8sync/systems/irc.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright © 2015, 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; This file is part of 8sync.
   6 ;;;
   7 ;;; 8sync is free software: you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU Lesser General Public License as
   9 ;;; published by the Free Software Foundation, either version 3 of the
  10 ;;; License, or (at your option) any later version.
  11 ;;;
  12 ;;; 8sync is distributed in the hope that it will be useful,
  13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU Lesser General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (8sync systems irc)
  21   #:use-module (8sync repl)
  22   #:use-module (8sync agenda)
  23   #:use-module (8sync actors)
  24   #:use-module (8sync contrib irc)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (ice-9 getopt-long)
  28   #:use-module (ice-9 format)
  29   #:use-module (ice-9 receive)
  30   #:use-module (ice-9 rdelim)
  31   #:use-module (ice-9 q)
  32   #:use-module (ice-9 match)
  33   #:use-module (oop goops)
  34   #:export (<irc-bot>
  35             irc-bot-username irc-bot-server irc-bot-channels irc-bot-port
  36
  37             dispatch-message handle-message
  38
  39             default-irc-port                ;REMOVEME compat
  40             irc-bot-send-line               ;REMOVEME compat
  41             handle-line handle-misc-input)) ;REMOVEME compat
  42
  43 ;;; A goofy default handler.
  44 (define* (echo-message irc-bot speaker channel-name
  45                        line-text emote? #:key (port (current-output-port)))
  46   "Simply echoes the message to the PORT."
  47   (if emote?
  48       (format port "~a emoted ~s in channel ~a\n"
  49               speaker line-text channel-name)
  50       (format port "~a said ~s in channel ~a\n"
  51               speaker line-text channel-name)))
  52
  53 \f
  54 ;;; Bot
  55 ;;; ===
  56
  57 (define-class <irc-bot> (<actor>)
  58   (username #:init-keyword #:username
  59             #:getter irc-bot-username)
  60   (realname #:init-keyword #:realname
  61             #:init-value #f)
  62   (server #:init-keyword #:server
  63           #:getter irc-bot-server)
  64   (channels #:init-keyword #:channels
  65             #:getter irc-bot-channels)
  66   (port #:init-keyword #:port
  67         #:init-value %irc:default-port
  68         #:getter irc-bot-port)
  69   (socket #:accessor irc-bot-socket)
  70   (actions #:allocation #:each-subclass
  71            #:init-thunk (build-actions
  72                          (*init* irc-bot-init)
  73                          (*cleanup* irc-bot-cleanup)
  74                          (main-loop irc-bot-main-loop)
  75                          (dispatch-message dispatch-message)
  76                          (handle-line handle-line) ;REMOVEME compat
  77                          (send-line irc-bot-send-line-action))))
  78
  79 (define (irc-bot-realname irc-bot)
  80   (or (slot-ref irc-bot 'realname)
  81       (irc-bot-username irc-bot)))
  82
  83 (define (irc-bot-init irc-bot message)
  84   "Initialize the IRC bot"
  85   (define socket (irc:listen (irc-bot-server irc-bot)
  86                              #:port (irc-bot-port irc-bot)
  87                              #:sleep 8sleep))
  88   (define flags (fcntl socket F_GETFL))
  89
  90   (fcntl socket F_SETFL (logior O_NONBLOCK flags))
  91   (set! (irc-bot-socket irc-bot) socket)
  92
  93   (irc:user socket (irc-bot-username irc-bot)
  94             #:real (irc-bot-realname irc-bot))
  95   (irc:nick socket (irc-bot-username irc-bot))
  96
  97   (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))
  98
  99   (<- (actor-id irc-bot) 'main-loop))
 100
 101 (define (irc-bot-cleanup irc-bot message)
 102   (close (irc-bot-socket irc-bot)))
 103
 104 (define (irc-bot-main-loop irc-bot message)
 105   (define socket (irc-bot-socket irc-bot))
 106   (define line (irc:receive socket))
 107   (define message (or (false-if-exception (irc:line->message line))
 108                       line))
 109   (<- (actor-id irc-bot) 'dispatch-message message)
 110   (cond
 111    ;; The port's been closed for some reason, so stop looping
 112    ((port-closed? socket)
 113     'done)
 114    ;; We've reached the EOF object, which means we should close
 115    ;; the port ourselves and stop looping
 116    ((eof-object? (peek-char socket))
 117     (close socket)
 118     'done)
 119    ;; ;; Looks like we've been killed somehow... well, stop running
 120    ;; ;; then!
 121    ;; ((actor-am-i-dead? irc-bot)
 122    ;;  (if (not (port-closed? socket))
 123    ;;      (close socket))
 124    ;;  'done)
 125    ;; Otherwise, let's read till the next line!
 126    (else
 127     (<- (actor-id irc-bot) 'main-loop))))
 128
 129 (define* (irc-bot-send-line-action irc-bot message
 130                                    channel line #:key emote?)
 131   "Action handler for sending lines.  Real behavior happens in
 132 irc:send-line."
 133   (define socket (irc-bot-socket irc-bot))
 134   (irc:send-line socket channel line #:emote? emote?))
 135
 136 \f
 137 ;;;
 138 ;;; Likely-to-be-overridden generic methods
 139 ;;;
 140 (define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
 141   "Dispatch an <irc:message>."
 142   (match message
 143     ((and ($ <irc:message>)
 144           (= irc:message-command 'PING)
 145           (= irc:message-message message))
 146      (irc:pong (irc-bot-socket irc-bot) message))
 147     (_ (handle-message irc-bot message))))
 148
 149 (define-method (handle-message (irc-bot <irc-bot>) message)
 150   (match message
 151     ((and ($ <irc:message>)
 152           (= irc:message-line line)
 153           (= irc:message-command command)
 154           (= irc:message-speaker speaker)
 155           (= irc:message-channel channel)
 156           (= irc:message-message message)
 157           (= irc:message-emote? emote?))
 158      (or
 159       (case command
 160         ((PRIVMSG)
 161          (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
 162         (else
 163          (handle-misc-input irc-bot line))) ;REMOVEME compat
 164       (echo-message irc-bot speaker channel message #f
 165                     #:port (current-error-port))))))
 166
 167 \f
 168 ;;;
 169 ;;; Compatibility with 0.4.2.
 170 ;;;
 171 (define default-irc-port %irc:default-port)
 172 (define irc-eol %irc:eol)
 173
 174 (define* (irc-bot-send-line irc-bot channel line #:key emote?)
 175   (define socket (irc-bot-socket irc-bot))
 176   (irc:send-line socket channel line))
 177
 178 (define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
 179                             8sync-message
 180                             username channel-name line-text emote?)
 181   "Keep compatibility with previous release."
 182   #f)
 183
 184 (define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
 185                                   (line <string>))
 186   "Keep compatibility with previous release."
 187   #f)
 188
 189 (define (startswith-colon? str)
 190   (and (> (string-length str) 0)
 191        (eq? (string-ref str 0)
 192             #\:)))
 193
 194 ;; TODO: This needs a cleanup.  Maybe even just using a regex is fine.
 195 (define (parse-line line)               ;REMOVEME compat
 196   (define (parse-params pre-params)
 197     ;; This is stupid and imperative but I can't wrap my brain around
 198     ;; the right way to do it in a functional way :\
 199     (let ((param-list '())
 200           (currently-building '()))
 201       (for-each
 202        (lambda (param-item)
 203          (cond
 204           ((startswith-colon? param-item)
 205            (if (not (eq? currently-building '()))
 206                (set! param-list
 207                      (cons
 208                       (reverse currently-building)
 209                       param-list)))
 210            (set! currently-building (list param-item)))
 211           (else
 212            (set! currently-building (cons param-item currently-building)))))
 213        pre-params)
 214       ;; We're still building something, so tack that on there
 215       (if (not (eq? currently-building '()))
 216           (set! param-list
 217                 (cons (reverse currently-building) param-list)))
 218       ;; return the reverse of the param list
 219       (reverse param-list)))
 220
 221   (match (string-split line #\space)
 222     (((? startswith-colon? prefix)
 223       command
 224       pre-params ...)
 225      (values prefix command
 226              (parse-params pre-params)))
 227     ((command pre-params ...)
 228      (values #f command
 229              (parse-params pre-params)))))
 230
 231 (define (strip-colon-if-necessary string) ;REMOVME compat
 232   (if (and (> (string-length string) 0)
 233            (string-ref string 0))
 234       (substring/copy string 1)
 235       string))
 236
 237 ;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
 238 (define (irc-line-username irc-line-prefix) ;REMOVME compat
 239   (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
 240          (exclaim-index (string-index prefix-name #\!)))
 241     (if exclaim-index
 242         (substring/copy prefix-name 0 exclaim-index)
 243         prefix-name)))
 244
 245 (define (condense-privmsg-line line)    ;REMOVME compat
 246   "Condense message line and do multiple value return of
 247   (channel message emote?)"
 248   (define (strip-last-char string)
 249     (substring/copy string 0 (- (string-length string) 1)))
 250   (let* ((channel-name (caar line))
 251          (rest-params (apply append (cdr line))))
 252     (match rest-params
 253       (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
 254        (values channel-name
 255                (string-join
 256                 (append middle-words (list last-word))
 257                 " ")
 258                #t))
 259       (((= strip-colon-if-necessary first-word) rest-message ...)
 260        (values channel-name
 261                (string-join (cons first-word rest-message) " ")
 262                #f)))))