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             irc-bot-init irc-bot-cleanup
  38             dispatch-message handle-message
  39
  40             default-irc-port                ;REMOVEME compat
  41             irc-bot-send-line               ;REMOVEME compat
  42             handle-line handle-misc-input)) ;REMOVEME compat
  43
  44 ;;; A goofy default handler.
  45 (define* (echo-message irc-bot speaker channel-name
  46                        line-text emote? #:key (port (current-output-port)))
  47   "Simply echoes the message to the PORT."
  48   (if emote?
  49       (format port "~a emoted ~s in channel ~a\n"
  50               speaker line-text channel-name)
  51       (format port "~a said ~s in channel ~a\n"
  52               speaker line-text channel-name)))
  53
  54 \f
  55 ;;; Bot
  56 ;;; ===
  57
  58 (define-class <irc-bot> (<actor>)
  59   (username #:init-keyword #:username
  60             #:getter irc-bot-username)
  61   (realname #:init-keyword #:realname
  62             #:init-value #f)
  63   (server #:init-keyword #:server
  64           #:getter irc-bot-server)
  65   (channels #:init-keyword #:channels
  66             #:getter irc-bot-channels)
  67   (port #:init-keyword #:port
  68         #:init-value %irc:default-port
  69         #:getter irc-bot-port)
  70   (socket #:accessor irc-bot-socket)
  71   (actions #:allocation #:each-subclass
  72            #:init-thunk (build-actions
  73                          (*init* irc-bot-init)
  74                          (*cleanup* irc-bot-cleanup)
  75                          (main-loop irc-bot-main-loop)
  76                          (dispatch-message dispatch-message)
  77                          (handle-line handle-line) ;REMOVEME compat
  78                          (send-line irc-bot-send-line-action))))
  79
  80 (define (irc-bot-realname irc-bot)
  81   (or (slot-ref irc-bot 'realname)
  82       (irc-bot-username irc-bot)))
  83
  84 (define-method (irc-bot-init (irc-bot <irc-bot>) message)
  85   "Initialize the IRC bot"
  86   (define socket (irc:listen (irc-bot-server irc-bot)
  87                              #:port (irc-bot-port irc-bot)
  88                              #:sleep 8sleep))
  89   (define flags (fcntl socket F_GETFL))
  90
  91   (fcntl socket F_SETFL (logior O_NONBLOCK flags))
  92   (set! (irc-bot-socket irc-bot) socket)
  93
  94   (irc:user socket (irc-bot-username irc-bot)
  95             #:real (irc-bot-realname irc-bot))
  96   (irc:nick socket (irc-bot-username irc-bot))
  97
  98   (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))
  99
 100   (<- (actor-id irc-bot) 'main-loop))
 101
 102 (define-method (irc-bot-cleanup (irc-bot <irc-bot>) message)
 103   (close (irc-bot-socket irc-bot)))
 104
 105 (define (irc-bot-main-loop irc-bot message)
 106   (define socket (irc-bot-socket irc-bot))
 107   (define line (irc:receive socket))
 108   (define message (or (false-if-exception (irc:line->message line))
 109                       line))
 110   (<- (actor-id irc-bot) 'dispatch-message message)
 111   (cond
 112    ;; The port's been closed for some reason, so stop looping
 113    ((port-closed? socket)
 114     'done)
 115    ;; We've reached the EOF object, which means we should close
 116    ;; the port ourselves and stop looping
 117    ((eof-object? (peek-char socket))
 118     (close socket)
 119     'done)
 120    ;; ;; Looks like we've been killed somehow... well, stop running
 121    ;; ;; then!
 122    ;; ((actor-am-i-dead? irc-bot)
 123    ;;  (if (not (port-closed? socket))
 124    ;;      (close socket))
 125    ;;  'done)
 126    ;; Otherwise, let's read till the next line!
 127    (else
 128     (<- (actor-id irc-bot) 'main-loop))))
 129
 130 (define* (irc-bot-send-line-action irc-bot message
 131                                    channel line #:key emote?)
 132   "Action handler for sending lines.  Real behavior happens in
 133 irc:send-line."
 134   (define socket (irc-bot-socket irc-bot))
 135   (irc:send-line socket channel line #:emote? emote?))
 136
 137 \f
 138 ;;;
 139 ;;; Likely-to-be-overridden generic methods
 140 ;;;
 141 (define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
 142   "Dispatch an <irc:message>."
 143   (match message
 144     ((and ($ <irc:message>)
 145           (= irc:message-command 'PING)
 146           (= irc:message-message message))
 147      (irc:pong (irc-bot-socket irc-bot) message))
 148     (_ (handle-message irc-bot message))))
 149
 150 (define-method (handle-message (irc-bot <irc-bot>) message)
 151   (match message
 152     ((and ($ <irc:message>)
 153           (= irc:message-line line)
 154           (= irc:message-command command)
 155           (= irc:message-speaker speaker)
 156           (= irc:message-channel channel)
 157           (= irc:message-message message)
 158           (= irc:message-emote? emote?))
 159      (or
 160       (case command
 161         ((PRIVMSG)
 162          (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
 163         (else
 164          (handle-misc-input irc-bot line))) ;REMOVEME compat
 165       (echo-message irc-bot speaker channel message #f
 166                     #:port (current-error-port))))))
 167
 168 \f
 169 ;;;
 170 ;;; Compatibility with 0.4.2.
 171 ;;;
 172 (define default-irc-port %irc:default-port)
 173 (define irc-eol %irc:eol)
 174
 175 (define* (irc-bot-send-line irc-bot channel line #:key emote?)
 176   (define socket (irc-bot-socket irc-bot))
 177   (irc:send-line socket channel line))
 178
 179 (define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
 180                             8sync-message
 181                             username channel-name line-text emote?)
 182   "Keep compatibility with previous release."
 183   #f)
 184
 185 (define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
 186                                   (line <string>))
 187   "Keep compatibility with previous release."
 188   #f)
 189
 190 (define (startswith-colon? str)
 191   (and (> (string-length str) 0)
 192        (eq? (string-ref str 0)
 193             #\:)))
 194
 195 ;; TODO: This needs a cleanup.  Maybe even just using a regex is fine.
 196 (define (parse-line line)               ;REMOVEME compat
 197   (define (parse-params pre-params)
 198     ;; This is stupid and imperative but I can't wrap my brain around
 199     ;; the right way to do it in a functional way :\
 200     (let ((param-list '())
 201           (currently-building '()))
 202       (for-each
 203        (lambda (param-item)
 204          (cond
 205           ((startswith-colon? param-item)
 206            (if (not (eq? currently-building '()))
 207                (set! param-list
 208                      (cons
 209                       (reverse currently-building)
 210                       param-list)))
 211            (set! currently-building (list param-item)))
 212           (else
 213            (set! currently-building (cons param-item currently-building)))))
 214        pre-params)
 215       ;; We're still building something, so tack that on there
 216       (if (not (eq? currently-building '()))
 217           (set! param-list
 218                 (cons (reverse currently-building) param-list)))
 219       ;; return the reverse of the param list
 220       (reverse param-list)))
 221
 222   (match (string-split line #\space)
 223     (((? startswith-colon? prefix)
 224       command
 225       pre-params ...)
 226      (values prefix command
 227              (parse-params pre-params)))
 228     ((command pre-params ...)
 229      (values #f command
 230              (parse-params pre-params)))))
 231
 232 (define (strip-colon-if-necessary string) ;REMOVME compat
 233   (if (and (> (string-length string) 0)
 234            (string-ref string 0))
 235       (substring/copy string 1)
 236       string))
 237
 238 ;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
 239 (define (irc-line-username irc-line-prefix) ;REMOVME compat
 240   (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
 241          (exclaim-index (string-index prefix-name #\!)))
 242     (if exclaim-index
 243         (substring/copy prefix-name 0 exclaim-index)
 244         prefix-name)))
 245
 246 (define (condense-privmsg-line line)    ;REMOVME compat
 247   "Condense message line and do multiple value return of
 248   (channel message emote?)"
 249   (define (strip-last-char string)
 250     (substring/copy string 0 (- (string-length string) 1)))
 251   (let* ((channel-name (caar line))
 252          (rest-params (apply append (cdr line))))
 253     (match rest-params
 254       (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
 255        (values channel-name
 256                (string-join
 257                 (append middle-words (list last-word))
 258                 " ")
 259                #t))
 260       (((= strip-colon-if-necessary first-word) rest-message ...)
 261        (values channel-name
 262                (string-join (cons first-word rest-message) " ")
 263                #f)))))