botbot.scm

   1 ;; Botbot: Very basic IRC bot
   2 ;;
   3 ;; Copyright (C) 2023 plugd
   4
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (import (chicken io)
  19         (chicken port)
  20         (chicken file)
  21         (chicken string)
  22         (chicken pathname)
  23         (chicken process-context)
  24         (chicken condition)
  25         (chicken irregex)
  26         matchable srfi-13 srfi-1 srfi-18
  27         tcp6 openssl)
  28
  29 ;; Globals
  30
  31 (define irc-host #f)
  32 (define irc-port #f)
  33 (define bot-nick #f)
  34 (define bot-channel #f)
  35 (define bot-proc-file #f)
  36 (define usetls #t)
  37 (define allow-reload #f)
  38
  39 (define bot-proc #f)
  40
  41 (define verbosity-level 0)
  42
  43 (define ping-period 60) ;seconds
  44
  45 (tcp-read-timeout #f) ;disable read timeout
  46
  47 (define (launch-bot)
  48   ;; (let-values (((in-port out-port) (tcp-connect host port)))
  49   (set-buffering-mode! (current-output-port) #:line)
  50   (let-values (((in-port out-port)
  51                 (if usetls
  52                     (ssl-connect* hostname: irc-host port: (or irc-port 6697))
  53                     (tcp-connect irc-host (or irc-port 6667)))))
  54     ;; Connect to server
  55     (if (establish-connection in-port out-port)
  56         ;; (bot-loop in-port out-port)
  57         (begin
  58           (print "Successfully connected!")
  59           (start-ping-timer out-port)
  60           (bot-loop in-port out-port))
  61         (print "Failed to establish connection. Aborting..."))))
  62
  63 (define (establish-connection in-port out-port)
  64   (write-msg `(#f #f "NICK" (,bot-nick)) out-port)
  65   (write-msg `(#f #f "USER" (,bot-nick "0" "*" ,bot-nick)) out-port)
  66   (if bot-channel
  67       (write-msg `(#f #f "JOIN" (,bot-channel)) out-port))
  68   #t)
  69
  70 (define (start-ping-timer out-port)
  71   (thread-start!
  72    (lambda ()
  73      (let loop ()
  74        (thread-sleep! ping-period)
  75        (write-msg `(#f #f "PING" (,irc-host)) out-port) ; send ping
  76        (loop)))))
  77
  78 (define (load-bot)
  79   (let ((new-bot-proc
  80          (condition-case
  81              (eval (with-input-from-file bot-proc-file read))
  82            (o (exn)
  83               (print-error-message o)
  84               #f))))
  85     (if new-bot-proc
  86         (begin
  87           (set! bot-proc new-bot-proc)
  88           (print "Loaded bot procedure file."))
  89         (print "Error loading procedure file."))
  90     new-bot-proc))
  91
  92 (define (bot-loop in-port out-port)
  93   (let ((privmsg (lambda (to . args)
  94                    (let ((msg (list #f #f "PRIVMSG" (cons to args))))
  95                      (write-msg msg out-port)
  96                      (when (>= verbosity-level 1)
  97                        (display "Responded with msg: ")
  98                        (write msg)
  99                        (newline))))))
 100     (let loop ((msg (read-msg in-port)))
 101       (match (cons (msg-source msg) (cons (msg-command msg) (msg-args msg)))
 102         ((_ "PING" token)
 103          (write-msg `(#f #f "PONG" (,token)) out-port))
 104         ((source "PRIVMSG" target "bbreload")
 105          (when (and allow-reload (string=? target bot-nick))
 106            (print "Reveived reload command from " source)
 107            (if (load-bot)
 108                (privmsg source "Reloaded bot script.")
 109                (privmsg source "Error loading bot script."))))
 110         ((source "PRIVMSG" target args ...)
 111          (when (string=? target bot-nick)
 112            (when (>= verbosity-level 1)
 113              (display "Received msg: ")
 114              (write msg)
 115              (newline))
 116            (condition-case
 117                (bot-proc source args privmsg)
 118              (o (exn)
 119                 (print "Error executing bot script.")
 120                 (print-error-message o)))))
 121         (_
 122          ;; Do nothing
 123          ))
 124       (loop (read-msg in-port)))))
 125
 126 (define (read-msg in-port)
 127   (let ((msg (string->msg (read-line in-port))))
 128     (when (>= verbosity-level 2)
 129       (display "Received message: ")
 130       (write msg)
 131       (newline))
 132     msg))
 133
 134 (define (write-msg msg out-port)
 135   (with-output-to-port out-port
 136     (lambda () (write-string (conc (msg->string msg) "\r\n"))))
 137   (when (>= verbosity-level 2)
 138     (print "Sent message: " msg)))
 139
 140 (define msg-regex
 141   (irregex '(:
 142              (? (: "@" (submatch (+ (~ " "))) (* " ")))
 143              (? (: ":" (submatch (+ (~ " " "!" "@")))
 144                    (* (~ " "))          ;discard non-nick portion
 145                    (* " ")))
 146              (submatch (+ (~ " ")))
 147              (* " ")
 148              (? (submatch (+ any))))))
 149
 150 (define (string->msg string)
 151   (let ((match  (irregex-match msg-regex string)))
 152     (list
 153      (irregex-match-substring match 1) ; Tags
 154      (irregex-match-substring match 2) ; Source
 155      (string-upcase (irregex-match-substring match 3)) ; command
 156      (parse-message-args (irregex-match-substring match 4))))) ;args
 157
 158 (define (msg->string msg)
 159   (conc
 160    (msg-command msg)
 161    (let ((args (msg-args msg)))
 162      (if args (conc " " (make-arg-string args)) ""))))
 163
 164 (define (make-arg-string args)
 165   (let* ((revargs (reverse args))
 166          (final-arg (car revargs))
 167          (first-args (reverse (cdr revargs))))
 168     (conc (string-join first-args " ")
 169           " :" final-arg)))
 170
 171 (define (parse-message-args argstr)
 172   (if argstr
 173       (let ((idx (substring-index ":" argstr)))
 174         (if idx
 175             (append
 176              (string-split (substring argstr 0 idx) " ")
 177              (list (substring argstr (+ idx 1))))
 178             (string-split argstr " ")))))
 179
 180 (define (msg-tags msg) (list-ref msg 0))
 181 (define (msg-source msg) (list-ref msg 1))
 182 (define (msg-command msg) (list-ref msg 2))
 183 (define (msg-args msg) (list-ref msg 3))
 184
 185 (define (print-usage progname)
 186   (let ((indent-str (make-string (string-length progname) #\space)))
 187     (print "Usage:\n"
 188            progname " [-h/--help]\n"
 189            progname " [-p/--port PORT] [--notls] [-c/--channnel CHANNEL]\n"
 190            indent-str " [-v/--verbose] [-a/--allow-reload]\n"
 191            indent-str " proc-file host nick")))
 192
 193 (define (main)
 194   (let ((progname (pathname-file (car (argv))))
 195         (port 6697)
 196         (channel #f))
 197     (if (null? (command-line-arguments))
 198         (print-usage progname)
 199         (let loop ((args (command-line-arguments)))
 200           (let ((this-arg (car args))
 201                 (rest-args (cdr args)))
 202             (if (string-prefix? "-" this-arg)
 203                 (cond
 204                  ((or (equal? this-arg "-h")
 205                       (equal? this-arg "--help"))
 206                   (print-usage progname))
 207                  ((or (equal? this-arg "-p")
 208                       (equal? this-arg "--port"))
 209                   (set! irc-port (string->number (car rest-args)))
 210                   (loop (cdr rest-args)))
 211                  ((equal? this-arg "--notls")
 212                   (set! usetls #f)
 213                   (loop rest-args))
 214                  ((or (equal? this-arg "-c")
 215                       (equal? this-arg "--channel"))
 216                   (set! bot-channel (car rest-args))
 217                   (loop (cdr rest-args)))
 218                  ((or (equal? this-arg "-v")
 219                       (equal? this-arg "--verbose"))
 220                   (set! verbosity-level (+ 1 verbosity-level))
 221                   (loop rest-args))
 222                  ((or (equal? this-arg "-a")
 223                       (equal? this-arg "--allow-reload"))
 224                   (set! allow-reload #t)
 225                   (loop rest-args))
 226                  (else
 227                   (print "Unknown argument '" this-arg "'")
 228                   (print-usage progname)))
 229                 (match args
 230                   ((procfile host nick)
 231                    (set! bot-proc-file procfile)
 232                    (set! irc-host host)
 233                    (set! bot-nick nick)
 234                    (if  (load-bot)
 235                         (launch-bot)
 236                         (error "Could not load bot procedure.")))
 237                   (else
 238                    (print "One or more invalid arguments.")
 239                    (print-usage progname)))))))))
 240
 241 (main)