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