initial commit

1 files changed, 146 insertions, 0 deletions

diff --git a/wrapper.scm b/wrapper.scm
new file mode 100755
index 0000000..07fb5c2
--- /dev/null
+++ b/wrapper.scm
@@ -0,0 +1,146 @@
+#!/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))))