1 ! Copyright (C) 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: assocs calendar calendar.format combinators
\r
4 concurrency.messaging continuations debugger destructors init io
\r
5 io.directories io.encodings.utf8 io.files io.pathnames kernel
\r
6 literals math math.parser math.ranges namespaces sequences
\r
10 : log-root ( -- string )
\r
11 \ log-root get [ "logs" resource-path ] unless* ;
\r
13 : log-path ( service -- path )
\r
14 log-root prepend-path ;
\r
16 : log# ( path n -- path' )
\r
17 number>string ".log" append append-path ;
\r
21 : open-log-stream ( service -- stream )
\r
23 [ make-directories ]
\r
24 [ 1 log# utf8 <file-appender> ] bi ;
\r
26 : log-stream ( service -- stream )
\r
27 log-files get [ open-log-stream ] cache ;
\r
29 : timestamp-header. ( -- )
\r
30 "[" write now (timestamp>rfc3339) "] " write ;
\r
32 CONSTANT: multiline-header $[ 20 CHAR: - <string> ]
\r
34 : multiline-header. ( -- )
\r
35 "[" write multiline-header write "] " write ;
\r
37 : write-message ( msg word-name level -- )
\r
38 [ harvest ] 2dip pick empty? [ 3drop ] [
\r
40 [ write bl write ": " write print ] 2curry
\r
41 [ multiline-header. ] swap interleave
\r
44 : (log-message) ( msg -- )
\r
45 #! msg: { msg word-name level service }
\r
46 first4 log-stream [ write-message flush ] with-output-stream* ;
\r
48 : try-dispose ( obj -- )
\r
49 [ dispose ] curry [ error. ] recover ;
\r
51 : close-log ( service -- )
\r
52 log-files get delete-at*
\r
53 [ try-dispose ] [ drop ] if ;
\r
55 : (close-logs) ( -- )
\r
57 [ values [ try-dispose ] each ] [ clear-assoc ] bi ;
\r
59 CONSTANT: keep-logs 10
\r
61 : ?delete-file ( path -- )
\r
62 dup exists? [ delete-file ] [ drop ] if ;
\r
64 : delete-oldest ( service -- )
\r
65 keep-logs log# ?delete-file ;
\r
67 : ?move-file ( old new -- )
\r
68 over exists? [ move-file ] [ 2drop ] if ;
\r
70 : advance-log ( path n -- )
\r
71 [ 1 - log# ] 2keep log# ?move-file ;
\r
73 : rotate-log ( service -- )
\r
78 [ keep-logs 1 [a,b] [ advance-log ] with each ] bi
\r
81 : (rotate-logs) ( -- )
\r
83 log-root directory-files [ rotate-log ] each ;
\r
85 : log-server-loop ( -- )
\r
87 { "log-message" [ (log-message) ] }
\r
88 { "rotate-logs" [ drop (rotate-logs) ] }
\r
89 { "close-logs" [ drop (close-logs) ] }
\r
90 } case log-server-loop ;
\r
96 [ error. (close-logs) ]
\r
99 "Log server" spawn-server
\r
100 "log-server" set-global ;
\r
103 H{ } clone log-files set-global
\r
105 ] "logging" add-startup-hook
\r