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