eightsync/systems/irc.scm

   1 #!/usr/bin/guile \
   2 -e main -s
   3 !#
   4
   5 ;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
   6
   7 ;; This library is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the GNU Lesser General Public
   9 ;; License as published by the Free Software Foundation; either
  10 ;; version 3 of the License, or (at your option) any later version.
  11 ;;
  12 ;; This library 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 GNU
  15 ;; 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 this library; if not, write to the Free Software
  19 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20 ;; 02110-1301 USA
  21
  22 (define-module (eightsync systems irc)
  23   #:use-module (eightsync repl)
  24   #:use-module (eightsync agenda)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (ice-9 getopt-long)
  27   #:use-module (ice-9 format)
  28   #:use-module (ice-9 receive)
  29   #:use-module (ice-9 q)
  30   #:use-module (ice-9 match)
  31   #:export (;; The only things you definitely need if writing a bot
  32             make-irc-bot-cli
  33             irc-format irc-display
  34
  35             ;; Useful things if you're making something more complicated
  36             irc-line
  37             irc-eol
  38
  39             default-irc-port
  40
  41             startswith-colon?
  42
  43             <irc-line>
  44             make-irc-line irc-line?
  45             irc-line-prefix irc-line-command irc-line-params
  46
  47             parse-line
  48             irc-line-username
  49
  50             condense-privmsg-line
  51             echo-back-message
  52
  53             make-handle-line make-basic-irc-handler
  54             queue-and-start-irc-agenda!))
  55
  56 \f
  57 ;;; Network stuff
  58 ;;; =============
  59
  60 (define default-irc-port 6665)
  61
  62 (define* (irc-socket-setup hostname #:optional (inet-port default-irc-port))
  63   (let ((s (socket PF_INET SOCK_STREAM 0))
  64         (ip-address (inet-ntoa (car (hostent:addr-list (gethost hostname))))))
  65     (connect s AF_INET
  66              (inet-pton AF_INET ip-address)
  67              inet-port)
  68     s))
  69
  70 (define (install-socket socket handler)
  71   (display "Installing socket...\n")   ; debugging :)
  72   (make-port-request socket #:read handler))
  73
  74 (define irc-eol "\r\n")
  75
  76 (define (irc-line line)
  77   (string-concatenate (list line irc-eol)))
  78
  79 (define-syntax-rule (irc-format dest format-string rest ...)
  80   (let ((line (string-concatenate
  81                (list (format #f format-string rest ...)
  82                      irc-eol))))
  83     (match dest
  84       (#f line)
  85       (#t (display line))
  86       (else
  87        (display line dest)))))
  88
  89 (define* (irc-display line #:optional dest)
  90   (if dest
  91       (display (irc-line line) dest)
  92       (display (irc-line dest))))
  93
  94 (define* (handle-login socket username
  95                        #:key
  96                        (hostname "*")
  97                        (servername "*")
  98                        (realname username)
  99                        (channels '()))
 100   (irc-format socket "USER ~a ~a ~a :~a"
 101               username hostname servername realname)
 102   (irc-format socket "NICK ~a" username)
 103   (for-each
 104    (lambda (channel)
 105      (irc-format socket "JOIN ~a" channel))
 106    channels))
 107
 108 (define (startswith-colon? str)
 109   (and (> (string-length str) 0)
 110        (eq? (string-ref str 0)
 111             #\:)))
 112
 113 (define-record-type <irc-line>
 114   (make-irc-line prefix command params)
 115   irc-line?
 116   (prefix irc-line-prefix)
 117   (command irc-line-command)
 118   (params irc-line-params))
 119
 120
 121 (define (parse-line line)
 122   (define (parse-params pre-params)
 123     ;; This is stupid and imperative but I can't wrap my brain around
 124     ;; the right way to do it in a functional way :\
 125     (let ((param-list '())
 126           (currently-building '()))
 127       (for-each
 128        (lambda (param-item)
 129          (cond
 130           ((startswith-colon? param-item)
 131            (if (not (eq? currently-building '()))
 132                (set! param-list
 133                      (cons
 134                       (reverse currently-building)
 135                       param-list)))
 136            (set! currently-building (list param-item)))
 137           (else
 138            (set! currently-building (cons param-item currently-building)))))
 139        pre-params)
 140       ;; We're still building something, so tack that on there
 141       (if (not (eq? currently-building '()))
 142           (set! param-list
 143                 (cons (reverse currently-building) param-list)))
 144       ;; return the reverse of the param list
 145       (reverse param-list)))
 146
 147   (match (string-split line #\space)
 148     (((? startswith-colon? prefix)
 149       command
 150       pre-params ...)
 151      (make-irc-line prefix command
 152                     (parse-params pre-params)))
 153     ((command pre-params ...)
 154      (make-irc-line #f command
 155                     (parse-params pre-params)))))
 156
 157 (define (strip-colon-if-necessary string)
 158   (if (and (> (string-length string) 0)
 159            (string-ref string 0))
 160       (substring/copy string 1)
 161       string))
 162
 163 ;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
 164 (define (irc-line-username irc-line)
 165   (let* ((prefix-name (strip-colon-if-necessary (irc-line-prefix irc-line)))
 166          (exclaim-index (string-index prefix-name #\!)))
 167     (if exclaim-index
 168         (substring/copy prefix-name 0 exclaim-index)
 169         prefix-name)))
 170
 171 (define (condense-privmsg-line line)
 172   "Condense message line and do multiple value return of
 173   (channel message is-action)"
 174   (define (strip-last-char string)
 175     (substring/copy string 0 (- (string-length string) 1)))
 176   (let* ((channel-name (caar line))
 177          (rest-params (apply append (cdr line))))
 178     (match rest-params
 179       (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
 180        (values channel-name
 181                (string-join
 182                 (append middle-words (list last-word))
 183                 " ")
 184                #t))
 185       (((= strip-colon-if-necessary first-word) rest-message ...)
 186        (values channel-name
 187                (string-join (cons first-word rest-message) " ")
 188                #f)))))
 189
 190 (define (echo-back-message socket my-name speaker
 191                            channel-name message is-action)
 192   (if is-action
 193       (format #t "~a emoted ~s in channel ~a\n"
 194               speaker message channel-name)
 195       (format #t "~a said ~s in channel ~a\n"
 196               speaker message channel-name)))
 197
 198 (define default-handle-privmsg echo-back-message)
 199
 200 (define* (make-handle-line #:key
 201                            (handle-privmsg default-handle-privmsg))
 202   (define (handle-line socket line my-username)
 203     (let ((parsed-line (parse-line line)))
 204       (match (irc-line-command parsed-line)
 205         ("PING"
 206          (irc-display "PONG" socket))
 207         ("PRIVMSG"
 208          (receive (channel-name message is-action)
 209              (condense-privmsg-line (irc-line-params parsed-line))
 210            (let ((username (irc-line-username parsed-line)))
 211              (handle-privmsg socket my-username username
 212                              channel-name message is-action))))
 213         (_
 214          (display line)
 215          (newline)))))
 216   handle-line)
 217
 218 (define (make-basic-irc-handler handle-line username)
 219   (let ((buffer '()))
 220     (define (reset-buffer)
 221       (set! buffer '()))
 222     (define (should-read-char socket)
 223       (and (char-ready? socket) (not (eof-object? (peek-char socket)))))
 224     (define (irc-handler socket)
 225       (while (should-read-char socket)
 226         (set! buffer (cons (read-char socket) buffer))
 227         (match buffer
 228           ((#\newline #\return (? char? line-chars) ...)
 229            (%sync (%run (handle-line
 230                          socket
 231                          (list->string (reverse line-chars))
 232                          username)))
 233            ;; reset buffer
 234            (set! buffer '()))
 235           (_ #f))))
 236     irc-handler))
 237
 238 (define default-line-handler (make-handle-line))
 239
 240 (define* (queue-and-start-irc-agenda! agenda socket #:key
 241                                       (username "syncbot")
 242                                       (inet-port default-irc-port)
 243                                       (line-handler default-line-handler)
 244                                       (channels '()))
 245   (dynamic-wind
 246     (lambda () #f)
 247     (lambda ()
 248       (enq! (agenda-queue agenda)
 249             (wrap (install-socket
 250                    socket
 251                    (make-basic-irc-handler
 252                     line-handler
 253                     username))))
 254       (enq! (agenda-queue agenda) (wrap (handle-login socket username
 255                                                       #:channels channels)))
 256       (start-agenda agenda))
 257     (lambda ()
 258       (display "Cleaning up...\n")
 259       (close socket))))
 260
 261
 262 \f
 263 ;;; CLI
 264 ;;; ===
 265
 266 (define option-spec
 267   `((server (single-char #\s) (required? #t) (value #t))
 268     (port (single-char #\p)
 269           (value #t)
 270           (predicate
 271            ,(lambda (s)
 272               (if (string->number s) #t #f))))
 273     (username (single-char #\u) (required? #t) (value #t))
 274     (channels (value #t))
 275     (listen)))
 276
 277 (define* (make-irc-bot-cli #:optional (line-handler default-line-handler))
 278   (define (main args)
 279     (let* ((options (getopt-long args option-spec))
 280            (hostname (option-ref options 'server #f))
 281            (port (or (option-ref options 'port #f)
 282                      default-irc-port))
 283            (username (option-ref options 'username #f))
 284            (listen (option-ref options 'listen #f))
 285            (channels (option-ref options 'channels ""))
 286            (agenda (make-agenda)))
 287       (display `((server ,hostname) (port ,port) (username ,username)
 288                  (listen ,listen) (channels-split ,(string-split channels #\space))))
 289       (newline)
 290       (if listen
 291           (spawn-and-queue-repl-server! agenda))
 292       (queue-and-start-irc-agenda!
 293        agenda
 294        (irc-socket-setup hostname port)
 295        #:inet-port port
 296        #:username username
 297        #:channels (string-split channels #\space)
 298        #:line-handler line-handler)))
 299   main)
 300
 301 (define main (make-irc-bot-cli))
 302