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: 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 locals math math.parser math.ranges namespaces sequences\r
   7 strings threads ;\r
   8 IN: logging.server\r
   9 \r
  10 : log-root ( -- string )\r
  11     \ log-root get-global [ "logs" resource-path ] unless* ;\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     [ make-directories ]\r
  24     [ 1 log# utf8 <file-appender> ] bi ;\r
  25 \r
  26 : log-stream ( service -- stream )\r
  27     log-files get [ open-log-stream ] cache ;\r
  28 \r
  29 : close-log-streams ( -- )\r
  30     log-files get [ values dispose-each ] [ clear-assoc ] bi ;\r
  31 \r
  32 :: with-log-root ( path quot -- )\r
  33     [ close-log-streams path \ log-root set-global quot call ]\r
  34     \ log-root get-global\r
  35     [ \ log-root set-global close-log-streams ] curry\r
  36     [ ] cleanup ; inline\r
  37 \r
  38 : timestamp-header. ( -- )\r
  39     "[" write now (timestamp>rfc3339) "] " write ;\r
  40 \r
  41 : multiline-header ( -- str ) 20 CHAR: - <string> ; foldable\r
  42 \r
  43 : multiline-header. ( -- )\r
  44     "[" write multiline-header write "] " write ;\r
  45 \r
  46 :: write-message ( msg word-name level -- )\r
  47     msg harvest [\r
  48         timestamp-header.\r
  49         [ multiline-header. ]\r
  50         [ level write bl word-name write ": " write print ]\r
  51         interleave\r
  52     ] unless-empty ;\r
  53 \r
  54 : (log-message) ( msg -- )\r
  55     #! msg: { msg word-name level service }\r
  56     first4 log-stream [ write-message flush ] with-output-stream* ;\r
  57 \r
  58 : try-dispose ( obj -- )\r
  59     [ dispose ] curry [ error. ] recover ;\r
  60 \r
  61 : close-log ( service -- )\r
  62     log-files get delete-at*\r
  63     [ try-dispose ] [ drop ] if ;\r
  64 \r
  65 : (close-logs) ( -- )\r
  66     log-files get\r
  67     [ values [ try-dispose ] each ] [ clear-assoc ] bi ;\r
  68 \r
  69 CONSTANT: keep-logs 10\r
  70 \r
  71 : ?delete-file ( path -- )\r
  72     dup exists? [ delete-file ] [ drop ] if ;\r
  73 \r
  74 : delete-oldest ( service -- )\r
  75     keep-logs log# ?delete-file ;\r
  76 \r
  77 : ?move-file ( old new -- )\r
  78     over exists? [ move-file ] [ 2drop ] if ;\r
  79 \r
  80 : advance-log ( path n -- )\r
  81     [ 1 - log# ] 2keep log# ?move-file ;\r
  82 \r
  83 : rotate-log ( service -- )\r
  84     [ close-log ]\r
  85     [\r
  86         log-path\r
  87         [ delete-oldest ]\r
  88         [ keep-logs 1 [a,b] [ advance-log ] with each ] bi\r
  89     ] bi ;\r
  90 \r
  91 : (rotate-logs) ( -- )\r
  92     (close-logs)\r
  93     log-root directory-files [ rotate-log ] each ;\r
  94 \r
  95 : log-server-loop ( -- )\r
  96     receive unclip {\r
  97         { "log-message" [ (log-message) ] }\r
  98         { "rotate-logs" [ drop (rotate-logs) ] }\r
  99         { "close-logs" [ drop (close-logs) ] }\r
 100     } case log-server-loop ;\r
 101 \r
 102 : log-server ( -- )\r
 103     [\r
 104         init-namespaces\r
 105         [ log-server-loop ]\r
 106         [ error. (close-logs) ]\r
 107         recover t\r
 108     ]\r
 109     "Log server" spawn-server\r
 110     "log-server" set-global ;\r
 111 \r
 112 [\r
 113     H{ } clone log-files set-global\r
 114     log-server\r
 115 ] "logging" add-startup-hook\r