From: Janneke Nieuwenhuizen <janneke@gnu.org>
Date: Sun, 13 Aug 2023 09:18:12 +0000 (+0200)
Subject: irc: Refactor using (8sync contrib irc) library from Snuik.
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=a82db588459534f845e0c64fcac6d289b3c01a03;p=8sync.git

irc: Refactor using (8sync contrib irc) library from Snuik.

Switch to new IRC library while retaining 0.4.2 api compatibility.

* 8sync/systems/irc.scm: Rewrite using low level irc functions
from (8sync contrib irc).
(irc-socket-setup): Remove,
(<irc-bot>): Update to use %irc:default-port.  Add dispatch-message
handler.
(irc-bot-init): Refactor using irc:listen, irc:user, irc:nick.
(irc-bot-main-loop): Dispatch to...
(dispatch-message): ...this new message handler.
(handle-message): New overridable handler.  Invoke legacy
handle-misc-input and handle-line handlers for PRIVMSG.
---

diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm
index 0007de8..ac4efa6 100644
--- a/8sync/systems/irc.scm
+++ b/8sync/systems/irc.scm
@@ -21,7 +21,9 @@
   #:use-module (8sync repl)
   #:use-module (8sync agenda)
   #:use-module (8sync actors)
+  #:use-module (8sync contrib irc)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 format)
   #:use-module (ice-9 receive)
@@ -32,109 +34,13 @@
   #:export (<irc-bot>
             irc-bot-username irc-bot-server irc-bot-channels irc-bot-port
 
-            irc-bot-send-line
+            dispatch-message handle-message
 
-            handle-line handle-misc-input
-            handle-user-join handle-user-quit
+            default-irc-port                ;REMOVEME compat
+            irc-bot-send-line               ;REMOVEME compat
+            handle-line handle-misc-input)) ;REMOVEME compat
 
-            default-irc-port))
-
-
-;;; Network stuff
-;;; =============
-
-(define default-irc-port 6665)
-
-(define* (irc-socket-setup hostname #:optional (inet-port default-irc-port))
-  (let* ((s (socket PF_INET SOCK_STREAM 0))
-         (flags (fcntl s F_GETFL))
-         (ip-address (inet-ntop AF_INET (car (hostent:addr-list (gethost hostname))))))
-    (cond (s
-           (fcntl s F_SETFL (logior O_NONBLOCK flags))
-           (connect s AF_INET (inet-pton AF_INET ip-address) inet-port)
-           s)
-          (else
-           (8sleep 1)
-           (irc-socket-setup hostname inet-port)))))
-
-(define irc-eol "\r\n")
-
-(define (startswith-colon? str)
-  (and (> (string-length str) 0)
-       (eq? (string-ref str 0)
-            #\:)))
-
-;; TODO: This needs a cleanup.  Maybe even just using a regex is fine.
-(define (parse-line line)
-  (define (parse-params pre-params)
-    ;; This is stupid and imperative but I can't wrap my brain around
-    ;; the right way to do it in a functional way :\
-    (let ((param-list '())
-          (currently-building '()))
-      (for-each
-       (lambda (param-item)
-         (cond
-          ((startswith-colon? param-item)
-           (if (not (eq? currently-building '()))
-               (set! param-list
-                     (cons
-                      (reverse currently-building)
-                      param-list)))
-           (set! currently-building (list param-item)))
-          (else
-           (set! currently-building (cons param-item currently-building)))))
-       pre-params)
-      ;; We're still building something, so tack that on there
-      (if (not (eq? currently-building '()))
-          (set! param-list
-                (cons (reverse currently-building) param-list)))
-      ;; return the reverse of the param list
-      (reverse param-list)))
-
-  (match (string-split line #\space)
-    (((? startswith-colon? prefix)
-      command
-      pre-params ...)
-     (values prefix command
-             (parse-params pre-params)))
-    ((command pre-params ...)
-     (values #f command
-             (parse-params pre-params)))))
-
-(define (strip-colon-if-necessary string)
-  (if (and (> (string-length string) 0)
-           (string-ref string 0))
-      (substring/copy string 1)
-      string))
-
-;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
-(define (irc-line-username irc-line-prefix)
-  (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
-         (exclaim-index (string-index prefix-name #\!)))
-    (if exclaim-index
-        (substring/copy prefix-name 0 exclaim-index)
-        prefix-name)))
-
-(define (condense-privmsg-line line)
-  "Condense message line and do multiple value return of
-  (channel message emote?)"
-  (define (strip-last-char string)
-    (substring/copy string 0 (- (string-length string) 1)))
-  (let* ((channel-name (caar line))
-         (rest-params (apply append (cdr line))))
-    (match rest-params
-      (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
-       (values channel-name
-               (string-join
-                (append middle-words (list last-word))
-                " ")
-               #t))
-      (((= strip-colon-if-necessary first-word) rest-message ...)
-       (values channel-name
-               (string-join (cons first-word rest-message) " ")
-               #f)))))
-
-;;; A goofy default
+;;; A goofy default handler.
 (define* (echo-message irc-bot speaker channel-name
                        line-text emote? #:key (port (current-output-port)))
   "Simply echoes the message to the PORT."
@@ -158,7 +64,7 @@
   (channels #:init-keyword #:channels
             #:getter irc-bot-channels)
   (port #:init-keyword #:port
-        #:init-value default-irc-port
+        #:init-value %irc:default-port
         #:getter irc-bot-port)
   (socket #:accessor irc-bot-socket)
   (actions #:allocation #:each-subclass
@@ -166,7 +72,8 @@
                          (*init* irc-bot-init)
                          (*cleanup* irc-bot-cleanup)
                          (main-loop irc-bot-main-loop)
-                         (handle-line handle-line)
+                         (dispatch-message dispatch-message)
+                         (handle-line handle-line) ;REMOVEME compat
                          (send-line irc-bot-send-line-action))))
 
 (define (irc-bot-realname irc-bot)
@@ -175,20 +82,19 @@
 
 (define (irc-bot-init irc-bot message)
   "Initialize the IRC bot"
-  (define socket
-    (irc-socket-setup (irc-bot-server irc-bot)
-                      (irc-bot-port irc-bot)))
+  (define socket (irc:listen (irc-bot-server irc-bot)
+                             #:port (irc-bot-port irc-bot)
+                             #:sleep 8sleep))
+  (define flags (fcntl socket F_GETFL))
+
+  (fcntl socket F_SETFL (logior O_NONBLOCK flags))
   (set! (irc-bot-socket irc-bot) socket)
-  (format socket "USER ~a ~a ~a :~a~a"
-          (irc-bot-username irc-bot)
-          "*" "*"  ; hostname and servername
-          (irc-bot-realname irc-bot) irc-eol)
-  (format socket "NICK ~a~a" (irc-bot-username irc-bot) irc-eol)
 
-  (for-each
-   (lambda (channel)
-     (format socket "JOIN ~a~a" channel irc-eol))
-   (irc-bot-channels irc-bot))
+  (irc:user socket (irc-bot-username irc-bot)
+            #:real (irc-bot-realname irc-bot))
+  (irc:nick socket (irc-bot-username irc-bot))
+
+  (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))
 
   (<- (actor-id irc-bot) 'main-loop))
 
@@ -197,8 +103,10 @@
 
 (define (irc-bot-main-loop irc-bot message)
   (define socket (irc-bot-socket irc-bot))
-  (define line (string-trim-right (read-line socket) #\return))
-  (dispatch-raw-line irc-bot line)
+  (define line (irc:receive socket))
+  (define message (or (false-if-exception (irc:line->message line))
+                      line))
+  (<- (actor-id irc-bot) 'dispatch-message message)
   (cond
    ;; The port's been closed for some reason, so stop looping
    ((port-closed? socket)
@@ -221,46 +129,134 @@
 (define* (irc-bot-send-line-action irc-bot message
                                    channel line #:key emote?)
   "Action handler for sending lines.  Real behavior happens in
-irc-bot-send-line."
-  (irc-bot-send-line irc-bot channel line #:emote? emote?))
+irc:send-line."
+  (define socket (irc-bot-socket irc-bot))
+  (irc:send-line socket channel line #:emote? emote?))
+
+
+;;;
+;;; Likely-to-be-overridden generic methods
+;;;
+(define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
+  "Dispatch an <irc:message>."
+  (match message
+    ((and ($ <irc:message>)
+          (= irc:message-command 'PING)
+          (= irc:message-message message))
+     (irc:pong (irc-bot-socket irc-bot) message))
+    (_ (handle-message irc-bot message))))
+
+(define-method (handle-message (irc-bot <irc-bot>) message)
+  (match message
+    ((and ($ <irc:message>)
+          (= irc:message-line line)
+          (= irc:message-command command)
+          (= irc:message-speaker speaker)
+          (= irc:message-channel channel)
+          (= irc:message-message message)
+          (= irc:message-emote? emote?))
+     (or
+      (case command
+        ((PRIVMSG)
+         (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
+        (else
+         (handle-misc-input irc-bot line))) ;REMOVEME compat
+      (echo-message irc-bot speaker channel message #f
+                    #:port (current-error-port))))))
+
+
+;;;
+;;; Compatibility with 0.4.2.
+;;;
+(define default-irc-port %irc:default-port)
+(define irc-eol %irc:eol)
 
 (define* (irc-bot-send-line irc-bot channel line #:key emote?)
-  ;; TODO: emote? handling
-  (format (irc-bot-socket irc-bot) "PRIVMSG ~a :~a~a"
-          channel line irc-eol))
+  (define socket (irc-bot-socket irc-bot))
+  (irc:send-line socket channel line))
 
+(define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
+                            8sync-message
+                            username channel-name line-text emote?)
+  "Keep compatibility with previous release."
+  #f)
 
-;;; Likely-to-be-overridden generic methods
+(define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
+                                  (line <string>))
+  "Keep compatibility with previous release."
+  #f)
 
-(define-method (dispatch-raw-line (irc-bot <irc-bot>) raw-line)
-  "Dispatch a raw line of input"
-  (receive (line-prefix line-command line-params)
-      (parse-line raw-line)
-    (match line-command
-      ("PING"
-       (display (string-append "PONG" irc-eol)
-                (irc-bot-socket irc-bot)))
-      ("PRIVMSG"
-       (receive (channel-name line-text emote?)
-           (condense-privmsg-line line-params)
-         (let ((username (irc-line-username line-prefix)))
-           (<- (actor-id irc-bot) 'handle-line
-               username channel-name
-               line-text emote?))))
-      (_ (handle-misc-input irc-bot raw-line)))))
+(define (startswith-colon? str)
+  (and (> (string-length str) 0)
+       (eq? (string-ref str 0)
+            #\:)))
 
-(define-method (handle-line (irc-bot <irc-bot>) message
-                            username channel-name line-text emote?)
-  (echo-message irc-bot username channel-name line-text emote?
-                #:port (current-error-port)))
+;; TODO: This needs a cleanup.  Maybe even just using a regex is fine.
+(define (parse-line line)               ;REMOVEME compat
+  (define (parse-params pre-params)
+    ;; This is stupid and imperative but I can't wrap my brain around
+    ;; the right way to do it in a functional way :\
+    (let ((param-list '())
+          (currently-building '()))
+      (for-each
+       (lambda (param-item)
+         (cond
+          ((startswith-colon? param-item)
+           (if (not (eq? currently-building '()))
+               (set! param-list
+                     (cons
+                      (reverse currently-building)
+                      param-list)))
+           (set! currently-building (list param-item)))
+          (else
+           (set! currently-building (cons param-item currently-building)))))
+       pre-params)
+      ;; We're still building something, so tack that on there
+      (if (not (eq? currently-building '()))
+          (set! param-list
+                (cons (reverse currently-building) param-list)))
+      ;; return the reverse of the param list
+      (reverse param-list)))
 
-(define-method (handle-misc-input (irc-bot <irc-bot>) raw-line)
-  (display raw-line)
-  (newline))
+  (match (string-split line #\space)
+    (((? startswith-colon? prefix)
+      command
+      pre-params ...)
+     (values prefix command
+             (parse-params pre-params)))
+    ((command pre-params ...)
+     (values #f command
+             (parse-params pre-params)))))
 
-(define-method (handle-user-join (irc-bot <irc-bot>) user channel)
-  'TODO)
+(define (strip-colon-if-necessary string) ;REMOVME compat
+  (if (and (> (string-length string) 0)
+           (string-ref string 0))
+      (substring/copy string 1)
+      string))
 
-(define-method (handle-user-quit (irc-bot <irc-bot>) user channel)
-  'TODO)
+;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
+(define (irc-line-username irc-line-prefix) ;REMOVME compat
+  (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
+         (exclaim-index (string-index prefix-name #\!)))
+    (if exclaim-index
+        (substring/copy prefix-name 0 exclaim-index)
+        prefix-name)))
 
+(define (condense-privmsg-line line)    ;REMOVME compat
+  "Condense message line and do multiple value return of
+  (channel message emote?)"
+  (define (strip-last-char string)
+    (substring/copy string 0 (- (string-length string) 1)))
+  (let* ((channel-name (caar line))
+         (rest-params (apply append (cdr line))))
+    (match rest-params
+      (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
+       (values channel-name
+               (string-join
+                (append middle-words (list last-word))
+                " ")
+               #t))
+      (((= strip-colon-if-necessary first-word) rest-message ...)
+       (values channel-name
+               (string-join (cons first-word rest-message) " ")
+               #f)))))