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   (let-values (((in-port out-port)
  50                 (if usetls
  51                     (ssl-connect* hostname: irc-host port: (or irc-port 6697))
  52                     (tcp-connect irc-host (or irc-port 6667)))))
  53     ;; Connect to server
  54     (if (establish-connection in-port out-port)
  55         ;; (bot-loop in-port out-port)
  56         (begin
  57           (print "Successfully connected!")
  58           (start-ping-timer out-port)
  59           (bot-loop in-port out-port))
  60         (print "Failed to establish connection. Aborting..."))))
  61
  62 (define (establish-connection in-port out-port)
  63   (write-msg `(#f #f "NICK" (,bot-nick)) out-port)
  64   (write-msg `(#f #f "USER" (,bot-nick "0" "*" ,bot-nick)) out-port)
  65   (if bot-channel
  66       (write-msg `(#f #f "JOIN" (,bot-channel)) out-port))
  67   #t)
  68
  69 (define (start-ping-timer out-port)
  70   (thread-start!
  71    (lambda ()
  72      (let loop ()
  73        (thread-sleep! ping-period)
  74        (write-msg `(#f #f "PING" (,irc-host)) out-port) ; send ping
  75        (loop)))))
  76
  77 (define (load-bot)
  78   (let ((new-bot-proc
  79          (condition-case
  80              (eval (with-input-from-file bot-proc-file read))
  81            (o (exn)
  82               (print-error-message o)
  83               #f))))
  84     (if new-bot-proc
  85         (begin
  86           (set! bot-proc new-bot-proc)
  87           (print "Loaded bot procedure file."))
  88         (print "Error loading procedure file."))
  89     new-bot-proc))
  90
  91 (define (bot-loop in-port out-port)
  92   (let ((privmsg (lambda (to . args)
  93                    (let ((msg (list #f #f "PRIVMSG" (cons to args))))
  94                      (write-msg msg out-port)
  95                      (when (>= verbosity-level 1)
  96                        (display "Responded with msg: ")
  97                        (write msg)
  98                        (newline))))))
  99     (let loop ((msg (read-msg in-port)))
 100       (match (cons (msg-source msg) (cons (msg-command msg) (msg-args msg)))
 101         ((_ "PING" token)
 102          (write-msg `(#f #f "PONG" (,token)) out-port))
 103         ((source "PRIVMSG" target "bbreload")
 104          (when (and allow-reload (string=? target bot-nick))
 105            (print "Reveived reload command from " source)
 106            (if (load-bot)
 107                (privmsg source "Reloaded bot script.")
 108                (privmsg source "Error loading bot script."))))
 109         ((source "PRIVMSG" target args ...)
 110          (when (string=? target bot-nick)
 111            (when (>= verbosity-level 1)
 112              (display "Received msg: ")
 113              (write msg)
 114              (newline))
 115            (condition-case
 116                (bot-proc source args privmsg)
 117              (o (exn)
 118                 (print "Error executing bot script.")
 119                 (print-error-message o)))))
 120         (_
 121          ;; Do nothing
 122          ))
 123       (loop (read-msg in-port)))))
 124
 125 (define (read-msg in-port)
 126   (let ((msg (string->msg (read-line in-port))))
 127     (when (>= verbosity-level 2)
 128       (display "Received message: ")
 129       (write msg)
 130       (newline))
 131     msg))
 132
 133 (define (write-msg msg out-port)
 134   (with-output-to-port out-port
 135     (lambda () (write-string (conc (msg->string msg) "\r\n"))))
 136   (when (>= verbosity-level 2)
 137     (print "Sent message: " msg)))
 138
 139 (define msg-regex
 140   (irregex '(:
 141              (? (: "@" (submatch (+ (~ " "))) (* " ")))
 142              (? (: ":" (submatch (+ (~ " " "!" "@")))
 143                    (* (~ " "))          ;discard non-nick portion
 144                    (* " ")))
 145              (submatch (+ (~ " ")))
 146              (* " ")
 147              (? (submatch (+ any))))))
 148
 149 (define (string->msg string)
 150   (let ((match  (irregex-match msg-regex string)))
 151     (list
 152      (irregex-match-substring match 1) ; Tags
 153      (irregex-match-substring match 2) ; Source
 154      (string-upcase (irregex-match-substring match 3)) ; command
 155      (parse-message-args (irregex-match-substring match 4))))) ;args
 156
 157 (define (msg->string msg)
 158   (conc
 159    (msg-command msg)
 160    (let ((args (msg-args msg)))
 161      (if args (conc " " (make-arg-string args)) ""))))
 162
 163 (define (make-arg-string args)
 164   (let* ((revargs (reverse args))
 165          (final-arg (car revargs))
 166          (first-args (reverse (cdr revargs))))
 167     (conc (string-join first-args " ")
 168           " :" final-arg)))
 169
 170 (define (parse-message-args argstr)
 171   (if argstr
 172       (let ((idx (substring-index ":" argstr)))
 173         (if idx
 174             (append
 175              (string-split (substring argstr 0 idx) " ")
 176              (list (substring argstr (+ idx 1))))
 177             (string-split argstr " ")))))
 178
 179 (define (msg-tags msg) (list-ref msg 0))
 180 (define (msg-source msg) (list-ref msg 1))
 181 (define (msg-command msg) (list-ref msg 2))
 182 (define (msg-args msg) (list-ref msg 3))
 183
 184 (define (print-usage progname)
 185   (let ((indent-str (make-string (string-length progname) #\space)))
 186     (print "Usage:\n"
 187            progname " [-h/--help]\n"
 188            progname " [-p/--port PORT] [--notls] [-c/--channnel CHANNEL]\n"
 189            indent-str " [-v/--verbose] [-a/--allow-reload]\n"
 190            indent-str " proc-file host nick")))
 191
 192 (define (main)
 193   (let ((progname (pathname-file (car (argv))))
 194         (port 6697)
 195         (channel #f))
 196     (if (null? (command-line-arguments))
 197         (print-usage progname)
 198         (let loop ((args (command-line-arguments)))
 199           (let ((this-arg (car args))
 200                 (rest-args (cdr args)))
 201             (if (string-prefix? "-" this-arg)
 202                 (cond
 203                  ((or (equal? this-arg "-h")
 204                       (equal? this-arg "--help"))
 205                   (print-usage progname))
 206                  ((or (equal? this-arg "-p")
 207                       (equal? this-arg "--port"))
 208                   (set! irc-port (string->number (car rest-args)))
 209                   (loop (cdr rest-args)))
 210                  ((equal? this-arg "--notls")
 211                   (set! usetls #f)
 212                   (loop rest-args))
 213                  ((or (equal? this-arg "-c")
 214                       (equal? this-arg "--channel"))
 215                   (set! bot-channel (car rest-args))
 216                   (loop (cdr rest-args)))
 217                  ((or (equal? this-arg "-v")
 218                       (equal? this-arg "--verbose"))
 219                   (set! verbosity-level (+ 1 verbosity-level))
 220                   (loop rest-args))
 221                  ((or (equal? this-arg "-a")
 222                       (equal? this-arg "--allow-reload"))
 223                   (set! allow-reload #t)
 224                   (loop rest-args))
 225                  (else
 226                   (print "Unknown argument '" this-arg "'")
 227                   (print-usage progname)))
 228                 (match args
 229                   ((procfile host nick)
 230                    (set! bot-proc-file procfile)
 231                    (set! irc-host host)
 232                    (set! bot-nick nick)
 233                    (if  (load-bot)
 234                         (launch-bot)
 235                         (error "Could not load bot procedure.")))
 236                   (else
 237                    (print "One or more invalid arguments.")
 238                    (print-usage progname)))))))))
 239
 240 (main)