branch master updated: Add IRC logging bot.

[Ricardo Wurmus]

This is an automated email from the git hooks/post-receive script.

rekado pushed a commit to branch master
in repository maintenance.

The following commit(s) were added to refs/heads/master by this push:
     new b7d491e  Add IRC logging bot.
b7d491e is described below

commit b7d491eac0710b8643e8c1e8c9b644fc2b563ae2
Author: Ricardo Wurmus <rekado@elephly.net>
AuthorDate: Wed Jul 20 18:47:10 2022 +0200

    Add IRC logging bot.
    
    * hydra/goggles-bot.scm: New file.
---
 hydra/goggles-bot.scm | 172 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 172 insertions(+)

diff --git a/hydra/goggles-bot.scm b/hydra/goggles-bot.scm
new file mode 100755
index 0000000..2fa7e3d
--- /dev/null
+++ b/hydra/goggles-bot.scm
@@ -0,0 +1,172 @@
+#!/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
+                              (alist-delete 'channel 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)
+  "Return an absolute file name with the basename matching the current
+date as contained in TIME."
+  (format #false "~a/~a/~a.log"
+          (assoc-ref %config 'directory)
+          (assoc-ref %config 'channel)
+          (strftime "%F" (localtime (current-time)))))
+
+(define log-to-file
+  (let ((day #false)
+        (port #false))
+    (lambda (message)
+      "Log MESSAGE to a file.  Create a new file for each day."
+      (let ((time (localtime (msg:time message))))
+        (when (or (not day)
+                  (not port)
+                  (< day (tm:mday time)))
+          (and port
+               (begin
+                 (force-output port)
+                 (close-port port)))
+          (let ((file (make-filename time)))
+            (mkdir-p (dirname file))
+            (set! day (tm:mday time))
+            (set! port (open-file file "a"))))
+        (print message port)))))
+
+(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 (main . args)
+  (match args
+    ((_ . rest)
+     (set! %config (parse-options rest))
+     (let* ((channel (or (assoc-ref %config 'channel)
+                         (error "must provide 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 (string->symbol
+                                 (format #f "printer-~a" channel)))
+       (do-connect irc)
+       (do-register irc)
+       (do-join irc channel)
+       (while #true
+         (run-message-hook irc (do-wait irc)))))
+    (_
+     (format #false
+             "\
+usage: goggles-bot
+  --channel=...
+  [--nick=...]
+  [--server=...]
+  [--port=...]
+  [--directory=...]"))))
+
+(apply main (program-arguments))