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

loggin: some cleanup, particularly of write-message.

db4
John Benediktsson 2014-03-11 11:22:24 -07:00
parent 80f88318a6
commit e0e88895a1
2 changed files with 22 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/logging/logging.factor
View File

@ -21,11 +21,11 @@ log-level [ DEBUG ] initialize
{ WARNING 20 } { WARNING 20 }
{ ERROR 30 } { ERROR 30 }
{ CRITICAL 40 } { CRITICAL 40 }
} ; } ; inline
ERROR: undefined-log-level ; ERROR: undefined-log-level ;
: log-level<=> ( log-level log-level -- ? ) : log-level<=> ( log-level log-level -- <=> )
[ log-levels at* [ undefined-log-level ] unless ] compare ; [ log-levels at* [ undefined-log-level ] unless ] compare ;
: log? ( log-level -- ? ) : log? ( log-level -- ? )

45
basis/logging/server/server.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel io io.files io.pathnames io.directories USING: assocs calendar calendar.format combinators
io.encodings.utf8 calendar calendar.format sequences continuations concurrency.messaging continuations debugger destructors init io
destructors prettyprint assocs math.parser words debugger math io.directories io.encodings.utf8 io.files io.pathnames kernel
combinators concurrency.messaging threads arrays init math.ranges literals math math.parser math.ranges namespaces sequences
strings ; strings threads ;
IN: logging.server IN: logging.server
: log-root ( -- string ) : log-root ( -- string )
\ log-root get "logs" resource-path or ; \ log-root get [ "logs" resource-path ] unless* ;
: log-path ( service -- path ) : log-path ( service -- path )
log-root prepend-path ; log-root prepend-path ;
@ -26,32 +26,26 @@ SYMBOL: log-files
: log-stream ( service -- stream ) : log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ; log-files get [ open-log-stream ] cache ;
: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable : timestamp-header. ( -- )
"[" write now (timestamp>rfc3339) "] " write ;
: (write-message) ( msg word-name level multi? -- ) CONSTANT: multiline-header $[ 20 CHAR: - <string> ]
[
"[" write multiline-header write "] " write : multiline-header. ( -- )
] [ "[" write multiline-header write "] " write ;
"[" write now (timestamp>rfc3339) "] " write
] if
write bl write ": " write print ;
: write-message ( msg word-name level -- ) : write-message ( msg word-name level -- )
[ harvest ] 2dip { [ harvest ] 2dip pick empty? [ 3drop ] [
{ [ pick empty? ] [ 3drop ] } timestamp-header.
{ [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] } [ write bl write ": " write print ] 2curry
[ [ multiline-header. ] swap interleave
[ [ first ] 2dip f (write-message) ] ] if ;
[ [ rest ] 2dip [ t (write-message) ] 2curry each ]
3bi
]
} cond ;
: (log-message) ( msg -- ) : (log-message) ( msg -- )
#! msg: { msg word-name level service } #! msg: { msg word-name level service }
first4 log-stream [ write-message flush ] with-output-stream* ; first4 log-stream [ write-message flush ] with-output-stream* ;
: try-dispose ( stream -- ) : try-dispose ( obj -- )
[ dispose ] curry [ error. ] recover ; [ dispose ] curry [ error. ] recover ;
: close-log ( service -- ) : close-log ( service -- )
@ -67,7 +61,8 @@ CONSTANT: keep-logs 10
: ?delete-file ( path -- ) : ?delete-file ( path -- )
dup exists? [ delete-file ] [ drop ] if ; dup exists? [ delete-file ] [ drop ] if ;
: delete-oldest ( service -- ) keep-logs log# ?delete-file ; : delete-oldest ( service -- )
keep-logs log# ?delete-file ;
: ?move-file ( old new -- ) : ?move-file ( old new -- )
over exists? [ move-file ] [ 2drop ] if ; over exists? [ move-file ] [ 2drop ] if ;