extra/irc/logbot/logbot.factor

   1 ! Copyright (C) 2009 Bruno Deferrari.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar destructors formatting fry io io.directories
   4 io.encodings.utf8 io.files io.pathnames irc.client irc.client.chats
   5 irc.logbot.log-line irc.messages.base kernel namespaces sequences
   6 splitting threads ;
   7 IN: irc.logbot
   8
   9 CONSTANT: bot-channel "#concatenative"
  10 CONSTANT: default-log-directory "resource:logs/irc"
  11 CONSTANT: default-nickserv-handle "flogbot2"
  12
  13 SYMBOL: ircbot-log-directory
  14 SYMBOL: nickserv-handle
  15 SYMBOL: nickserv-password
  16
  17 SYMBOL: current-day
  18 SYMBOL: current-stream
  19
  20 : bot-profile ( -- obj )
  21     "irc.libera.chat" 6697
  22     nickserv-handle get default-nickserv-handle or
  23     nickserv-password get <irc-profile> ;
  24
  25 : add-timestamp ( string timestamp -- string )
  26     "[%H:%M:%S] " strftime prepend ;
  27
  28 : make-log-path ( -- path )
  29     ircbot-log-directory get default-log-directory or
  30     bot-channel "#" ?head drop
  31     append-path ;
  32
  33 : timestamp-path ( timestamp -- path )
  34     "%Y-%m-%d.log" strftime
  35     make-log-path dup make-directories
  36     prepend-path ;
  37
  38 : update-current-stream ( timestamp -- )
  39     current-stream get [ dispose ] when*
  40     [ day-of-year current-day set ]
  41     [ timestamp-path utf8 <file-appender> ] bi
  42     current-stream set ;
  43
  44 : same-day? ( timestamp -- ? ) day-of-year current-day get = ;
  45
  46 : timestamp>stream ( timestamp  -- stream )
  47     dup same-day? [ drop ] [ update-current-stream ] if
  48     current-stream get ;
  49
  50 : log-message ( string timestamp -- )
  51     [ add-timestamp ] [ timestamp>stream ] bi
  52     [ stream-print ] [ stream-flush ] bi ;
  53
  54 GENERIC: handle-message ( msg -- )
  55
  56 M: object      handle-message drop ;
  57 M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
  58
  59 : bot-loop ( chat -- ) dup hear handle-message bot-loop ;
  60
  61 : start-bot ( -- )
  62     bot-profile <irc-client>
  63     [ connect-irc ]
  64     [
  65         [ bot-channel <irc-channel-chat> ] dip
  66         '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
  67         "LogBot" spawn drop
  68     ] bi ;
  69
  70 : logbot ( -- ) start-bot ;
  71
  72 MAIN: logbot