blob: 07fb5c23255d9874d32013f71fac2aef570b9ad7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
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))))
|
