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