8sync/systems/irc.scm

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