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
  37             irc-bot-port irc-bot-handler
  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   (line-handler #:init-keyword #:line-handler
 161                 #:init-value (wrap-apply echo-message)
 162                 #:getter irc-bot-line-handler)
 163   (socket #:accessor irc-bot-socket)
 164   (actions #:allocation #:each-subclass
 165            #:init-value (build-actions
 166                          (init irc-bot-init)
 167                          (main-loop irc-bot-main-loop)
 168                          (send-line irc-bot-send-line))))
 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   (<- irc-bot (actor-id irc-bot) 'main-loop))
 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   (irc-bot-dispatch-line irc-bot line)
 197   (cond
 198    ;; The port's been closed for some reason, so stop looping
 199    ((port-closed? socket)
 200     'done)
 201    ;; We've reached the EOF object, which means we should close
 202    ;; the port ourselves and stop looping
 203    ((eof-object? (peek-char socket))
 204     (close socket)
 205     'done)
 206    ;; ;; Looks like we've been killed somehow... well, stop running
 207    ;; ;; then!
 208    ;; ((actor-am-i-dead? irc-bot)
 209    ;;  (if (not (port-closed? socket))
 210    ;;      (close socket))
 211    ;;  'done)
 212    ;; Otherwise, let's read till the next line!
 213    (else
 214     (<- irc-bot (actor-id irc-bot) 'main-loop))))
 215
 216 (define-method (irc-bot-dispatch-line (irc-bot <irc-bot>) line)
 217   (receive (line-prefix line-command line-params)
 218       (parse-line line)
 219     (match line-command
 220       ("PING"
 221        (display "PONG" (irc-bot-socket irc-bot)))
 222       ("PRIVMSG"
 223        (receive (channel-name line-text emote?)
 224            (condense-privmsg-line line-params)
 225          (let ((username (irc-line-username line-prefix)))
 226            ((irc-bot-line-handler irc-bot) irc-bot username
 227             channel-name line-text emote?))))
 228       (_
 229        (display line)
 230        (newline)))))
 231
 232 (define* (irc-bot-send-line irc-bot message
 233                             channel line #:key emote?)
 234   ;; TODO: emote? handling
 235   (format (irc-bot-socket irc-bot) "PRIVMSG ~a :~a~a"
 236           channel line irc-eol))