botbot.scm

   1 ;; Botbot: Very basic IRC bot
   2
   3 (import (chicken io)
   4         (chicken port)
   5         (chicken file)
   6         (chicken string)
   7         (chicken pathname)
   8         (chicken process-context)
   9         (chicken irregex)
  10         matchable srfi-13 srfi-1 srfi-18
  11         uri-common tcp6 openssl)
  12
  13 ;; Globals
  14
  15 (define irc-host #f)
  16 (define irc-port #f)
  17 (define bot-nick #f)
  18 (define bot-channel #f)
  19 (define bot-proc-file #f)
  20 (define usetls #t)
  21
  22 (define bot-proc #f)
  23
  24 (define ping-period 60) ;seconds
  25
  26 (tcp-read-timeout #f) ;disable read timeout
  27
  28 (define (launch-bot)
  29   ;; (let-values (((in-port out-port) (tcp-connect host port)))
  30   (set! bot-proc (eval (with-input-from-file bot-proc-file read)))
  31   (let-values (((in-port out-port)
  32                 (if usetls
  33                     (ssl-connect* hostname: irc-host port: (or irc-port 6697))
  34                     (tcp-connect irc-host (or irc-port 6667)))))
  35     ;; Connect to server
  36     (if (establish-connection in-port out-port)
  37         ;; (bot-loop in-port out-port)
  38         (begin
  39           (print "Successfully connected!")
  40           (start-ping-timer out-port)
  41           (bot-loop in-port out-port))
  42         (print "Failed to establish connection. Aborting..."))))
  43
  44 (define (establish-connection in-port out-port)
  45   (write-msg `(#f #f "NICK" (,bot-nick)) out-port)
  46   (write-msg `(#f #f "USER" (,bot-nick "0" "*" ,bot-nick)) out-port)
  47   (if bot-channel
  48       (write-msg `(#f #f "JOIN" (,bot-channel)) out-port))
  49   #t)
  50
  51 (define (start-ping-timer out-port)
  52   (thread-start!
  53    (lambda ()
  54      (let loop ()
  55        (thread-sleep! ping-period)
  56        (write-msg `(#f #f "PING" (,bot-host)) out-port) ; send ping
  57        (loop)))))
  58
  59 (define (bot-loop in-port out-port)
  60   (let ((privmsg (lambda (to . args)
  61                    (write-msg (list #f #f "PRIVMSG" (cons to args)) out-port))))
  62     (let loop ((msg (read-msg in-port)))
  63       (match (cons (msg-source msg) (cons (msg-command msg) (msg-args msg)))
  64         ((_ "PING" token)
  65          (write-msg `(#f #f "PONG" (,token)) out-port))
  66         ((source "PRIVMSG" target args ...)
  67          (when (string=? target bot-nick)
  68            (bot-proc source args privmsg)))
  69         (_
  70          ;; Do nothing
  71          ))
  72       (loop (read-msg in-port)))))
  73
  74 (define (read-msg in-port)
  75   (let ((msg (string->msg (read-line in-port))))
  76     (display "Received message: ")
  77     (write msg)
  78     (newline)
  79     msg))
  80
  81 (define (write-msg msg out-port)
  82   (with-output-to-port out-port
  83     (lambda () (write-string (conc (msg->string msg) "\r\n"))))
  84   (print "Sent message: " msg))
  85
  86 (define msg-regex
  87   (irregex '(:
  88              (? (: "@" (submatch (+ (~ " "))) (* " ")))
  89              (? (: ":" (submatch (+ (~ " " "!" "@")))
  90                    (* (~ " "))          ;discard non-nick portion
  91                    (* " ")))
  92              (submatch (+ (~ " ")))
  93              (* " ")
  94              (? (submatch (+ any))))))
  95
  96 (define (string->msg string)
  97   (let ((match  (irregex-match msg-regex string)))
  98     (list
  99      (irregex-match-substring match 1) ; Tags
 100      (irregex-match-substring match 2) ; Source
 101      (string-upcase (irregex-match-substring match 3)) ; command
 102      (parse-message-args (irregex-match-substring match 4))))) ;args
 103
 104 (define (msg->string msg)
 105   (conc
 106    (msg-command msg)
 107    (let ((args (msg-args msg)))
 108      (if args (conc " " (make-arg-string args)) ""))))
 109
 110 (define (make-arg-string args)
 111   (let* ((revargs (reverse args))
 112          (final-arg (car revargs))
 113          (first-args (reverse (cdr revargs))))
 114     (conc (string-join first-args " ")
 115           " :" final-arg)))
 116
 117 (define (parse-message-args argstr)
 118   (if argstr
 119       (let ((idx (substring-index ":" argstr)))
 120         (if idx
 121             (append
 122              (string-split (substring argstr 0 idx) " ")
 123              (list (substring argstr (+ idx 1))))
 124             (string-split argstr " ")))))
 125
 126 (define (msg-tags msg) (list-ref msg 0))
 127 (define (msg-source msg) (list-ref msg 1))
 128 (define (msg-command msg) (list-ref msg 2))
 129 (define (msg-args msg) (list-ref msg 3))
 130
 131 (define (print-usage progname)
 132   (let ((indent-str (make-string (string-length progname) #\space)))
 133     (print "Usage:\n"
 134            progname " [-h/--help]\n"
 135            progname " [-p/--port PORT] [--notls] [-c/--channnel CHANNEL]\n"
 136            indent-str " proc-file host nick")))
 137
 138 (define (main)
 139   (let ((progname (pathname-file (car (argv))))
 140         (port 6697)
 141         (channel #f))
 142     (if (null? (command-line-arguments))
 143         (print-usage progname)
 144         (let loop ((args (command-line-arguments)))
 145           (let ((this-arg (car args))
 146                 (rest-args (cdr args)))
 147             (if (string-prefix? "-" this-arg)
 148                 (cond
 149                  ((or (equal? this-arg "-h")
 150                       (equal? this-arg "--help"))
 151                   (print-usage progname))
 152                  ((or (equal? this-arg "-p")
 153                       (equal? this-arg "--port"))
 154                   (set! irc-port (string->number (car rest-args)))
 155                   (loop (cdr rest-args)))
 156                  ((equal? this-arg "--notls")
 157                   (set! usetls #f)
 158                   (loop rest-args))
 159                  ((or (equal? this-arg "-c")
 160                       (equal? this-arg "--channel"))
 161                   (set! bot-channel (car rest-args))
 162                   (loop (cdr rest-args)))
 163                  (else
 164                   (print "Unknown argument '" this-arg "'")
 165                   (print-usage progname)))
 166                 (match args
 167                   ((procfile host nick)
 168                    (set! bot-proc-file procfile)
 169                    (set! irc-host host)
 170                    (set! bot-nick nick)
 171                    (launch-bot))
 172                   (else
 173                    (print "One or more invalid arguments.")
 174                    (print-usage progname)))))))))
 175
 176 (main)