basis/logging/server/server.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: namespaces kernel io io.files io.pathnames io.directories\r
   4 io.encodings.utf8 calendar calendar.format sequences continuations\r
   5 destructors prettyprint assocs math.parser words debugger math\r
   6 combinators concurrency.messaging threads arrays init math.ranges\r
   7 strings ;\r
   8 IN: logging.server\r
   9 \r
  10 : log-root ( -- string )\r
  11     \ log-root get "logs" resource-path or ;\r
  12 \r
  13 : log-path ( service -- path )\r
  14     log-root prepend-path ;\r
  15 \r
  16 : log# ( path n -- path' )\r
  17     number>string ".log" append append-path ;\r
  18 \r
  19 SYMBOL: log-files\r
  20 \r
  21 : open-log-stream ( service -- stream )\r
  22     log-path\r
  23     dup make-directories\r
  24     1 log# utf8 <file-appender> ;\r
  25 \r
  26 : log-stream ( service -- stream )\r
  27     log-files get [ open-log-stream ] cache ;\r
  28 \r
  29 : multiline-header ( -- string ) 20 CHAR: - <string> ; foldable\r
  30 \r
  31 : (write-message) ( msg word-name level multi? -- )\r
  32     [\r
  33         "[" write multiline-header write "] " write\r
  34     ] [\r
  35         "[" write now (timestamp>rfc3339) "] " write\r
  36     ] if\r
  37     write bl write ": " write print ;\r
  38 \r
  39 : write-message ( msg word-name level -- )\r
  40     [ harvest ] 2dip {\r
  41         { [ pick empty? ] [ 3drop ] }\r
  42         { [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] }\r
  43         [\r
  44             [ [ first ] 2dip f (write-message) ]\r
  45             [ [ rest ] 2dip [ t (write-message) ] 2curry each ]\r
  46             3bi\r
  47         ]\r
  48     } cond ;\r
  49 \r
  50 : (log-message) ( msg -- )\r
  51     #! msg: { msg word-name level service }\r
  52     first4 log-stream [ write-message flush ] with-output-stream* ;\r
  53 \r
  54 : try-dispose ( stream -- )\r
  55     [ dispose ] curry [ error. ] recover ;\r
  56 \r
  57 : close-log ( service -- )\r
  58     log-files get delete-at*\r
  59     [ try-dispose ] [ drop ] if ;\r
  60 \r
  61 : (close-logs) ( -- )\r
  62     log-files get\r
  63     dup values [ try-dispose ] each\r
  64     clear-assoc ;\r
  65 \r
  66 CONSTANT: keep-logs 10\r
  67 \r
  68 : ?delete-file ( path -- )\r
  69     dup exists? [ delete-file ] [ drop ] if ;\r
  70 \r
  71 : delete-oldest ( service -- ) keep-logs log# ?delete-file ;\r
  72 \r
  73 : ?move-file ( old new -- )\r
  74     over exists? [ move-file ] [ 2drop ] if ;\r
  75 \r
  76 : advance-log ( path n -- )\r
  77     [ 1 - log# ] 2keep log# ?move-file ;\r
  78 \r
  79 : rotate-log ( service -- )\r
  80     dup close-log\r
  81     log-path\r
  82     dup delete-oldest\r
  83     keep-logs 1 [a,b] [ advance-log ] with each ;\r
  84 \r
  85 : (rotate-logs) ( -- )\r
  86     (close-logs)\r
  87     log-root directory-files [ rotate-log ] each ;\r
  88 \r
  89 : log-server-loop ( -- )\r
  90     receive unclip {\r
  91         { "log-message" [ (log-message) ] }\r
  92         { "rotate-logs" [ drop (rotate-logs) ] }\r
  93         { "close-logs" [ drop (close-logs) ] }\r
  94     } case log-server-loop ;\r
  95 \r
  96 : log-server ( -- )\r
  97     [\r
  98         init-namespaces\r
  99         [ log-server-loop ]\r
 100         [ error. (close-logs) ]\r
 101         recover t\r
 102     ]\r
 103     "Log server" spawn-server\r
 104     "log-server" set-global ;\r
 105 \r
 106 [\r
 107     H{ } clone log-files set-global\r
 108     log-server\r
 109 ] "logging" add-init-hook\r