1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright © 2015, 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
3 ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
5 ;;; This file is part of 8sync.
7 ;;; 8sync is free software: you can redistribute it and/or modify it
8 ;;; under the terms of the GNU Lesser General Public License as
9 ;;; published by the Free Software Foundation, either version 3 of the
10 ;;; License, or (at your option) any later version.
12 ;;; 8sync is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU Lesser General Public License for more details.
17 ;;; You should have received a copy of the GNU Lesser General Public
18 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (8sync systems irc)
21 #:use-module (8sync repl)
22 #:use-module (8sync agenda)
23 #:use-module (8sync actors)
24 #:use-module (8sync contrib irc)
25 #:use-module (srfi srfi-9)
26 #:use-module (srfi srfi-26)
27 #:use-module (ice-9 getopt-long)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 receive)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 q)
32 #:use-module (ice-9 match)
33 #:use-module (oop goops)
35 irc-bot-username irc-bot-server irc-bot-channels irc-bot-port
37 irc-bot-init irc-bot-cleanup
38 dispatch-message handle-message
40 default-irc-port ;REMOVEME compat
41 irc-bot-send-line ;REMOVEME compat
42 handle-line handle-misc-input)) ;REMOVEME compat
44 ;;; A goofy default handler.
45 (define* (echo-message irc-bot speaker channel-name
46 line-text emote? #:key (port (current-output-port)))
47 "Simply echoes the message to the PORT."
49 (format port "~a emoted ~s in channel ~a\n"
50 speaker line-text channel-name)
51 (format port "~a said ~s in channel ~a\n"
52 speaker line-text channel-name)))
58 (define-class <irc-bot> (<actor>)
59 (username #:init-keyword #:username
60 #:getter irc-bot-username)
61 (realname #:init-keyword #:realname
63 (server #:init-keyword #:server
64 #:getter irc-bot-server)
65 (channels #:init-keyword #:channels
66 #:getter irc-bot-channels)
67 (port #:init-keyword #:port
68 #:init-value %irc:default-port
69 #:getter irc-bot-port)
70 (socket #:accessor irc-bot-socket)
71 (actions #:allocation #:each-subclass
72 #:init-thunk (build-actions
74 (*cleanup* irc-bot-cleanup)
75 (main-loop irc-bot-main-loop)
76 (dispatch-message dispatch-message)
77 (handle-line handle-line) ;REMOVEME compat
78 (send-line irc-bot-send-line-action))))
80 (define (irc-bot-realname irc-bot)
81 (or (slot-ref irc-bot 'realname)
82 (irc-bot-username irc-bot)))
84 (define-method (irc-bot-init (irc-bot <irc-bot>) message)
85 "Initialize the IRC bot"
86 (define socket (irc:listen (irc-bot-server irc-bot)
87 #:port (irc-bot-port irc-bot)
89 (define flags (fcntl socket F_GETFL))
91 (fcntl socket F_SETFL (logior O_NONBLOCK flags))
92 (set! (irc-bot-socket irc-bot) socket)
94 (irc:user socket (irc-bot-username irc-bot)
95 #:real (irc-bot-realname irc-bot))
96 (irc:nick socket (irc-bot-username irc-bot))
98 (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))
100 (<- (actor-id irc-bot) 'main-loop))
102 (define-method (irc-bot-cleanup (irc-bot <irc-bot>) message)
103 (close (irc-bot-socket irc-bot)))
105 (define (irc-bot-main-loop irc-bot message)
106 (define socket (irc-bot-socket irc-bot))
107 (define line (irc:receive socket))
108 (define message (or (false-if-exception (irc:line->message line))
110 (<- (actor-id irc-bot) 'dispatch-message message)
112 ;; The port's been closed for some reason, so stop looping
113 ((port-closed? socket)
115 ;; We've reached the EOF object, which means we should close
116 ;; the port ourselves and stop looping
117 ((eof-object? (peek-char socket))
120 ;; ;; Looks like we've been killed somehow... well, stop running
122 ;; ((actor-am-i-dead? irc-bot)
123 ;; (if (not (port-closed? socket))
126 ;; Otherwise, let's read till the next line!
128 (<- (actor-id irc-bot) 'main-loop))))
130 (define* (irc-bot-send-line-action irc-bot message
131 channel line #:key emote?)
132 "Action handler for sending lines. Real behavior happens in
134 (define socket (irc-bot-socket irc-bot))
135 (irc:send-line socket channel line #:emote? emote?))
139 ;;; Likely-to-be-overridden generic methods
141 (define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
142 "Dispatch an <irc:message>."
144 ((and ($ <irc:message>)
145 (= irc:message-command 'PING)
146 (= irc:message-message message))
147 (irc:pong (irc-bot-socket irc-bot) message))
148 (_ (handle-message irc-bot message))))
150 (define-method (handle-message (irc-bot <irc-bot>) message)
152 ((and ($ <irc:message>)
153 (= irc:message-line line)
154 (= irc:message-command command)
155 (= irc:message-speaker speaker)
156 (= irc:message-channel channel)
157 (= irc:message-message message)
158 (= irc:message-emote? emote?))
162 (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
164 (handle-misc-input irc-bot line))) ;REMOVEME compat
165 (echo-message irc-bot speaker channel message #f
166 #:port (current-error-port))))))
170 ;;; Compatibility with 0.4.2.
172 (define default-irc-port %irc:default-port)
173 (define irc-eol %irc:eol)
175 (define* (irc-bot-send-line irc-bot channel line #:key emote?)
176 (define socket (irc-bot-socket irc-bot))
177 (irc:send-line socket channel line))
179 (define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
181 username channel-name line-text emote?)
182 "Keep compatibility with previous release."
185 (define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
187 "Keep compatibility with previous release."
190 (define (startswith-colon? str)
191 (and (> (string-length str) 0)
192 (eq? (string-ref str 0)
195 ;; TODO: This needs a cleanup. Maybe even just using a regex is fine.
196 (define (parse-line line) ;REMOVEME compat
197 (define (parse-params pre-params)
198 ;; This is stupid and imperative but I can't wrap my brain around
199 ;; the right way to do it in a functional way :\
200 (let ((param-list '())
201 (currently-building '()))
205 ((startswith-colon? param-item)
206 (if (not (eq? currently-building '()))
209 (reverse currently-building)
211 (set! currently-building (list param-item)))
213 (set! currently-building (cons param-item currently-building)))))
215 ;; We're still building something, so tack that on there
216 (if (not (eq? currently-building '()))
218 (cons (reverse currently-building) param-list)))
219 ;; return the reverse of the param list
220 (reverse param-list)))
222 (match (string-split line #\space)
223 (((? startswith-colon? prefix)
226 (values prefix command
227 (parse-params pre-params)))
228 ((command pre-params ...)
230 (parse-params pre-params)))))
232 (define (strip-colon-if-necessary string) ;REMOVME compat
233 (if (and (> (string-length string) 0)
234 (string-ref string 0))
235 (substring/copy string 1)
238 ;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
239 (define (irc-line-username irc-line-prefix) ;REMOVME compat
240 (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
241 (exclaim-index (string-index prefix-name #\!)))
243 (substring/copy prefix-name 0 exclaim-index)
246 (define (condense-privmsg-line line) ;REMOVME compat
247 "Condense message line and do multiple value return of
248 (channel message emote?)"
249 (define (strip-last-char string)
250 (substring/copy string 0 (- (string-length string) 1)))
251 (let* ((channel-name (caar line))
252 (rest-params (apply append (cdr line))))
254 (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
257 (append middle-words (list last-word))
260 (((= strip-colon-if-necessary first-word) rest-message ...)
262 (string-join (cons first-word rest-message) " ")