New logging framework
Slava Pestov
parent
2126903739
commit
5310a2cabe
|
|
@ -14,7 +14,7 @@ C: <node> node
|
|||
|
||||
: node-server ( port -- )
|
||||
internet-server
|
||||
"concurrency"
|
||||
"concurrency.distributed"
|
||||
[ handle-node-client ] with-server ;
|
||||
|
||||
: send-to-node ( msg pid host port -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs hashtables html html.elements splitting
|
||||
http io kernel math math.parser namespaces parser sequences
|
||||
strings io.server vectors assocs.lib io.logging ;
|
||||
strings io.server vectors assocs.lib logging ;
|
||||
|
||||
IN: http.server.responders
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ SYMBOL: responders
|
|||
<html> <body> <h1> write </h1> </body> </html> ;
|
||||
|
||||
: error-head ( error -- )
|
||||
dup log-error response
|
||||
response
|
||||
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
|
|
@ -30,6 +30,8 @@ SYMBOL: responders
|
|||
dup error-head
|
||||
"head" "method" get = [ drop ] [ error-body ] if ;
|
||||
|
||||
\ httpd-error ERROR add-error-logging
|
||||
|
||||
: bad-request ( -- )
|
||||
[
|
||||
! Make httpd-error print a body
|
||||
|
|
@ -84,17 +86,21 @@ SYMBOL: max-post-request
|
|||
: read-post-request ( header -- str hash )
|
||||
content-length [ read dup query>hash ] [ f f ] if* ;
|
||||
|
||||
: log-headers ( hash -- )
|
||||
LOG: log-headers DEBUG
|
||||
|
||||
: interesting-headers ( assoc -- string )
|
||||
[
|
||||
drop {
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append log-message
|
||||
] multi-assoc-each ;
|
||||
[
|
||||
drop {
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append % "\n" %
|
||||
] multi-assoc-each
|
||||
] "" make ;
|
||||
|
||||
: prepare-url ( url -- url )
|
||||
#! This is executed in the with-request namespace.
|
||||
|
|
@ -105,7 +111,7 @@ SYMBOL: max-post-request
|
|||
: prepare-header ( -- )
|
||||
read-header
|
||||
dup "header" set
|
||||
dup log-headers
|
||||
dup interesting-headers log-headers
|
||||
read-post-request "response" set "raw-response" set ;
|
||||
|
||||
! Responders are called in a new namespace with these
|
||||
|
|
@ -177,9 +183,6 @@ SYMBOL: max-post-request
|
|||
"/" "responder-url" set
|
||||
"default" responder call-responder ;
|
||||
|
||||
: log-responder ( path -- )
|
||||
"Calling responder " swap append log-message ;
|
||||
|
||||
: trim-/ ( url -- url )
|
||||
#! Trim a leading /, if there is one.
|
||||
"/" ?head drop ;
|
||||
|
|
@ -199,13 +202,15 @@ SYMBOL: max-post-request
|
|||
#! /foo/bar... - default responder used
|
||||
#! /responder/foo/bar - responder foo, argument bar
|
||||
vhost [
|
||||
dup log-responder trim-/ "responder/" ?head [
|
||||
trim-/ "responder/" ?head [
|
||||
serve-explicit-responder
|
||||
] [
|
||||
serve-default-responder
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
\ serve-responder DEBUG add-input-logging
|
||||
|
||||
: no-such-responder ( -- )
|
||||
"404 No such responder" httpd-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel namespaces io strings splitting
|
||||
threads http http.server.responders sequences prettyprint
|
||||
io.server io.logging ;
|
||||
io.server logging ;
|
||||
|
||||
IN: http.server
|
||||
|
||||
|
|
@ -36,7 +36,6 @@ IN: http.server
|
|||
[ (handle-request) serve-responder ] with-scope ;
|
||||
|
||||
: parse-request ( request -- )
|
||||
dup log-message
|
||||
" " split1 dup [
|
||||
" HTTP" split1 drop url>path secure-path dup [
|
||||
swap handle-request
|
||||
|
|
@ -47,8 +46,9 @@ IN: http.server
|
|||
2drop bad-request
|
||||
] if ;
|
||||
|
||||
\ parse-request NOTICE add-input-logging
|
||||
|
||||
: httpd ( port -- )
|
||||
"Starting HTTP server on port " write dup . flush
|
||||
internet-server "http.server" [
|
||||
60000 stdio get set-timeout
|
||||
readln [ parse-request ] when*
|
||||
|
|
|
|||
|
|
@ -1,26 +0,0 @@
|
|||
IN: io.logging
|
||||
USING: help.markup help.syntax io ;
|
||||
|
||||
HELP: log-stream
|
||||
{ $var-description "Holds an output stream for logging messages." }
|
||||
{ $see-also log-error log-client with-logging } ;
|
||||
|
||||
HELP: log-message
|
||||
{ $values { "str" "a string" } }
|
||||
{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." }
|
||||
{ $see-also log-error log-client } ;
|
||||
|
||||
HELP: log-error
|
||||
{ $values { "str" "a string" } }
|
||||
{ $description "Logs an error message." }
|
||||
{ $see-also log-message log-client } ;
|
||||
|
||||
HELP: log-client
|
||||
{ $values { "client" "a client socket stream" } }
|
||||
{ $description "Logs an incoming client connection." }
|
||||
{ $see-also log-message log-error } ;
|
||||
|
||||
HELP: with-logging
|
||||
{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } }
|
||||
{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ;
|
||||
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel io calendar sequences io.files
|
||||
io.sockets continuations prettyprint ;
|
||||
IN: io.logging
|
||||
|
||||
SYMBOL: log-stream
|
||||
|
||||
: to-log-stream ( quot -- )
|
||||
log-stream get swap with-stream* ; inline
|
||||
|
||||
: log-message ( str -- )
|
||||
[
|
||||
"[" write now timestamp>string write "] " write
|
||||
print flush
|
||||
] to-log-stream ;
|
||||
|
||||
: log-error ( str -- ) "Error: " swap append log-message ;
|
||||
|
||||
: log-client ( client -- )
|
||||
"Accepted connection from "
|
||||
swap client-stream-addr unparse append log-message ;
|
||||
|
||||
: log-file ( service -- path )
|
||||
".log" append resource-path ;
|
||||
|
||||
: with-log-stream ( stream quot -- )
|
||||
log-stream get [ nip call ] [
|
||||
log-stream swap with-variable
|
||||
] if ; inline
|
||||
|
||||
: with-log-file ( file quot -- )
|
||||
>r <file-appender> r>
|
||||
[ with-log-stream ] curry
|
||||
with-disposal ; inline
|
||||
|
||||
: with-log-stdio ( quot -- )
|
||||
stdio get swap with-log-stream ; inline
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
over [
|
||||
>r log-file
|
||||
"Writing log messages to " write dup print flush r>
|
||||
with-log-file
|
||||
] [
|
||||
nip with-log-stdio
|
||||
] if ; inline
|
||||
|
|
@ -1 +0,0 @@
|
|||
Basic logging framework for server applications
|
||||
|
|
@ -1,32 +1,34 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.sockets io.files io.logging continuations kernel
|
||||
USING: io io.sockets io.files logging continuations kernel
|
||||
math math.parser namespaces parser sequences strings
|
||||
prettyprint debugger quotations calendar qualified ;
|
||||
QUALIFIED: concurrency
|
||||
|
||||
IN: io.server
|
||||
|
||||
: with-client ( quot client -- )
|
||||
dup log-client
|
||||
[ swap with-stream ] 2curry concurrency:spawn drop ; inline
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-client ( client quot -- )
|
||||
[
|
||||
over client-stream-addr accepted-connection
|
||||
with-stream*
|
||||
] curry with-disposal ; inline
|
||||
|
||||
\ with-client NOTICE add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[ swap accept with-client ] 2keep accept-loop ; inline
|
||||
[
|
||||
>r accept r> [ with-client ] 2curry concurrency:spawn
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( server quot -- )
|
||||
[ accept-loop ] curry with-disposal ; inline
|
||||
|
||||
: spawn-server ( addrspec quot -- )
|
||||
"Waiting for connections on " pick unparse append
|
||||
log-message
|
||||
[
|
||||
>r <server> r> server-loop
|
||||
] [
|
||||
"Cannot spawn server: " print
|
||||
print-error
|
||||
2drop
|
||||
] recover ; inline
|
||||
>r <server> r> server-loop ; inline
|
||||
|
||||
\ spawn-server NOTICE add-error-logging
|
||||
|
||||
: local-server ( port -- seq )
|
||||
"localhost" swap t resolve-host ;
|
||||
|
|
@ -39,19 +41,21 @@ IN: io.server
|
|||
[ spawn-server ] curry concurrency:parallel-each
|
||||
] curry with-logging ; inline
|
||||
|
||||
: log-datagram ( addrspec -- )
|
||||
"Received datagram from " swap unparse append log-message ;
|
||||
: received-datagram ( addrspec -- ) drop ;
|
||||
|
||||
\ received-datagram NOTICE add-input-logging
|
||||
|
||||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup log-datagram >r swap call r> ] keep
|
||||
[ receive dup received-datagram >r swap call r> ] keep
|
||||
pick [ send ] [ 3drop ] keep
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
"Waiting for datagrams on " over unparse append log-message
|
||||
<datagram> [ datagram-loop ] with-disposal ; inline
|
||||
|
||||
\ spawn-datagrams NOTICE add-input-logging
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
[
|
||||
[ swap spawn-datagrams ] curry concurrency:parallel-each
|
||||
|
|
|
|||
|
|
@ -0,0 +1,69 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces words assocs logging sorting
|
||||
prettyprint io io.styles strings logging.parser ;
|
||||
IN: logging.analysis
|
||||
|
||||
SYMBOL: word-names
|
||||
SYMBOL: errors
|
||||
SYMBOL: word-histogram
|
||||
SYMBOL: message-histogram
|
||||
|
||||
: analyze-entry ( entry -- )
|
||||
dup second ERROR eq? [ dup errors get push ] when
|
||||
1 over third word-histogram get at+
|
||||
dup third word-names get member? [
|
||||
1 over 1 tail message-histogram get at+
|
||||
] when
|
||||
drop ;
|
||||
|
||||
: analyze-entries ( entries word-names -- errors word-histogram message-histogram )
|
||||
[
|
||||
word-names set
|
||||
V{ } clone errors set
|
||||
H{ } clone word-histogram set
|
||||
H{ } clone message-histogram set
|
||||
|
||||
[
|
||||
analyze-entry
|
||||
] each
|
||||
|
||||
errors get
|
||||
word-histogram get
|
||||
message-histogram get
|
||||
] with-scope ;
|
||||
|
||||
: histogram. ( assoc quot -- )
|
||||
standard-table-style [
|
||||
>r >alist sort-values <reversed> r> [
|
||||
[ >r swap r> with-cell pprint-cell ] with-row
|
||||
] curry assoc-each
|
||||
] tabular-output ;
|
||||
|
||||
: log-entry.
|
||||
[
|
||||
dup first [ write ] with-cell
|
||||
dup second [ pprint ] with-cell
|
||||
dup third [ write ] with-cell
|
||||
fourth "\n" join [ write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: errors. ( errors -- )
|
||||
standard-table-style
|
||||
[ [ log-entry. ] each ] tabular-output ;
|
||||
|
||||
: analysis. ( errors word-histogram message-histogram -- )
|
||||
"==== INTERESTING MESSAGES:" print nl
|
||||
"Total: " write dup values sum . nl
|
||||
[
|
||||
dup second write ": " write third "\n" join write
|
||||
] histogram.
|
||||
nl
|
||||
"==== WORDS:" print nl
|
||||
[ write ] histogram.
|
||||
nl
|
||||
"==== ERRORS:" print nl
|
||||
errors. ;
|
||||
|
||||
: log-analysis ( lines word-names -- )
|
||||
>r parse-log r> analyze-entries analysis. ;
|
||||
|
|
@ -1 +1 @@
|
|||
Slava Pestov
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Analyze logs and produce summaries
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.analysis logging.server logging smtp io.sockets
|
||||
kernel io.files io.streams.string namespaces raptor.cron ;
|
||||
IN: logging.insomniac
|
||||
|
||||
SYMBOL: insomniac-config
|
||||
|
||||
SYMBOL: insomniac-smtp-host
|
||||
SYMBOL: insomniac-smtp-port
|
||||
SYMBOL: insomniac-sender
|
||||
SYMBOL: insomniac-recipients
|
||||
|
||||
: ?log-analysis ( service word-names -- string/f )
|
||||
>r log-path 1 log# dup exists? [
|
||||
file-lines r> [ log-analysis ] string-out
|
||||
] [
|
||||
r> 2drop f
|
||||
] if ;
|
||||
|
||||
: with-insomniac-smtp ( quot -- )
|
||||
[
|
||||
insomniac-smtp-host get [ smtp-host set ] when*
|
||||
insomniac-smtp-port get [ smtp-port set ] when*
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
: email-subject ( service -- string )
|
||||
[ "[INSOMNIAC] " % % " on " % host-name % ] "" make ;
|
||||
|
||||
: (email-log-report) ( service word-names -- )
|
||||
[
|
||||
over >r
|
||||
?log-analysis dup [
|
||||
r> email-subject
|
||||
insomniac-recipients get
|
||||
insomniac-sender get
|
||||
send-simple-message
|
||||
] [ r> 2drop ] if
|
||||
] with-insomniac-smtp ;
|
||||
|
||||
: email-log-report ( service word-names -- )
|
||||
(email-log-report) ;
|
||||
|
||||
\ email-log-report NOTICE add-error-logging
|
||||
|
||||
: schedule-insomniac ( service word-names -- )
|
||||
{ 25 } { 6 } f f f <when> -rot
|
||||
[ email-log-report ] 2curry schedule ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Task which rotates logs and e-mails summaries
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.server sequences namespaces concurrency
|
||||
words kernel arrays shuffle tools.annotations
|
||||
prettyprint.config prettyprint debugger io.streams.string
|
||||
splitting continuations effects arrays.lib parser strings
|
||||
combinators.lib ;
|
||||
IN: logging
|
||||
|
||||
SYMBOL: DEBUG
|
||||
SYMBOL: NOTICE
|
||||
SYMBOL: WARNING
|
||||
SYMBOL: ERROR
|
||||
SYMBOL: CRITICAL
|
||||
|
||||
: log-levels
|
||||
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
|
||||
: send-to-log-server ( array string -- )
|
||||
add* "log-server" get send ;
|
||||
|
||||
SYMBOL: log-service
|
||||
|
||||
: check-log-message
|
||||
pick string?
|
||||
pick word?
|
||||
pick word? and and
|
||||
[ "Bad parameters to log-message" throw ] unless ;
|
||||
|
||||
: log-message ( msg word level -- )
|
||||
check-log-message
|
||||
log-service get dup [
|
||||
>r >r >r string-lines r> word-name r> word-name r>
|
||||
4array "log-message" send-to-log-server
|
||||
] [
|
||||
4drop
|
||||
] if ;
|
||||
|
||||
: rotate-logs ( -- )
|
||||
{ } "rotate-logs" send-to-log-server ;
|
||||
|
||||
: close-log-files ( -- )
|
||||
{ } "close-log-files" send-to-log-server ;
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
log-service swap with-variable ; inline
|
||||
|
||||
! Aspect-oriented programming idioms
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: one-string?
|
||||
{
|
||||
[ dup array? ]
|
||||
[ dup length 1 = ]
|
||||
[ dup first string? ]
|
||||
} && nip ;
|
||||
|
||||
: inputs>message ( obj -- inputs>message )
|
||||
dup one-string? [ first ] [
|
||||
H{
|
||||
{ string-limit f }
|
||||
{ line-limit 1 }
|
||||
{ nesting-limit 3 }
|
||||
{ margin 0 }
|
||||
} clone [ unparse ] bind
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (define-logging) ( word level quot -- )
|
||||
>r >r dup r> r> 2curry annotate ;
|
||||
|
||||
: call-logging-quot ( quot word level -- quot' )
|
||||
"called" -rot [ log-message ] 3curry swap compose ;
|
||||
|
||||
: add-logging ( word level -- )
|
||||
[ call-logging-quot ] (define-logging) ;
|
||||
|
||||
: log-inputs ( n word level -- )
|
||||
log-service get [
|
||||
>r >r [ ndup ] keep narray inputs>message
|
||||
r> r> log-message
|
||||
] [
|
||||
3drop
|
||||
] if ; inline
|
||||
|
||||
: input# stack-effect effect-in length ;
|
||||
|
||||
: input-logging-quot ( quot word level -- quot' )
|
||||
over input# -rot [ log-inputs ] 3curry swap compose ;
|
||||
|
||||
: add-input-logging ( word level -- )
|
||||
[ input-logging-quot ] (define-logging) ;
|
||||
|
||||
: (log-error) ( object word level -- )
|
||||
log-service get [
|
||||
>r >r [ print-error ] string-out r> r> log-message
|
||||
] [
|
||||
2drop rethrow
|
||||
] if ;
|
||||
|
||||
: log-error ( object word -- ) ERROR (log-error) ;
|
||||
|
||||
: log-critical ( object word -- ) CRITICAL (log-error) ;
|
||||
|
||||
: error-logging-quot ( quot word -- quot' )
|
||||
dup stack-effect effect-in length
|
||||
[ >r log-error r> ndrop ] 2curry
|
||||
[ recover ] 2curry ;
|
||||
|
||||
: add-error-logging ( word level -- )
|
||||
[ over >r input-logging-quot r> error-logging-quot ]
|
||||
(define-logging) ;
|
||||
|
||||
: LOG:
|
||||
#! Syntax: name level
|
||||
CREATE
|
||||
dup reset-generic
|
||||
dup scan-word
|
||||
[ >r >r 1array inputs>message r> r> log-message ] 2curry
|
||||
define ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser-combinators memoize kernel sequences
|
||||
logging arrays words strings vectors io io.files
|
||||
namespaces combinators combinators.lib logging.server ;
|
||||
IN: logging.parser
|
||||
|
||||
: string-of satisfy <!*> [ >string ] <@ ;
|
||||
|
||||
: 'date'
|
||||
[ CHAR: ] eq? not ] string-of
|
||||
"[" "]" surrounded-by ;
|
||||
|
||||
: 'log-level'
|
||||
log-levels [
|
||||
[ word-name token ] keep [ nip ] curry <@
|
||||
] map <or-parser> ;
|
||||
|
||||
: 'word-name'
|
||||
[ " :" member? not ] string-of ;
|
||||
|
||||
SYMBOL: malformed
|
||||
|
||||
: 'malformed-line'
|
||||
[ drop t ] string-of [ malformed swap 2array ] <@ ;
|
||||
|
||||
: 'log-message'
|
||||
[ drop t ] string-of [ 1vector ] <@ ;
|
||||
|
||||
MEMO: 'log-line' ( -- parser )
|
||||
'date' " " token <&
|
||||
'log-level' " " token <& <&>
|
||||
'word-name' ": " token <& <:&>
|
||||
'log-message' <:&>
|
||||
'malformed-line' <|> ;
|
||||
|
||||
: parse-log-line ( string -- entry )
|
||||
'log-line' parse-1 ;
|
||||
|
||||
: malformed? ( line -- ? )
|
||||
first malformed eq? ;
|
||||
|
||||
: multiline? ( line -- ? )
|
||||
first first CHAR: - = ;
|
||||
|
||||
: malformed-line
|
||||
"Warning: malformed log line:" print
|
||||
second print ;
|
||||
|
||||
: add-multiline ( line -- )
|
||||
building get empty? [
|
||||
"Warning: log begins with multiline entry" print drop
|
||||
] [
|
||||
fourth first building get peek fourth push
|
||||
] if ;
|
||||
|
||||
: parse-log ( lines -- entries )
|
||||
[
|
||||
[
|
||||
parse-log-line {
|
||||
{ [ dup malformed? ] [ malformed-line ] }
|
||||
{ [ dup multiline? ] [ add-multiline ] }
|
||||
{ [ t ] [ , ] }
|
||||
} cond
|
||||
] each
|
||||
] { } make ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Log parser
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel io calendar sequences io.files
|
||||
io.sockets continuations prettyprint assocs math.parser
|
||||
words debugger math combinators concurrency arrays init
|
||||
math.ranges strings ;
|
||||
IN: logging.server
|
||||
|
||||
: log-root ( -- string )
|
||||
\ log-root get "logs" resource-path or ;
|
||||
|
||||
: log-path ( service -- path )
|
||||
log-root swap path+ ;
|
||||
|
||||
: log# ( path n -- path' )
|
||||
number>string ".log" append path+ ;
|
||||
|
||||
SYMBOL: log-files
|
||||
|
||||
: open-log-stream ( service -- stream )
|
||||
log-path
|
||||
dup make-directories
|
||||
1 log# <file-appender> ;
|
||||
|
||||
: log-stream ( service -- stream )
|
||||
log-files get [ open-log-stream ] cache ;
|
||||
|
||||
: (write-message) ( msg word-name level multi? -- )
|
||||
[
|
||||
"[" write 20 CHAR: - <string> write "] " write
|
||||
] [
|
||||
"[" write now (timestamp>rfc3339) "] " write
|
||||
] if
|
||||
write bl write ": " write print ;
|
||||
|
||||
: write-message ( msg word-name level -- )
|
||||
rot [ empty? not ] subset {
|
||||
{ [ dup empty? ] [ 3drop ] }
|
||||
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
|
||||
{ [ t ] [
|
||||
[ first -rot f (write-message) ] 3keep
|
||||
1 tail -rot [ t (write-message) ] 2curry each
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
: (log-message) ( msg -- )
|
||||
#! msg: { msg word-name level service }
|
||||
first4 log-stream [ write-message flush ] with-stream* ;
|
||||
|
||||
: try-dispose ( stream -- )
|
||||
[ dispose ] curry [ error. ] recover ;
|
||||
|
||||
: close-log-file ( service -- )
|
||||
log-files get delete-at*
|
||||
[ try-dispose ] [ drop ] if ;
|
||||
|
||||
: (close-log-files) ( -- )
|
||||
log-files get
|
||||
dup values [ try-dispose ] each
|
||||
clear-assoc ;
|
||||
|
||||
: keep-logs 10 ;
|
||||
|
||||
: ?delete-file ( path -- )
|
||||
dup exists? [ delete-file ] [ drop ] if ;
|
||||
|
||||
: delete-oldest keep-logs log# ?delete-file ;
|
||||
|
||||
: ?rename-file ( old new -- )
|
||||
over exists? [ rename-file ] [ 2drop ] if ;
|
||||
|
||||
: advance-log ( path n -- )
|
||||
[ 1- log# ] 2keep log# ?rename-file ;
|
||||
|
||||
: rotate-log ( service -- )
|
||||
dup close-log-file
|
||||
log-path
|
||||
dup delete-oldest
|
||||
keep-logs 1 [a,b] [ advance-log ] with each ;
|
||||
|
||||
: (rotate-logs) ( -- )
|
||||
(close-log-files)
|
||||
log-root directory [ drop rotate-log ] assoc-each ;
|
||||
|
||||
: log-server-loop
|
||||
[
|
||||
receive unclip {
|
||||
{ "log-message" [ (log-message) ] }
|
||||
{ "rotate-logs" [ drop (rotate-logs) ] }
|
||||
{ "close-log-files" [ drop (close-log-files) ] }
|
||||
} case
|
||||
] [ error. (close-log-files) ] recover
|
||||
log-server-loop ;
|
||||
|
||||
: log-server ( -- )
|
||||
[ log-server-loop ] spawn "log-server" set-global ;
|
||||
|
||||
[
|
||||
H{ } clone log-files set-global
|
||||
log-server
|
||||
] "logging" add-init-hook
|
||||
|
|
@ -0,0 +1 @@
|
|||
Distributed concurrency log server
|
||||
|
|
@ -0,0 +1 @@
|
|||
AOP Logging framework with support for log rotation and machine-readable logs
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel namespaces threads sequences calendar
|
||||
combinators.cleave combinators.lib ;
|
||||
combinators.cleave combinators.lib debugger ;
|
||||
|
||||
IN: raptor.cron
|
||||
|
||||
|
|
@ -43,9 +43,9 @@ C: <when> when
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: recurring-job ( when quot -- )
|
||||
[ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
|
||||
[ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
|
||||
|
||||
: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
|
||||
: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: smtp tools.test io.streams.string io.logging threads
|
||||
USING: smtp tools.test io.streams.string threads
|
||||
smtp.server kernel sequences namespaces ;
|
||||
IN: temporary
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces io kernel io.logging io.sockets sequences
|
||||
USING: namespaces io kernel logging io.sockets sequences
|
||||
combinators sequences.lib splitting assocs strings math.parser
|
||||
random system calendar ;
|
||||
|
||||
|
|
@ -12,21 +12,18 @@ SYMBOL: smtp-port 25 smtp-port set-global
|
|||
SYMBOL: read-timeout 60000 read-timeout set-global
|
||||
SYMBOL: esmtp t esmtp set-global
|
||||
|
||||
: log-smtp-connection ( host port -- )
|
||||
[
|
||||
"Establishing SMTP connection to " % swap % ":" % #
|
||||
] "" make log-message ;
|
||||
: log-smtp-connection ( host port -- ) 2drop ;
|
||||
|
||||
\ log-smtp-connection NOTICE add-input-logging
|
||||
|
||||
: with-smtp-connection ( quot -- )
|
||||
[
|
||||
smtp-host get smtp-port get
|
||||
2dup log-smtp-connection
|
||||
<inet> <client> [
|
||||
smtp-domain [ host-name or ] change
|
||||
read-timeout get stdio get set-timeout
|
||||
call
|
||||
] with-stream
|
||||
] with-log-stdio ; inline
|
||||
smtp-host get smtp-port get
|
||||
2dup log-smtp-connection
|
||||
<inet> <client> [
|
||||
smtp-domain [ host-name or ] change
|
||||
read-timeout get stdio get set-timeout
|
||||
call
|
||||
] with-stream ; inline
|
||||
|
||||
: crlf "\r\n" write ;
|
||||
|
||||
|
|
@ -58,20 +55,20 @@ SYMBOL: esmtp t esmtp set-global
|
|||
: quit ( -- )
|
||||
"QUIT" write crlf ;
|
||||
|
||||
: log-response ( string -- ) "SMTP: " swap append log-message ;
|
||||
LOG: smtp-response DEBUG
|
||||
|
||||
: check-response ( response -- )
|
||||
{
|
||||
{ [ dup "220" head? ] [ log-response ] }
|
||||
{ [ dup "235" swap subseq? ] [ log-response ] }
|
||||
{ [ dup "250" head? ] [ log-response ] }
|
||||
{ [ dup "221" head? ] [ log-response ] }
|
||||
{ [ dup "bye" head? ] [ log-response ] }
|
||||
{ [ dup "220" head? ] [ smtp-response ] }
|
||||
{ [ dup "235" swap subseq? ] [ smtp-response ] }
|
||||
{ [ dup "250" head? ] [ smtp-response ] }
|
||||
{ [ dup "221" head? ] [ smtp-response ] }
|
||||
{ [ dup "bye" head? ] [ smtp-response ] }
|
||||
{ [ dup "4" head? ] [ "server busy" throw ] }
|
||||
{ [ dup "354" head? ] [ log-response ] }
|
||||
{ [ dup "50" head? ] [ log-response "syntax error" throw ] }
|
||||
{ [ dup "53" head? ] [ log-response "invalid authentication data" throw ] }
|
||||
{ [ dup "55" head? ] [ log-response "fatal error" throw ] }
|
||||
{ [ dup "354" head? ] [ smtp-response ] }
|
||||
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
|
||||
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
|
||||
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
|
||||
{ [ t ] [ "unknown error" throw ] }
|
||||
} cond ;
|
||||
|
||||
|
|
@ -80,7 +77,7 @@ SYMBOL: esmtp t esmtp set-global
|
|||
|
||||
: process-multiline ( multiline -- response )
|
||||
>r readln r> 2dup " " append head? [
|
||||
drop dup log-response
|
||||
drop dup smtp-response
|
||||
] [
|
||||
swap check-response process-multiline
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -7,23 +7,31 @@ IN: tools.annotations
|
|||
: reset ( word -- )
|
||||
dup "unannotated-def" word-prop [
|
||||
[
|
||||
dup "unannotated-def" word-prop define
|
||||
dup dup "unannotated-def" word-prop define
|
||||
] with-compilation-unit
|
||||
f "unannotated-def" set-word-prop
|
||||
] [ drop ] if ;
|
||||
|
||||
: annotate ( word quot -- )
|
||||
over "unannotated-def" word-prop [
|
||||
"Cannot annotate a word twice" throw
|
||||
] when
|
||||
[
|
||||
over dup word-def "unannotated-def" set-word-prop
|
||||
>r dup word-def r> call define
|
||||
] with-compilation-unit ; inline
|
||||
|
||||
: word-inputs ( word -- seq )
|
||||
stack-effect [
|
||||
>r datastack r> effect-in length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
|
||||
: entering ( str -- )
|
||||
"/-- Entering: " write dup .
|
||||
stack-effect [
|
||||
>r datastack r> effect-in length tail* stack.
|
||||
] [
|
||||
.s
|
||||
] if* "\\--" print flush ;
|
||||
word-inputs stack.
|
||||
"\\--" print flush ;
|
||||
|
||||
: leaving ( str -- )
|
||||
"/-- Leaving: " write dup .
|
||||
|
|
|
|||
|
|
@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
{ [ "windows." ?head ] [ t ] }
|
||||
{ [ "cocoa" ?head ] [ t ] }
|
||||
{ [ ".test" ?tail ] [ t ] }
|
||||
{ [ "raptor" ?head ] [ t ] }
|
||||
{ [ dup "tools.deploy.app" = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: calendar html io io.files kernel math math.parser
|
||||
http.server.responders http.server.templating namespaces parser
|
||||
sequences strings assocs hashtables debugger http.mime sorting
|
||||
html.elements ;
|
||||
html.elements logging ;
|
||||
|
||||
IN: webapps.file
|
||||
|
||||
|
|
@ -58,6 +58,8 @@ SYMBOL: page
|
|||
[ [ dup page set run-template-file ] with-scope ] try
|
||||
drop ;
|
||||
|
||||
\ run-page DEBUG add-input-logging
|
||||
|
||||
: include-page ( filename -- )
|
||||
"doc-root" get swap path+ run-page ;
|
||||
|
||||
|
|
@ -69,6 +71,8 @@ SYMBOL: page
|
|||
dup mime-type dup "application/x-factor-server-page" =
|
||||
[ drop serve-fhtml ] [ serve-static ] if ;
|
||||
|
||||
\ serve-file NOTICE add-input-logging
|
||||
|
||||
: file. ( name dirp -- )
|
||||
[ "/" append ] when
|
||||
dup <a =href a> write </a> ;
|
||||
|
|
@ -104,15 +108,15 @@ SYMBOL: page
|
|||
] if ;
|
||||
|
||||
: serve-object ( filename -- )
|
||||
dup directory? [ serve-directory ] [ serve-file ] if ;
|
||||
serving-path dup exists? [
|
||||
dup directory? [ serve-directory ] [ serve-file ] if
|
||||
] [
|
||||
drop "404 not found" httpd-error
|
||||
] if ;
|
||||
|
||||
: file-responder ( -- )
|
||||
"doc-root" get [
|
||||
"argument" get serving-path dup exists? [
|
||||
serve-object
|
||||
] [
|
||||
drop "404 not found" httpd-error
|
||||
] if
|
||||
"argument" get serve-object
|
||||
] [
|
||||
"404 doc-root not set" httpd-error
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting
|
|||
html.elements io assocs namespaces math threads vocabs html
|
||||
furnace http.server.templating calendar math.parser splitting
|
||||
continuations debugger system http.server.responders
|
||||
xml.writer prettyprint io.logging ;
|
||||
xml.writer prettyprint logging ;
|
||||
IN: webapps.planet
|
||||
|
||||
: print-posting-summary ( posting -- )
|
||||
|
|
@ -75,27 +75,19 @@ SYMBOL: cached-postings
|
|||
|
||||
SYMBOL: last-update
|
||||
|
||||
: fetch-feed ( triple -- feed )
|
||||
second
|
||||
"Fetching " over append log-message
|
||||
dup download-feed feed-entries
|
||||
"Done fetching " swap append log-message ;
|
||||
|
||||
: <posting> ( author entry -- entry' )
|
||||
clone
|
||||
[ ": " swap entry-title 3append ] keep
|
||||
[ set-entry-title ] keep ;
|
||||
|
||||
: ?fetch-feed ( triple -- feed/f )
|
||||
[
|
||||
fetch-feed
|
||||
] [
|
||||
swap [ . error. ] to-log-stream f
|
||||
] recover ;
|
||||
: fetch-feed ( url -- feed )
|
||||
download-feed feed-entries ;
|
||||
|
||||
\ fetch-feed DEBUG add-error-logging
|
||||
|
||||
: fetch-blogroll ( blogroll -- entries )
|
||||
dup 0 <column>
|
||||
swap [ ?fetch-feed ] parallel-map
|
||||
swap [ fetch-feed ] parallel-map
|
||||
[ [ <posting> ] with map ] 2map concat ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
|
|
|
|||
Loading…
Reference in New Issue