maintenance/hydra/goggles-bot.scm

#!/run/current-system/profile/bin/guile \
--no-auto-compile -e main -s
!#
;;; IRC bot for logging
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Released under the GNU GPLv3 or any later version.

(use-modules (srfi srfi-1)
             (srfi srfi-37)
             (srfi srfi-71)
             (ice-9 match)
             (irc irc)
             (irc handlers)
             ((irc message)
              #:renamer (symbol-prefix-proc 'msg:)))

(define %options
  (list (option '("channel") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'channel arg result)))
        (option '("directory") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'directory arg
                              (alist-delete 'directory result))))
        (option '("nick") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'nick arg
                              (alist-delete 'nick result))))
        (option '("server") #t #f
                (lambda (opt name arg result)
                  (catch #t
                    (lambda ()
                      (inet-pton AF_INET arg))
                    (lambda _
                      (error "invalid IRC server name" arg)))
                  (alist-cons 'server arg
                              (alist-delete 'server result))))
        (option '("port") #t #f
                (lambda (opt name arg result)
                  (let ((port (string->number arg)))
                    (if port
                        (alist-cons 'port port
                                    (alist-delete 'port result))
                        (error "invalid IRC server port" arg)))))))

(define %default-options
  `((nick . "goggles-bot")
    (server . "irc.libera.chat")
    (port . 6697)
    (directory . "/var/log/irc")))

(define (parse-options args)
  (args-fold
   args %options
   (lambda (opt name arg result)
     (error "unrecognized option" name))
   (lambda (arg result)
     (error "extraneous argument" arg))
   %default-options))

(define %config '())


(define (mkdir-p dir)
  "Create directory DIR and all its ancestors."
  (define absolute?
    (string-prefix? "/" dir))

  (define not-slash
    (char-set-complement (char-set #\/)))

  (let loop ((components (string-tokenize dir not-slash))
             (root       (if absolute?
                             ""
                             ".")))
    (match components
      ((head tail ...)
       (let ((path (string-append root "/" head)))
         (catch 'system-error
           (lambda ()
             (mkdir path)
             (loop tail path))
           (lambda args
             (if (= EEXIST (system-error-errno args))
                 (loop tail path)
                 (apply throw args))))))
      (() #t))))

(define (make-filename time channel)
  "Return an absolute file name for CHANNEL with the basename matching
the current date as contained in TIME."
  (format #false "~a/~a/~a.log"
          (assoc-ref %config 'directory) channel
          (strftime "%F" (localtime (current-time)))))

(define log-to-file
  (let ((days #false)
        (ports #false))
    (lambda (message)
      "Log MESSAGE to a file.  Create a new file for each day."
      (let ((channel (msg:parse-target message))
            (time (localtime (msg:time message)))
            (day-for-channel
             (lambda (channel)
               (and days (assoc-ref days channel))))
            (port-for-channel
             (lambda (channel)
               (and ports (assoc-ref ports channel)))))
        ;; Only log messages to known channels
        (when (member channel (%channels))

          ;; When the music's over turn out the lights
          (let ((port (port-for-channel channel))
                (day (day-for-channel channel)))
            (when (or (not day)
                      (not port)
                      (< day (tm:mday time)))
              ;; Day's over, finish the file. 
              (when port
                (force-output port)
                (close-port port))
              ;; Create a new file for the new day; update
              ;; channel->port alist.
              (let ((file (make-filename time channel)))
                (mkdir-p (dirname file))
                (set! days
                      (assoc-set! days channel (tm:mday time)))
                (set! ports
                      (assoc-set! ports channel (open-file file "a"))))))

          ;; Write message, ensuring that we're using the latest port.
          (print message (port-for-channel channel)))))))

(define* (print message #:optional (port (current-output-port)))
  "Format and print MESSAGE to PORT."
  (let ((timestamp (strftime "[%T]" (localtime (msg:time message))))
        (who text (match (msg:command message)
                    ;; TODO: capture optional join and parting messages
                    ((and (or 'JOIN 'QUIT 'PART) cmd)
                     (values (format #false "*** ~as:"
                                     (string-capitalize (symbol->string cmd)))
                             (match (msg:prefix message)
                               ((nick user host)
                                (format #false "~a (~a@~a)" nick user host))
                               (str str))))
                    ('PRIVMSG
                     (values (match (msg:prefix message)
                               ((nick user host)
                                (format #false "<~a>" nick))
                               (_ "***"))
                             (msg:trailing message)))
                    ;; Ignore everything else
                    (_
                     (values #f #f)))))
    (when (and who text)
      (format port "~a ~a ~a~%"
              timestamp who text)
      (force-output port))))

(define %channels
  (let ((result #false))
    (lambda ()
      (unless result
        (set! result
              (fold (match-lambda*
                      ((('channel . name) res) (cons name res))
                      ((_ res) res))
                    '() %config)))
      result)))

(define (main . args)
  (match args
    ((_ . rest)
     (set! %config (parse-options rest))
     (let* ((channels (or (%channels)
                          (error "must provide at least one channel name")))
            (irc (make-irc #:nick (assoc-ref %config 'nick)
                           #:server (assoc-ref %config 'server)
                           #:port (assoc-ref %config 'port)
                           #:ssl #true)))
       (install-ping-handler! irc)
       (add-message-hook! irc log-to-file #:tag 'log-to-file)
       (do-connect irc)
       (do-register irc)
       (for-each (lambda (channel)
                   (do-join irc channel))
                 channels)
       (while #true
         (run-message-hook irc (do-wait irc)))))
    (_
     (format #false
             "\
usage: goggles-bot
  --channel=...
  [--channel=...]
  [--nick=...]
  [--server=...]
  [--port=...]
  [--directory=...]"))))

(apply main (program-arguments))