8sync/systems/irc.scm

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