basis/logging/parser/parser.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs calendar calendar.format calendar.parser
   4 combinators io io.encodings.utf8 io.files kernel logging
   5 logging.server make namespaces peg peg.parsers prettyprint
   6 sequences splitting strings vectors words ;
   7 IN: logging.parser
   8
   9 TUPLE: log-entry date level word-name message ;
  10
  11 : string-of ( quot -- parser )
  12     satisfy repeat0 [ >string ] action ; inline
  13
  14 SYMBOL: multiline
  15
  16 : date-parser ( -- parser )
  17     [ "]" member? not ] string-of [
  18         dup multiline-header =
  19         [ drop multiline ] [ rfc3339>timestamp ] if
  20     ] action
  21     "[" "]" surrounded-by ;
  22
  23 : log-level-parser ( -- parser )
  24     log-levels keys [
  25         [ name>> token ] keep [ nip ] curry action
  26     ] map choice ;
  27
  28 : word-name-parser ( -- parser )
  29     [ " :" member? not ] string-of ;
  30
  31 SYMBOL: malformed
  32
  33 : malformed-line-parser ( -- parser )
  34     [ drop t ] string-of
  35     [ log-entry new swap >>message malformed >>level ] action ;
  36
  37 : log-message-parser ( -- parser )
  38     [ drop t ] string-of
  39     [ 1vector ] action ;
  40
  41 : log-line-parser ( -- parser )
  42     [
  43         date-parser ,
  44         " " token hide ,
  45         log-level-parser ,
  46         " " token hide ,
  47         word-name-parser ,
  48         ": " token hide ,
  49         log-message-parser ,
  50     ] seq* [ first4 log-entry boa ] action
  51     malformed-line-parser 2choice ;
  52
  53 PEG: parse-log-line ( string -- entry ) log-line-parser ;
  54
  55 : malformed? ( line -- ? )
  56     level>> malformed eq? ;
  57
  58 : multiline? ( line -- ? )
  59     level>> multiline eq? ;
  60
  61 : malformed-line ( line -- )
  62     "Warning: malformed log line:" print
  63     message>> print ;
  64
  65 : add-multiline ( line -- )
  66     building get empty? [
  67         "Warning: log begins with multiline entry" print drop
  68     ] [
  69         message>> first building get last message>> push
  70     ] if ;
  71
  72 : parse-log ( lines -- entries )
  73     [
  74         [
  75             parse-log-line {
  76                 { [ dup malformed? ] [ malformed-line ] }
  77                 { [ dup multiline? ] [ add-multiline ] }
  78                 [ , ]
  79             } cond
  80         ] each
  81     ] { } make ;
  82
  83 : parse-log-file ( service -- entries )
  84     log-path 1 log# dup file-exists?
  85     [ utf8 file-lines parse-log ] [ drop f ] if ;
  86
  87 GENERIC: log-timestamp. ( date -- )
  88
  89 M: timestamp log-timestamp. write-timestamp ;
  90 M: word log-timestamp. drop "multiline" write ;
  91
  92 : log-entry. ( entry -- )
  93     "====== " write
  94     {
  95         [ date>> log-timestamp. bl ]
  96         [ level>> pprint bl ]
  97         [ word-name>> write nl ]
  98         [ message>> unlines print ]
  99     } cleave ;
 100
 101 : log-entries. ( errors -- )
 102     [ log-entry. ] each ;