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