steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

New logging framework

db4
Slava Pestov 2008-02-07 17:07:43 -06:00
parent 2126903739
commit 5310a2cabe
29 changed files with 523 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/concurrency/distributed/distributed.factor Normal file → Executable file
View File

@ -14,7 +14,7 @@ C: <node> node
: node-server ( port -- ) : node-server ( port -- )
internet-server internet-server
"concurrency" "concurrency.distributed"
[ handle-node-client ] with-server ; [ handle-node-client ] with-server ;
: send-to-node ( msg pid host port -- ) : send-to-node ( msg pid host port -- )

25
extra/http/server/responders/responders.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences 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 IN: http.server.responders
@ -22,7 +22,7 @@ SYMBOL: responders
<html> <body> <h1> write </h1> </body> </html> ; <html> <body> <h1> write </h1> </body> </html> ;
: error-head ( error -- ) : error-head ( error -- )
dup log-error response response
H{ { "Content-Type" V{ "text/html" } } } print-header nl ; H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
: httpd-error ( error -- ) : httpd-error ( error -- )
@ -30,6 +30,8 @@ SYMBOL: responders
dup error-head dup error-head
"head" "method" get = [ drop ] [ error-body ] if ; "head" "method" get = [ drop ] [ error-body ] if ;
\ httpd-error ERROR add-error-logging
: bad-request ( -- ) : bad-request ( -- )
[ [
! Make httpd-error print a body ! Make httpd-error print a body
@ -84,7 +86,10 @@ SYMBOL: max-post-request
: read-post-request ( header -- str hash ) : read-post-request ( header -- str hash )
content-length [ read dup query>hash ] [ f f ] if* ; content-length [ read dup query>hash ] [ f f ] if* ;
: log-headers ( hash -- ) LOG: log-headers DEBUG
: interesting-headers ( assoc -- string )
[
[ [
drop { drop {
"user-agent" "user-agent"
@ -93,8 +98,9 @@ SYMBOL: max-post-request
"host" "host"
} member? } member?
] assoc-subset [ ] assoc-subset [
": " swap 3append log-message ": " swap 3append % "\n" %
] multi-assoc-each ; ] multi-assoc-each
] "" make ;
: prepare-url ( url -- url ) : prepare-url ( url -- url )
#! This is executed in the with-request namespace. #! This is executed in the with-request namespace.
@ -105,7 +111,7 @@ SYMBOL: max-post-request
: prepare-header ( -- ) : prepare-header ( -- )
read-header read-header
dup "header" set dup "header" set
dup log-headers dup interesting-headers log-headers
read-post-request "response" set "raw-response" set ; read-post-request "response" set "raw-response" set ;
! Responders are called in a new namespace with these ! Responders are called in a new namespace with these
@ -177,9 +183,6 @@ SYMBOL: max-post-request
"/" "responder-url" set "/" "responder-url" set
"default" responder call-responder ; "default" responder call-responder ;
: log-responder ( path -- )
"Calling responder " swap append log-message ;
: trim-/ ( url -- url ) : trim-/ ( url -- url )
#! Trim a leading /, if there is one. #! Trim a leading /, if there is one.
"/" ?head drop ; "/" ?head drop ;
@ -199,13 +202,15 @@ SYMBOL: max-post-request
#! /foo/bar... - default responder used #! /foo/bar... - default responder used
#! /responder/foo/bar - responder foo, argument bar #! /responder/foo/bar - responder foo, argument bar
vhost [ vhost [
dup log-responder trim-/ "responder/" ?head [ trim-/ "responder/" ?head [
serve-explicit-responder serve-explicit-responder
] [ ] [
serve-default-responder serve-default-responder
] if ] if
] bind ; ] bind ;
\ serve-responder DEBUG add-input-logging
: no-such-responder ( -- ) : no-such-responder ( -- )
"404 No such responder" httpd-error ; "404 No such responder" httpd-error ;

6
extra/http/server/server.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io strings splitting USING: assocs kernel namespaces io strings splitting
threads http http.server.responders sequences prettyprint threads http http.server.responders sequences prettyprint
io.server io.logging ; io.server logging ;
IN: http.server IN: http.server
@ -36,7 +36,6 @@ IN: http.server
[ (handle-request) serve-responder ] with-scope ; [ (handle-request) serve-responder ] with-scope ;
: parse-request ( request -- ) : parse-request ( request -- )
dup log-message
" " split1 dup [ " " split1 dup [
" HTTP" split1 drop url>path secure-path dup [ " HTTP" split1 drop url>path secure-path dup [
swap handle-request swap handle-request
@ -47,8 +46,9 @@ IN: http.server
2drop bad-request 2drop bad-request
] if ; ] if ;
\ parse-request NOTICE add-input-logging
: httpd ( port -- ) : httpd ( port -- )
"Starting HTTP server on port " write dup . flush
internet-server "http.server" [ internet-server "http.server" [
60000 stdio get set-timeout 60000 stdio get set-timeout
readln [ parse-request ] when* readln [ parse-request ] when*

26
extra/io/logging/logging-docs.factor
View File

@ -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 } ")." } ;

47
extra/io/logging/logging.factor
View File

@ -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
extra/io/logging/summary.txt
View File

@ -1 +0,0 @@
Basic logging framework for server applications

40
extra/io/server/server.factor
View File

@ -1,32 +1,34 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 math math.parser namespaces parser sequences strings
prettyprint debugger quotations calendar qualified ; prettyprint debugger quotations calendar qualified ;
QUALIFIED: concurrency QUALIFIED: concurrency
IN: io.server IN: io.server
: with-client ( quot client -- ) LOG: accepted-connection NOTICE
dup log-client
[ swap with-stream ] 2curry concurrency:spawn drop ; inline : 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 -- ) : 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 -- ) : server-loop ( server quot -- )
[ accept-loop ] curry with-disposal ; inline [ accept-loop ] curry with-disposal ; inline
: spawn-server ( addrspec quot -- ) : spawn-server ( addrspec quot -- )
"Waiting for connections on " pick unparse append >r <server> r> server-loop ; inline
log-message
[ \ spawn-server NOTICE add-error-logging
>r <server> r> server-loop
] [
"Cannot spawn server: " print
print-error
2drop
] recover ; inline
: local-server ( port -- seq ) : local-server ( port -- seq )
"localhost" swap t resolve-host ; "localhost" swap t resolve-host ;
@ -39,19 +41,21 @@ IN: io.server
[ spawn-server ] curry concurrency:parallel-each [ spawn-server ] curry concurrency:parallel-each
] curry with-logging ; inline ] curry with-logging ; inline
: log-datagram ( addrspec -- ) : received-datagram ( addrspec -- ) drop ;
"Received datagram from " swap unparse append log-message ;
\ received-datagram NOTICE add-input-logging
: datagram-loop ( quot datagram -- ) : 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 pick [ send ] [ 3drop ] keep
] 2keep datagram-loop ; inline ] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- ) : spawn-datagrams ( quot addrspec -- )
"Waiting for datagrams on " over unparse append log-message
<datagram> [ datagram-loop ] with-disposal ; inline <datagram> [ datagram-loop ] with-disposal ; inline
\ spawn-datagrams NOTICE add-input-logging
: with-datagrams ( seq service quot -- ) : with-datagrams ( seq service quot -- )
[ [
[ swap spawn-datagrams ] curry concurrency:parallel-each [ swap spawn-datagrams ] curry concurrency:parallel-each

69
extra/logging/analysis/analysis.factor Executable file
View File

@ -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. ;

0
extra/io/logging/authors.txt → extra/logging/analysis/authors.txt Normal file → Executable file
View File

1
extra/logging/analysis/summary.txt Executable file
View File

@ -0,0 +1 @@
Analyze logs and produce summaries

1
extra/logging/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/logging/insomniac/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

49
extra/logging/insomniac/insomniac.factor Executable file
View File

@ -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 ;

1
extra/logging/insomniac/summary.txt Executable file
View File

@ -0,0 +1 @@
Task which rotates logs and e-mails summaries

122
extra/logging/logging.factor Executable file
View File

@ -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

1
extra/logging/parser/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

66
extra/logging/parser/parser.factor Executable file
View File

@ -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 ;

1
extra/logging/parser/summary.txt Executable file
View File

@ -0,0 +1 @@
Log parser

1
extra/logging/server/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

101
extra/logging/server/server.factor Executable file
View File

@ -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

1
extra/logging/server/summary.txt Executable file
View File

@ -0,0 +1 @@
Distributed concurrency log server

1
extra/logging/summary.txt Executable file
View File

@ -0,0 +1 @@
AOP Logging framework with support for log rotation and machine-readable logs

6
extra/raptor/cron/cron.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: kernel namespaces threads sequences calendar USING: kernel namespaces threads sequences calendar
combinators.cleave combinators.lib ; combinators.cleave combinators.lib debugger ;
IN: raptor.cron IN: raptor.cron
@ -43,9 +43,9 @@ C: <when> when
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: recurring-job ( when quot -- ) : 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/smtp/smtp-tests.factor Normal file → Executable file
View File

@ -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 ; smtp.server kernel sequences namespaces ;
IN: temporary IN: temporary

35
extra/smtp/smtp.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 combinators sequences.lib splitting assocs strings math.parser
random system calendar ; random system calendar ;
@ -12,21 +12,18 @@ SYMBOL: smtp-port 25 smtp-port set-global
SYMBOL: read-timeout 60000 read-timeout set-global SYMBOL: read-timeout 60000 read-timeout set-global
SYMBOL: esmtp t esmtp set-global SYMBOL: esmtp t esmtp set-global
: log-smtp-connection ( host port -- ) : log-smtp-connection ( host port -- ) 2drop ;
[
"Establishing SMTP connection to " % swap % ":" % # \ log-smtp-connection NOTICE add-input-logging
] "" make log-message ;
: with-smtp-connection ( quot -- ) : with-smtp-connection ( quot -- )
[
smtp-host get smtp-port get smtp-host get smtp-port get
2dup log-smtp-connection 2dup log-smtp-connection
<inet> <client> [ <inet> <client> [
smtp-domain [ host-name or ] change smtp-domain [ host-name or ] change
read-timeout get stdio get set-timeout read-timeout get stdio get set-timeout
call call
] with-stream ] with-stream ; inline
] with-log-stdio ; inline
: crlf "\r\n" write ; : crlf "\r\n" write ;
@ -58,20 +55,20 @@ SYMBOL: esmtp t esmtp set-global
: quit ( -- ) : quit ( -- )
"QUIT" write crlf ; "QUIT" write crlf ;
: log-response ( string -- ) "SMTP: " swap append log-message ; LOG: smtp-response DEBUG
: check-response ( response -- ) : check-response ( response -- )
{ {
{ [ dup "220" head? ] [ log-response ] } { [ dup "220" head? ] [ smtp-response ] }
{ [ dup "235" swap subseq? ] [ log-response ] } { [ dup "235" swap subseq? ] [ smtp-response ] }
{ [ dup "250" head? ] [ log-response ] } { [ dup "250" head? ] [ smtp-response ] }
{ [ dup "221" head? ] [ log-response ] } { [ dup "221" head? ] [ smtp-response ] }
{ [ dup "bye" head? ] [ log-response ] } { [ dup "bye" head? ] [ smtp-response ] }
{ [ dup "4" head? ] [ "server busy" throw ] } { [ dup "4" head? ] [ "server busy" throw ] }
{ [ dup "354" head? ] [ log-response ] } { [ dup "354" head? ] [ smtp-response ] }
{ [ dup "50" head? ] [ log-response "syntax error" throw ] } { [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
{ [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ log-response "fatal error" throw ] } { [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
{ [ t ] [ "unknown error" throw ] } { [ t ] [ "unknown error" throw ] }
} cond ; } cond ;
@ -80,7 +77,7 @@ SYMBOL: esmtp t esmtp set-global
: process-multiline ( multiline -- response ) : process-multiline ( multiline -- response )
>r readln r> 2dup " " append head? [ >r readln r> 2dup " " append head? [
drop dup log-response drop dup smtp-response
] [ ] [
swap check-response process-multiline swap check-response process-multiline
] if ; ] if ;

20
extra/tools/annotations/annotations.factor
View File

@ -7,23 +7,31 @@ IN: tools.annotations
: reset ( word -- ) : reset ( word -- )
dup "unannotated-def" word-prop [ dup "unannotated-def" word-prop [
[ [
dup "unannotated-def" word-prop define dup dup "unannotated-def" word-prop define
] with-compilation-unit ] with-compilation-unit
f "unannotated-def" set-word-prop
] [ drop ] if ; ] [ drop ] if ;
: annotate ( word quot -- ) : annotate ( word quot -- )
over "unannotated-def" word-prop [
"Cannot annotate a word twice" throw
] when
[ [
over dup word-def "unannotated-def" set-word-prop over dup word-def "unannotated-def" set-word-prop
>r dup word-def r> call define >r dup word-def r> call define
] with-compilation-unit ; inline ] with-compilation-unit ; inline
: word-inputs ( word -- seq )
stack-effect [
>r datastack r> effect-in length tail*
] [
datastack
] if* ;
: entering ( str -- ) : entering ( str -- )
"/-- Entering: " write dup . "/-- Entering: " write dup .
stack-effect [ word-inputs stack.
>r datastack r> effect-in length tail* stack. "\\--" print flush ;
] [
.s
] if* "\\--" print flush ;
: leaving ( str -- ) : leaving ( str -- )
"/-- Leaving: " write dup . "/-- Leaving: " write dup .

1
extra/tools/browser/browser.factor
View File

@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq )
{ [ "windows." ?head ] [ t ] } { [ "windows." ?head ] [ t ] }
{ [ "cocoa" ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] }
{ [ ".test" ?tail ] [ t ] } { [ ".test" ?tail ] [ t ] }
{ [ "raptor" ?head ] [ t ] }
{ [ dup "tools.deploy.app" = ] [ t ] } { [ dup "tools.deploy.app" = ] [ t ] }
{ [ t ] [ f ] } { [ t ] [ f ] }
} cond nip ; } cond nip ;

18
extra/webapps/file/file.factor
View File

@ -3,7 +3,7 @@
USING: calendar html io io.files kernel math math.parser USING: calendar html io io.files kernel math math.parser
http.server.responders http.server.templating namespaces parser http.server.responders http.server.templating namespaces parser
sequences strings assocs hashtables debugger http.mime sorting sequences strings assocs hashtables debugger http.mime sorting
html.elements ; html.elements logging ;
IN: webapps.file IN: webapps.file
@ -58,6 +58,8 @@ SYMBOL: page
[ [ dup page set run-template-file ] with-scope ] try [ [ dup page set run-template-file ] with-scope ] try
drop ; drop ;
\ run-page DEBUG add-input-logging
: include-page ( filename -- ) : include-page ( filename -- )
"doc-root" get swap path+ run-page ; "doc-root" get swap path+ run-page ;
@ -69,6 +71,8 @@ SYMBOL: page
dup mime-type dup "application/x-factor-server-page" = dup mime-type dup "application/x-factor-server-page" =
[ drop serve-fhtml ] [ serve-static ] if ; [ drop serve-fhtml ] [ serve-static ] if ;
\ serve-file NOTICE add-input-logging
: file. ( name dirp -- ) : file. ( name dirp -- )
[ "/" append ] when [ "/" append ] when
dup <a =href a> write </a> ; dup <a =href a> write </a> ;
@ -104,15 +108,15 @@ SYMBOL: page
] if ; ] if ;
: serve-object ( filename -- ) : 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 ( -- ) : file-responder ( -- )
"doc-root" get [ "doc-root" get [
"argument" get serving-path dup exists? [ "argument" get serve-object
serve-object
] [
drop "404 not found" httpd-error
] if
] [ ] [
"404 doc-root not set" httpd-error "404 doc-root not set" httpd-error
] if ; ] if ;

20
extra/webapps/planet/planet.factor
View File

@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting furnace http.server.templating calendar math.parser splitting
continuations debugger system http.server.responders continuations debugger system http.server.responders
xml.writer prettyprint io.logging ; xml.writer prettyprint logging ;
IN: webapps.planet IN: webapps.planet
: print-posting-summary ( posting -- ) : print-posting-summary ( posting -- )
@ -75,27 +75,19 @@ SYMBOL: cached-postings
SYMBOL: last-update 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' ) : <posting> ( author entry -- entry' )
clone clone
[ ": " swap entry-title 3append ] keep [ ": " swap entry-title 3append ] keep
[ set-entry-title ] keep ; [ set-entry-title ] keep ;
: ?fetch-feed ( triple -- feed/f ) : fetch-feed ( url -- feed )
[ download-feed feed-entries ;
fetch-feed
] [ \ fetch-feed DEBUG add-error-logging
swap [ . error. ] to-log-stream f
] recover ;
: fetch-blogroll ( blogroll -- entries ) : fetch-blogroll ( blogroll -- entries )
dup 0 <column> dup 0 <column>
swap [ ?fetch-feed ] parallel-map swap [ fetch-feed ] parallel-map
[ [ <posting> ] with map ] 2map concat ; [ [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )