#!/usr/bin/env -S csi -ss

(import (chicken format)
        (chicken io)
        (chicken irregex)
        (chicken process)
        (chicken process-context)
        (chicken time posix)
        irc
        srfi-18
        srfi-26)

(include-relative "config.scm")


(define (process-log-line tag message timestamp log-port control-port)
  (when verbose-log-relay?
    (irc:say irc-conn (sprintf "[~a] ~a" tag message) irc-channel))
  ;; check for regular chat message
  (let ([match (irregex-search chat-message-format message)])
    (when (and (equal? tag "INFO") match)
      (let ([username (irregex-match-substring match 1)]
            [message (irregex-match-substring match 2)])
        (irc:command irc-conn
                     (sprintf "NPC ~a ~a :~a" irc-channel username message))
        #;(printf "<~a> ~a~n" username message))))
  ;; check for /me message
  (let ([match (irregex-search chat-action-format message)])
    (when (and (equal? tag "INFO") match)
      (let ([username (irregex-match-substring match 1)]
            [message (irregex-match-substring match 2)])
        (irc:command irc-conn
                     (sprintf "NPCA ~a ~a :~a" irc-channel username message))
        #;(printf "* ~a ~a~n" username message))))
  ;; check for joins and parts
  (let ([match (irregex-search player-join-format message)])
    (when (and (equal? tag "INFO") match)
      (let ([username (irregex-match-substring match 1)])
        (irc:say irc-conn (sprintf "8~a joined the game" username)
                 irc-channel)
        #;(printf "~a joined~n" username))))
  (let ([match (irregex-search player-part-format message)])
    (when (and (equal? tag "INFO") match)
      (let ([username (irregex-match-substring match 1)])
        (irc:say irc-conn (sprintf "8~a left the game" username) irc-channel)
        #;(printf "~a quit~n" (irregex-match-substring match 1))))))


(define (each-line line log-port control-port)
  (when (not (eof-object? line))
    (when emit-minecraft-log?
      (write-line line (current-error-port)))
    (let ([timestamp (string->time line timestamp-format)]
          [match (irregex-search log-line-format line)])
      (when (and timestamp match)
        (let ([log-tag (irregex-match-substring match 1)]
              [log-message (irregex-match-substring match 2)])
          (process-log-line log-tag log-message timestamp
                            log-port control-port))))
    (each-line (read-line log-port) log-port control-port)))


;; TODO: convert colour codes between each protocol


(define (handle-admin-command control-port sender command)
  (cond
    [(not (member sender irc-admins))
     (irc:say irc-conn
              (sprintf "~a, you don't have permission to do that" sender)
              irc-channel)]
    [(equal? (substring command 0 1) "/")
     (write-line (substring command 1) control-port)]
    [(equal? command "set-verbose")
     (set! verbose-log-relay? #t)]
    [(equal? command "unset-verbose")
     (set! verbose-log-relay? #f)]
    [else
     (irc:say irc-conn (sprintf "~a, I can't understand that command" sender)
              irc-channel)]))


(define (message-handler control-port msg)
  (when emit-irc-trace?
    (write-line (irc:message-body msg) (current-error-port)))
  (cond
    ;; admin commands
    [(and (equal? (irc:message-command msg) "PRIVMSG")
          (not (irc:extended-data? (cadr (irc:message-parameters msg))))
          (equal? (substring (cadr (irc:message-parameters msg)) 0 2) "!!"))
     (handle-admin-command control-port (irc:message-sender msg)
                           (substring (cadr (irc:message-parameters msg)) 2))]
    ;; accept messages; ignore RPs (to avoid duplicating our own stuff)
    [(and (equal? (irc:message-command msg) "PRIVMSG")
          (not (member (caddr (irc:message-prefix msg))
                       (list "npc.fakeuser.invalid"
                             (irc:connection-nick irc-conn)))))
     (if (irc:extended-data? (cadr (irc:message-parameters msg)))
         ;; CTCP
         (let ([extdata (cadr (irc:message-parameters msg))])
           (when (equal? (irc:extended-data-tag extdata) 'ACTION)
             (fprintf control-port "say §7[~a]§r * ~a ~a~n"
                      (irc:message-receiver msg)
                      (irc:message-sender msg)
                      (irc:extended-data-content extdata))))
         ;; normal message
         (fprintf control-port "say §7[~a]§r <~a> ~a~n"
                  (irc:message-receiver msg)
                  (irc:message-sender msg)
                  (cadr (irc:message-parameters msg))))]
    ;; join/part/quit lines
    [(equal? (irc:message-command msg) "JOIN")
     (fprintf control-port "say §7[~a] §e~a joined the channel~n"
              (irc:message-receiver msg)
              (irc:message-sender msg))]
    [(equal? (irc:message-command msg) "PART")
     (fprintf control-port "say §7[~a] §e~a left the channel (~a)~n"
              (irc:message-receiver msg)
              (irc:message-sender msg)
              (cadr (irc:message-parameters msg)))]
    [(equal? (irc:message-command msg) "QUIT")
     (fprintf control-port "say §7[~a] §e~a left the server (~a)~n"
              (irc:message-receiver msg)
              (irc:message-sender msg)
              (cadr (irc:message-parameters msg)))])
  #f)


(define (main args)
  (change-directory server-dir)
  (let-values ([(cout ccmd pid clog) (process* (car server-command)
                                               (cdr server-command))])
    (irc:connect irc-conn)
    (irc:join irc-conn irc-channel)
    (irc:add-message-handler! irc-conn (cut message-handler ccmd <>))
    (let ([irc-loop (make-thread
                      (lambda () (irc:run-message-loop irc-conn #:pong #t))
                      'irc-loop)]
          [log-watcher (make-thread
                         (lambda () (each-line (read-line clog) clog ccmd))
                         'log-watcher)])
      (thread-start! irc-loop)
      (thread-start! log-watcher)
      (thread-join! log-watcher) ;; terminates when the server exits
      (irc:quit irc-conn "Minecraft server process exited")
      (thread-join! irc-loop))))