basis/logging/server/server.factor

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