1 ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
4 accessors destructors namespaces io assocs arrays qualified fry
5 continuations threads strings classes combinators splitting hashtables
7 RENAME: join sequences => sjoin
8 EXCLUDE: sequences => join ;
11 ! ======================================
12 ! Setup and running objects
13 ! ======================================
15 : irc-port 6667 ; ! Default irc port
17 TUPLE: irc-profile server port nickname password ;
18 C: <irc-profile> irc-profile
20 TUPLE: irc-client profile stream in-messages out-messages join-messages
21 listeners is-running connect reconnect-time ;
22 : <irc-client> ( profile -- irc-client )
23 f <mailbox> <mailbox> <mailbox> H{ } clone f
24 [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
26 TUPLE: irc-listener in-messages out-messages ;
27 TUPLE: irc-server-listener < irc-listener ;
28 TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
29 TUPLE: irc-nick-listener < irc-listener name ;
30 SYMBOL: +server-listener+
37 : participant-mode ( n -- mode )
38 H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
40 ! participant changed actions
47 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
49 : <irc-server-listener> ( -- irc-server-listener )
50 <mailbox> <mailbox> irc-server-listener boa ;
52 : <irc-channel-listener> ( name -- irc-channel-listener )
53 [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
54 irc-channel-listener boa ;
56 : <irc-nick-listener> ( name -- irc-nick-listener )
57 [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
59 ! ======================================
61 ! ======================================
63 TUPLE: participant-changed nick action parameter ;
64 C: <participant-changed> participant-changed
66 SINGLETON: irc-listener-end ! send to a listener to stop its execution
67 SINGLETON: irc-end ! sent when the client isn't running anymore
68 SINGLETON: irc-disconnected ! sent when connection is lost
69 SINGLETON: irc-connected ! sent when connection is established
72 : end-loops ( irc-client -- )
73 [ listeners>> values [ out-messages>> ] map ]
75 [ out-messages>> ] tri 2array prepend
76 [ irc-end swap mailbox-put ] each ;
79 : terminate-irc ( irc-client -- )
80 [ is-running>> ] keep and [
81 [ end-loops ] [ [ f ] dip (>>is-running) ] bi
86 SYMBOL: current-irc-client
88 ! ======================================
90 ! ======================================
92 : irc> ( -- irc-client ) current-irc-client get ;
93 : irc-stream> ( -- stream ) irc> stream>> ;
94 : irc-write ( s -- ) irc-stream> stream-write ;
95 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
96 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
97 : listener> ( name -- listener/f ) irc> listeners>> at ;
98 : channel-mode? ( mode -- ? ) name>> first "#&" member? ;
99 : me? ( string -- ? ) irc> profile>> nickname>> = ;
101 GENERIC: to-listener ( message obj -- )
103 M: string to-listener ( message string -- )
104 listener> [ +server-listener+ listener> ] unless*
105 [ to-listener ] [ drop ] if* ;
107 M: irc-listener to-listener ( message irc-listener -- )
108 in-messages>> mailbox-put ;
110 : unregister-listener ( name -- )
112 [ at [ irc-listener-end ] dip to-listener ]
116 : (remove-participant) ( nick listener -- )
117 [ participants>> delete-at ]
118 [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
120 : remove-participant ( nick channel -- )
121 listener> [ (remove-participant) ] [ drop ] if* ;
123 : listeners-with-participant ( nick -- seq )
124 irc> listeners>> values
125 [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
128 : to-listeners-with-participant ( message nickname -- )
129 listeners-with-participant [ to-listener ] with each ;
131 : remove-participant-from-all ( nick -- )
132 dup listeners-with-participant [ (remove-participant) ] with each ;
134 : notify-rename ( newnick oldnick listener -- )
135 [ participant-changed new +nick+ >>action
136 [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
138 : rename-participant ( newnick oldnick listener -- )
139 [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
140 [ notify-rename ] 3bi ;
142 : rename-participant-in-all ( oldnick newnick -- )
143 swap dup listeners-with-participant [ rename-participant ] with with each ;
145 : add-participant ( mode nick channel -- )
147 [ participants>> set-at ]
148 [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
150 : change-participant-mode ( channel mode nick -- )
152 [ participants>> set-at ]
153 [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
157 : maybe-forward-join ( join -- )
158 [ irc-message-sender me? ] keep and
159 [ irc> join-messages>> mailbox-put ] when* ;
161 ! ======================================
162 ! IRC client messages
163 ! ======================================
166 "NICK " irc-write irc-print ;
170 "USER " irc-write irc-write
171 " hostname servername :irc.factor" irc-print ;
173 : /CONNECT ( server port -- stream )
174 irc> connect>> call drop ;
176 : /JOIN ( channel password -- )
178 [ [ " :" ] dip 3append ] when* irc-print ;
181 "PONG " irc-write irc-print ;
183 ! ======================================
184 ! Server message handling
185 ! ======================================
187 GENERIC: forward-name ( irc-message -- name )
188 M: join forward-name ( join -- name ) trailing>> ;
189 M: part forward-name ( part -- name ) channel>> ;
190 M: kick forward-name ( kick -- name ) channel>> ;
191 M: mode forward-name ( mode -- name ) name>> ;
192 M: privmsg forward-name ( privmsg -- name )
193 dup name>> me? [ irc-message-sender ] [ name>> ] if ;
195 UNION: single-forward join part kick mode privmsg ;
196 UNION: multiple-forward nick quit ;
197 UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
198 GENERIC: forward-message ( irc-message -- )
200 M: irc-message forward-message ( irc-message -- )
201 +server-listener+ listener> [ to-listener ] [ drop ] if* ;
203 M: single-forward forward-message ( forward-single -- )
204 dup forward-name to-listener ;
206 M: multiple-forward forward-message ( multiple-forward -- )
207 dup irc-message-sender to-listeners-with-participant ;
209 M: join forward-message ( join -- )
210 [ maybe-forward-join ] [ call-next-method ] bi ;
212 M: broadcast-forward forward-message ( irc-broadcasted-message -- )
213 irc> listeners>> values [ to-listener ] with each ;
215 GENERIC: process-message ( irc-message -- )
217 M: object process-message ( object -- )
220 M: logged-in process-message ( logged-in -- )
221 name>> irc> profile>> (>>nickname) ;
223 M: ping process-message ( ping -- )
226 M: nick-in-use process-message ( nick-in-use -- )
227 name>> "_" append /NICK ;
229 M: join process-message ( join -- )
230 [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
231 dup listener> [ add-participant ] [ 3drop ] if ;
233 M: part process-message ( part -- )
234 [ irc-message-sender ] [ channel>> ] bi remove-participant ;
236 M: kick process-message ( kick -- )
237 [ [ who>> ] [ channel>> ] bi remove-participant ]
238 [ dup who>> me? [ unregister-listener ] [ drop ] if ]
241 M: quit process-message ( quit -- )
242 irc-message-sender remove-participant-from-all ;
244 M: nick process-message ( nick -- )
245 [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
247 ! M: mode process-message ( mode -- )
248 ! [ channel-mode? ] keep and [
249 ! [ name>> ] [ mode>> ] [ parameter>> ] tri
250 ! [ change-participant-mode ] [ 2drop ] if*
253 : >nick/mode ( string -- nick mode )
254 dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
256 : names-reply>participants ( names-reply -- participants )
257 trailing>> [ blank? ] trim " " split
258 [ >nick/mode 2array ] map >hashtable ;
260 M: names-reply process-message ( names-reply -- )
261 [ names-reply>participants ] [ channel>> listener> ] bi [
263 [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
266 ! ======================================
267 ! Client message handling
268 ! ======================================
270 GENERIC: handle-outgoing-irc ( irc-message -- ? )
271 M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
272 M: irc-message handle-outgoing-irc ( irc-message -- ? )
273 irc-message>client-line irc-print t ;
275 ! ======================================
277 ! ======================================
279 : handle-reader-message ( irc-message -- )
280 irc> in-messages>> mailbox-put ;
284 : (handle-disconnect) ( -- )
286 [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
287 [ dup reconnect-time>> sleep (connect-irc) ]
288 [ profile>> nickname>> /LOGIN ]
291 ! FIXME: do something with the exception, store somewhere to help debugging
292 : handle-disconnect ( error -- )
293 drop irc> is-running>> [ (handle-disconnect) ] when ;
295 : (reader-loop) ( -- ? )
297 |dispose stream-readln [
298 parse-irc-line handle-reader-message t
304 : reader-loop ( -- ? )
305 [ (reader-loop) ] [ handle-disconnect t ] recover ;
307 : writer-loop ( -- ? )
308 irc> out-messages>> mailbox-get handle-outgoing-irc ;
310 ! ======================================
312 ! ======================================
314 : in-multiplexer-loop ( -- ? )
315 irc> in-messages>> mailbox-get
316 [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
318 : strings>privmsg ( name string -- privmsg )
319 privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
321 : maybe-annotate-with-name ( name obj -- obj )
322 { { [ dup string? ] [ strings>privmsg ] }
323 { [ dup privmsg instance? ] [ swap >>name ] }
327 GENERIC: handle-listener-out ( irc-message -- ? )
328 M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
329 M: irc-message handle-listener-out ( irc-message -- ? )
330 irc> out-messages>> mailbox-put t ;
332 : listener-loop ( name -- ? )
334 out-messages>> mailbox-get
335 maybe-annotate-with-name handle-listener-out
339 [ reader-loop ] "irc-reader-loop" spawn-server
340 [ writer-loop ] "irc-writer-loop" spawn-server
341 [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
344 ! ======================================
345 ! Listener join request handling
346 ! ======================================
348 : set+run-listener ( name irc-listener -- )
349 over irc> listeners>> set-at
350 '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
352 GENERIC: (add-listener) ( irc-listener -- )
354 M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
355 [ [ name>> ] [ password>> ] bi /JOIN ]
356 [ [ [ drop irc> join-messages>> ]
358 [ name>> '[ trailing>> _ = ] ]
359 tri mailbox-get-timeout? trailing>> ] keep set+run-listener
362 M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
363 [ name>> ] keep set+run-listener ;
365 M: irc-server-listener (add-listener) ( irc-server-listener -- )
366 [ +server-listener+ ] dip set+run-listener ;
368 GENERIC: (remove-listener) ( irc-listener -- )
370 M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
371 name>> unregister-listener ;
373 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
374 [ [ name>> ] [ out-messages>> ] bi
375 [ [ part new ] dip >>channel ] dip mailbox-put ] keep
376 name>> unregister-listener ;
378 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
379 drop +server-listener+ unregister-listener ;
381 : (connect-irc) ( irc-client -- )
382 [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
385 in-messages>> [ irc-connected ] dip mailbox-put ;
387 : with-irc-client ( irc-client quot: ( -- ) -- )
388 [ \ current-irc-client ] dip with-variable ; inline
392 : connect-irc ( irc-client -- )
394 [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
395 spawn-irc ] with-irc-client ;
397 : add-listener ( irc-listener irc-client -- )
398 swap '[ _ (add-listener) ] with-irc-client ;
400 : remove-listener ( irc-listener irc-client -- )
401 swap '[ _ (remove-listener) ] with-irc-client ;
403 : write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
404 : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;