#!/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 (relayed-privmsg conn recipient spoofnick message) (case irc-relay-mode [(relaymsg) (irc:command conn (sprintf "RELAYMSG ~a ~a/~a :~a" recipient (irc:connection-nick conn) spoofnick message))] [(roleplay) (irc:command conn (sprintf "NPC ~a ~a :~a" recipient spoofnick message))] [else (irc:say conn (sprintf "<~a> ~a" spoofnick message) recipient)])) (define (relayed-action conn recipient spoofnick message) (case irc-relay-mode [(relaymsg) (irc:command conn (sprintf "RELAYMSG ~a ~a/~a :\001ACTION ~a\001" recipient (irc:connection-nick conn) spoofnick message))] [(roleplay) (irc:command conn (sprintf "NPCA ~a ~a :~a" recipient spoofnick message))] [else (irc:say conn (sprintf "* ~a ~a" spoofnick message) recipient)])) (define (message-from-self? conn message) (or (equal? (irc:message-sender message) (irc:connection-nick conn)) (case irc-relay-mode [(relaymsg) (let ([prefix (string-append (irc:connection-nick conn) "/")] [sender (irc:message-sender message)]) (and (>= (string-length sender) (string-length prefix)) (equal? (substring sender 0 (string-length prefix)) prefix)))] [(roleplay) (equal? (caddr (irc:message-prefix message)) "npc.fakeuser.invalid")] [else #f]))) (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)]) (relayed-privmsg irc-conn 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)]) (relayed-action irc-conn 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 (message-from-self? irc-conn msg))) (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))))