;; Botbot: Very basic IRC bot
;;
;; Copyright (C) 2023 plugd

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(import (chicken io)
        (chicken port)
        (chicken file)
        (chicken string)
        (chicken pathname)
        (chicken process-context)
        (chicken condition)
        (chicken irregex)
        matchable srfi-13 srfi-1 srfi-18
        tcp6 openssl)

;; Globals

(define irc-host #f)
(define irc-port #f)
(define bot-nick #f)
(define bot-channel #f)
(define bot-proc-file #f)
(define usetls #t)
(define allow-reload #f)

(define bot-proc #f)

(define verbosity-level 0)

(define ping-period 60) ;seconds

(tcp-read-timeout #f) ;disable read timeout

(define (launch-bot)
  ;; (let-values (((in-port out-port) (tcp-connect host port)))
  (set-buffering-mode! (current-output-port) #:line)
  (let-values (((in-port out-port)
                (if usetls
                    (ssl-connect* hostname: irc-host port: (or irc-port 6697))
                    (tcp-connect irc-host (or irc-port 6667)))))
    ;; Connect to server
    (if (establish-connection in-port out-port)
        ;; (bot-loop in-port out-port)
        (begin
          (print "Successfully connected!")
          (start-ping-timer out-port)
          (bot-loop in-port out-port))
        (print "Failed to establish connection. Aborting..."))))

(define (establish-connection in-port out-port)
  (write-msg `(#f #f "NICK" (,bot-nick)) out-port)
  (write-msg `(#f #f "USER" (,bot-nick "0" "*" ,bot-nick)) out-port)
  (if bot-channel
      (write-msg `(#f #f "JOIN" (,bot-channel)) out-port))
  #t)

(define (start-ping-timer out-port)
  (thread-start!
   (lambda ()
     (let loop ()
       (thread-sleep! ping-period)
       (write-msg `(#f #f "PING" (,irc-host)) out-port) ; send ping
       (loop)))))

(define (load-bot)
  (let ((new-bot-proc
         (condition-case
             (eval (with-input-from-file bot-proc-file read))
           (o (exn)
              (print-error-message o)
              #f))))
    (if new-bot-proc
        (begin
          (set! bot-proc new-bot-proc)
          (print "Loaded bot procedure file."))
        (print "Error loading procedure file."))
    new-bot-proc))

(define (bot-loop in-port out-port)
  (let ((privmsg (lambda (to . args)
                   (let ((msg (list #f #f "PRIVMSG" (cons to args))))
                     (write-msg msg out-port)
                     (when (>= verbosity-level 1)
                       (display "Responded with msg: ")
                       (write msg)
                       (newline))))))
    (let loop ((msg (read-msg in-port)))
      (match (cons (msg-source msg) (cons (msg-command msg) (msg-args msg)))
        ((_ "PING" token)
         (write-msg `(#f #f "PONG" (,token)) out-port))
        ((source "PRIVMSG" target "bbreload")
         (when (and allow-reload (string=? target bot-nick))
           (print "Reveived reload command from " source)
           (if (load-bot)
               (privmsg source "Reloaded bot script.")
               (privmsg source "Error loading bot script."))))
        ((source "PRIVMSG" target args ...)
         (when (string=? target bot-nick)
           (when (>= verbosity-level 1)
             (display "Received msg: ")
             (write msg)
             (newline))
           (condition-case
               (bot-proc source args privmsg)
             (o (exn)
                (print "Error executing bot script.")
                (print-error-message o)))))
        (_
         ;; Do nothing
         ))
      (loop (read-msg in-port)))))

(define (read-msg in-port)
  (let ((msg (string->msg (read-line in-port))))
    (when (>= verbosity-level 2)
      (display "Received message: ")
      (write msg)
      (newline))
    msg))

(define (write-msg msg out-port)
  (with-output-to-port out-port
    (lambda () (write-string (conc (msg->string msg) "\r\n"))))
  (when (>= verbosity-level 2)
    (print "Sent message: " msg)))

(define msg-regex
  (irregex '(:
             (? (: "@" (submatch (+ (~ " "))) (* " ")))
             (? (: ":" (submatch (+ (~ " " "!" "@")))
                   (* (~ " "))          ;discard non-nick portion
                   (* " ")))
             (submatch (+ (~ " ")))
             (* " ")
             (? (submatch (+ any))))))

(define (string->msg string)
  (let ((match  (irregex-match msg-regex string)))
    (list
     (irregex-match-substring match 1) ; Tags
     (irregex-match-substring match 2) ; Source
     (string-upcase (irregex-match-substring match 3)) ; command
     (parse-message-args (irregex-match-substring match 4))))) ;args

(define (msg->string msg)
  (conc
   (msg-command msg)
   (let ((args (msg-args msg)))
     (if args (conc " " (make-arg-string args)) ""))))

(define (make-arg-string args)
  (let* ((revargs (reverse args))
         (final-arg (car revargs))
         (first-args (reverse (cdr revargs))))
    (conc (string-join first-args " ")
          " :" final-arg)))

(define (parse-message-args argstr)
  (if argstr
      (let ((idx (substring-index ":" argstr)))
        (if idx
            (append
             (string-split (substring argstr 0 idx) " ")
             (list (substring argstr (+ idx 1))))
            (string-split argstr " ")))))

(define (msg-tags msg) (list-ref msg 0))
(define (msg-source msg) (list-ref msg 1))
(define (msg-command msg) (list-ref msg 2))
(define (msg-args msg) (list-ref msg 3))

(define (print-usage progname)
  (let ((indent-str (make-string (string-length progname) #\space)))
    (print "Usage:\n"
           progname " [-h/--help]\n"
           progname " [-p/--port PORT] [--notls] [-c/--channnel CHANNEL]\n"
           indent-str " [-v/--verbose] [-a/--allow-reload]\n"
           indent-str " proc-file host nick")))

(define (main)
  (let ((progname (pathname-file (car (argv))))
        (port 6697)
        (channel #f))
    (if (null? (command-line-arguments))
        (print-usage progname)
        (let loop ((args (command-line-arguments)))
          (let ((this-arg (car args))
                (rest-args (cdr args)))
            (if (string-prefix? "-" this-arg)
                (cond
                 ((or (equal? this-arg "-h")
                      (equal? this-arg "--help"))
                  (print-usage progname))
                 ((or (equal? this-arg "-p")
                      (equal? this-arg "--port"))
                  (set! irc-port (string->number (car rest-args)))
                  (loop (cdr rest-args)))
                 ((equal? this-arg "--notls")
                  (set! usetls #f)
                  (loop rest-args))
                 ((or (equal? this-arg "-c")
                      (equal? this-arg "--channel"))
                  (set! bot-channel (car rest-args))
                  (loop (cdr rest-args)))
                 ((or (equal? this-arg "-v")
                      (equal? this-arg "--verbose"))
                  (set! verbosity-level (+ 1 verbosity-level))
                  (loop rest-args))
                 ((or (equal? this-arg "-a")
                      (equal? this-arg "--allow-reload"))
                  (set! allow-reload #t)
                  (loop rest-args))
                 (else
                  (print "Unknown argument '" this-arg "'")
                  (print-usage progname)))
                (match args
                  ((procfile host nick)
                   (set! bot-proc-file procfile)
                   (set! irc-host host)
                   (set! bot-nick nick)
                   (if  (load-bot)
                        (launch-bot)
                        (error "Could not load bot procedure.")))
                  (else
                   (print "One or more invalid arguments.")
                   (print-usage progname)))))))))

(main)