-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs calendar calendar.format combinators\r
-concurrency.messaging continuations debugger destructors init io\r
-io.directories io.encodings.utf8 io.files io.pathnames kernel\r
-locals math math.parser math.ranges namespaces sequences\r
-strings threads ;\r
-IN: logging.server\r
-\r
-: log-root ( -- string )\r
- \ log-root get-global [ "logs" resource-path ] unless* ;\r
-\r
-: log-path ( service -- path )\r
- log-root prepend-path ;\r
-\r
-: log# ( path n -- path' )\r
- number>string ".log" append append-path ;\r
-\r
-SYMBOL: log-files\r
-\r
-: open-log-stream ( service -- stream )\r
- log-path\r
- [ make-directories ]\r
- [ 1 log# utf8 <file-appender> ] bi ;\r
-\r
-: log-stream ( service -- stream )\r
- log-files get [ open-log-stream ] cache ;\r
-\r
-: close-log-streams ( -- )\r
- log-files get [ values dispose-each ] [ clear-assoc ] bi ;\r
-\r
-:: with-log-root ( path quot -- )\r
- [ close-log-streams path \ log-root set-global quot call ]\r
- \ log-root get-global\r
- [ \ log-root set-global close-log-streams ] curry\r
- [ ] cleanup ; inline\r
-\r
-: timestamp-header. ( -- )\r
- "[" write now (timestamp>rfc3339) "] " write ;\r
-\r
-: multiline-header ( -- str ) 20 CHAR: - <string> ; foldable\r
-\r
-: multiline-header. ( -- )\r
- "[" write multiline-header write "] " write ;\r
-\r
-:: write-message ( msg word-name level -- )\r
- msg harvest [\r
- timestamp-header.\r
- [ multiline-header. ]\r
- [ level write bl word-name write ": " write print ]\r
- interleave\r
- ] unless-empty ;\r
-\r
-: (log-message) ( msg -- )\r
- #! msg: { msg word-name level service }\r
- first4 log-stream [ write-message flush ] with-output-stream* ;\r
-\r
-: try-dispose ( obj -- )\r
- [ dispose ] curry [ error. ] recover ;\r
-\r
-: close-log ( service -- )\r
- log-files get delete-at*\r
- [ try-dispose ] [ drop ] if ;\r
-\r
-: (close-logs) ( -- )\r
- log-files get\r
- [ values [ try-dispose ] each ] [ clear-assoc ] bi ;\r
-\r
-CONSTANT: keep-logs 10\r
-\r
-: ?delete-file ( path -- )\r
- dup exists? [ delete-file ] [ drop ] if ;\r
-\r
-: delete-oldest ( service -- )\r
- keep-logs log# ?delete-file ;\r
-\r
-: ?move-file ( old new -- )\r
- over exists? [ move-file ] [ 2drop ] if ;\r
-\r
-: advance-log ( path n -- )\r
- [ 1 - log# ] 2keep log# ?move-file ;\r
-\r
-: rotate-log ( service -- )\r
- [ close-log ]\r
- [\r
- log-path\r
- [ delete-oldest ]\r
- [ keep-logs 1 [a,b] [ advance-log ] with each ] bi\r
- ] bi ;\r
-\r
-: (rotate-logs) ( -- )\r
- (close-logs)\r
- log-root directory-files [ rotate-log ] each ;\r
-\r
-: log-server-loop ( -- )\r
- receive unclip {\r
- { "log-message" [ (log-message) ] }\r
- { "rotate-logs" [ drop (rotate-logs) ] }\r
- { "close-logs" [ drop (close-logs) ] }\r
- } case log-server-loop ;\r
-\r
-: log-server ( -- )\r
- [\r
- init-namespaces\r
- [ log-server-loop ]\r
- [ error. (close-logs) ]\r
- recover t\r
- ]\r
- "Log server" spawn-server\r
- "log-server" set-global ;\r
-\r
-[\r
- H{ } clone log-files set-global\r
- log-server\r
-] "logging" add-startup-hook\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs calendar calendar.format combinators
+concurrency.messaging continuations debugger destructors init io
+io.directories io.encodings.utf8 io.files io.pathnames kernel
+locals math math.parser math.ranges namespaces sequences
+strings threads ;
+IN: logging.server
+
+: log-root ( -- string )
+ \ log-root get-global [ "logs" resource-path ] unless* ;
+
+: log-path ( service -- path )
+ log-root prepend-path ;
+
+: log# ( path n -- path' )
+ number>string ".log" append append-path ;
+
+SYMBOL: log-files
+
+: open-log-stream ( service -- stream )
+ log-path
+ [ make-directories ]
+ [ 1 log# utf8 <file-appender> ] bi ;
+
+: log-stream ( service -- stream )
+ log-files get [ open-log-stream ] cache ;
+
+: close-log-streams ( -- )
+ log-files get [ values dispose-each ] [ clear-assoc ] bi ;
+
+:: with-log-root ( path quot -- )
+ [ close-log-streams path \ log-root set-global quot call ]
+ \ log-root get-global
+ [ \ log-root set-global close-log-streams ] curry
+ [ ] cleanup ; inline
+
+: timestamp-header. ( -- )
+ "[" write now (timestamp>rfc3339) "] " write ;
+
+: multiline-header ( -- str ) 20 CHAR: - <string> ; foldable
+
+: multiline-header. ( -- )
+ "[" write multiline-header write "] " write ;
+
+:: write-message ( msg word-name level -- )
+ msg harvest [
+ timestamp-header.
+ [ multiline-header. ]
+ [ level write bl word-name write ": " write print ]
+ interleave
+ ] unless-empty ;
+
+: (log-message) ( msg -- )
+ #! msg: { msg word-name level service }
+ first4 log-stream [ write-message flush ] with-output-stream* ;
+
+: try-dispose ( obj -- )
+ [ dispose ] curry [ error. ] recover ;
+
+: close-log ( service -- )
+ log-files get delete-at*
+ [ try-dispose ] [ drop ] if ;
+
+: (close-logs) ( -- )
+ log-files get
+ [ values [ try-dispose ] each ] [ clear-assoc ] bi ;
+
+CONSTANT: keep-logs 10
+
+: ?delete-file ( path -- )
+ dup exists? [ delete-file ] [ drop ] if ;
+
+: delete-oldest ( service -- )
+ keep-logs log# ?delete-file ;
+
+: ?move-file ( old new -- )
+ over exists? [ move-file ] [ 2drop ] if ;
+
+: advance-log ( path n -- )
+ [ 1 - log# ] 2keep log# ?move-file ;
+
+: rotate-log ( service -- )
+ [ close-log ]
+ [
+ log-path
+ [ delete-oldest ]
+ [ keep-logs 1 [a,b] [ advance-log ] with each ] bi
+ ] bi ;
+
+: (rotate-logs) ( -- )
+ (close-logs)
+ log-root directory-files [ rotate-log ] each ;
+
+: log-server-loop ( -- )
+ receive unclip {
+ { "log-message" [ (log-message) ] }
+ { "rotate-logs" [ drop (rotate-logs) ] }
+ { "close-logs" [ drop (close-logs) ] }
+ } case log-server-loop ;
+
+: log-server ( -- )
+ [
+ init-namespaces
+ [ log-server-loop ]
+ [ error. (close-logs) ]
+ recover t
+ ]
+ "Log server" spawn-server
+ "log-server" set-global ;
+
+[
+ H{ } clone log-files set-global
+ log-server
+] "logging" add-startup-hook
projects / factor.git / blobdiff