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 fry
5 continuations threads strings classes combinators splitting hashtables
6 ascii irc.messages irc.messages.base irc.messages.parser call ;
7 RENAME: join sequences => sjoin
8 EXCLUDE: sequences => join ;
11 ! ======================================
12 ! Setup and running objects
13 ! ======================================
15 CONSTANT: 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
21 chats is-running nick connect reconnect-time is-ready ;
23 : <irc-client> ( profile -- irc-client )
26 <mailbox> >>in-messages
27 <mailbox> >>out-messages
29 dup profile>> nickname>> >>nick
30 [ <inet> latin1 <client> ] >>connect
31 15 seconds >>reconnect-time ;
33 TUPLE: irc-chat in-messages client ;
34 TUPLE: irc-server-chat < irc-chat ;
35 TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
36 TUPLE: irc-nick-chat < irc-chat name ;
44 : participant-mode ( n -- mode )
45 H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
47 ! participant changed actions
54 : <irc-server-chat> ( -- irc-server-chat )
55 <mailbox> f irc-server-chat boa ;
57 : <irc-channel-chat> ( name -- irc-channel-chat )
58 [ <mailbox> f ] dip f 60 seconds H{ } clone t
59 irc-channel-chat boa ;
61 : <irc-nick-chat> ( name -- irc-nick-chat )
62 [ <mailbox> f ] dip irc-nick-chat boa ;
64 ! ======================================
66 ! ======================================
68 TUPLE: participant-changed nick action parameter ;
69 C: <participant-changed> participant-changed
71 SINGLETON: irc-chat-end ! sent to a chat to stop its execution
72 SINGLETON: irc-end ! sent when the client isn't running anymore
73 SINGLETON: irc-disconnected ! sent when connection is lost
74 SINGLETON: irc-connected ! sent when connection is established
76 : terminate-irc ( irc-client -- )
79 [ stream>> dispose ] keep
80 [ in-messages>> ] [ out-messages>> ] bi 2array
81 [ irc-end swap mailbox-put ] each
86 SYMBOL: current-irc-client
88 ! ======================================
90 ! ======================================
92 : irc> ( -- irc-client ) current-irc-client get ;
93 : irc-write ( s -- ) irc> stream>> stream-write ;
94 : irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
95 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
96 : chat> ( name -- chat/f ) irc> chats>> at ;
97 : channel-mode? ( mode -- ? ) name>> first "#&" member? ;
98 : me? ( string -- ? ) irc> nick>> = ;
100 GENERIC: to-chat ( message obj -- )
103 chat> [ +server-chat+ chat> ] unless*
104 [ to-chat ] [ drop ] if* ;
106 M: irc-chat to-chat in-messages>> mailbox-put ;
108 : unregister-chat ( name -- )
110 [ at [ irc-chat-end ] dip to-chat ]
114 : (remove-participant) ( nick chat -- )
115 [ participants>> delete-at ]
116 [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
118 : remove-participant ( nick channel -- )
119 chat> [ (remove-participant) ] [ drop ] if* ;
121 : chats-with-participant ( nick -- seq )
123 [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ]
126 : to-chats-with-participant ( message nickname -- )
127 chats-with-participant [ to-chat ] with each ;
129 : remove-participant-from-all ( nick -- )
130 dup chats-with-participant [ (remove-participant) ] with each ;
132 : notify-rename ( newnick oldnick chat -- )
133 [ participant-changed new +nick+ >>action
134 [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
136 : rename-participant ( newnick oldnick chat -- )
137 [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
138 [ notify-rename ] 3bi ;
140 : rename-participant-in-all ( oldnick newnick -- )
141 swap dup chats-with-participant [ rename-participant ] with with each ;
143 : add-participant ( mode nick channel -- )
145 [ participants>> set-at ]
146 [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
148 : change-participant-mode ( channel mode nick -- )
150 [ participants>> set-at ]
151 [ [ participant-changed new
152 [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
155 ! ======================================
156 ! IRC client messages
157 ! ======================================
160 "NICK " irc-write irc-print ;
164 "USER " irc-write irc-write
165 " hostname servername :irc.factor" irc-print ;
167 : /CONNECT ( server port -- stream )
168 irc> connect>> call( host port -- stream local ) drop ;
170 : /JOIN ( channel password -- )
171 "JOIN " irc-write [ " :" swap 3append ] when* irc-print ;
174 "PONG " irc-write irc-print ;
176 ! ======================================
177 ! Server message handling
178 ! ======================================
180 GENERIC: initialize-chat ( chat -- )
181 M: irc-chat initialize-chat drop ;
182 M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
184 GENERIC: forward-name ( irc-message -- name )
185 M: join forward-name trailing>> ;
186 M: part forward-name channel>> ;
187 M: kick forward-name channel>> ;
188 M: mode forward-name name>> ;
189 M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ;
191 UNION: single-forward join part kick mode privmsg ;
192 UNION: multiple-forward nick quit ;
193 UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
194 GENERIC: forward-message ( irc-message -- )
196 M: irc-message forward-message
197 +server-chat+ chat> [ to-chat ] [ drop ] if* ;
199 M: single-forward forward-message dup forward-name to-chat ;
201 M: multiple-forward forward-message
202 dup sender>> to-chats-with-participant ;
204 M: broadcast-forward forward-message
205 irc> chats>> values [ to-chat ] with each ;
207 GENERIC: process-message ( irc-message -- )
208 M: object process-message drop ;
209 M: rpl-welcome process-message
210 nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
211 values [ initialize-chat ] each ;
212 M: ping process-message trailing>> /PONG ;
213 M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
215 M: join process-message
216 [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri
217 dup chat> [ add-participant ] [ 3drop ] if ;
219 M: part process-message
220 [ sender>> ] [ channel>> ] bi remove-participant ;
222 M: kick process-message
223 [ [ user>> ] [ channel>> ] bi remove-participant ]
224 [ dup user>> me? [ unregister-chat ] [ drop ] if ]
227 M: quit process-message
228 sender>> remove-participant-from-all ;
230 M: nick process-message
231 [ sender>> ] [ trailing>> ] bi rename-participant-in-all ;
233 M: mode process-message ( mode -- )
235 [ name>> ] [ mode>> ] [ parameter>> ] tri
236 [ change-participant-mode ] [ 2drop ] if*
239 : >nick/mode ( string -- nick mode )
240 dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
242 : names-reply>participants ( names-reply -- participants )
243 nicks>> [ blank? ] trim " " split
244 [ >nick/mode 2array ] map >hashtable ;
246 : maybe-clean-participants ( channel-chat -- )
247 dup clean-participants>> [
248 H{ } clone >>participants f >>clean-participants
251 M: rpl-names process-message
252 [ names-reply>participants ] [ channel>> chat> ] bi [
253 [ maybe-clean-participants ]
254 [ participants>> 2array assoc-combine ]
255 [ (>>participants) ] tri
258 M: rpl-names-end process-message
260 t >>clean-participants
261 [ f f f <participant-changed> ] dip name>> to-chat
264 ! ======================================
265 ! Client message handling
266 ! ======================================
268 GENERIC: handle-outgoing-irc ( irc-message -- ? )
269 M: irc-end handle-outgoing-irc drop f ;
270 M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
272 ! ======================================
274 ! ======================================
276 : handle-reader-message ( irc-message -- )
277 irc> in-messages>> mailbox-put ;
281 : (handle-disconnect) ( -- )
283 [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
284 [ dup reconnect-time>> sleep (connect-irc) ]
288 ! FIXME: do something with the exception, store somewhere to help debugging
289 : handle-disconnect ( error -- ? )
290 drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
292 : (reader-loop) ( -- ? )
294 |dispose stream-readln [
295 string>irc-message handle-reader-message t
301 : reader-loop ( -- ? )
302 [ (reader-loop) ] [ handle-disconnect ] recover ;
304 : writer-loop ( -- ? )
305 irc> out-messages>> mailbox-get handle-outgoing-irc ;
307 ! ======================================
309 ! ======================================
311 : in-multiplexer-loop ( -- ? )
312 irc> in-messages>> mailbox-get
313 [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
315 : strings>privmsg ( name string -- privmsg )
316 " :" prepend append "PRIVMSG " prepend string>irc-message ;
318 : maybe-annotate-with-name ( name obj -- obj )
319 { { [ dup string? ] [ strings>privmsg ] }
320 { [ dup privmsg instance? ] [ swap >>name ] }
324 GENERIC: annotate-message ( chat object -- object )
325 M: object annotate-message nip ;
326 M: part annotate-message swap name>> >>channel ;
327 M: privmsg annotate-message swap name>> >>target ;
328 M: string annotate-message [ name>> ] dip strings>privmsg ;
331 [ reader-loop ] "irc-reader-loop" spawn-server
332 [ writer-loop ] "irc-writer-loop" spawn-server
333 [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
336 GENERIC: (attach-chat) ( irc-chat -- )
338 M: irc-chat (attach-chat)
339 [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
340 [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
343 M: irc-server-chat (attach-chat)
344 irc> >>client +server-chat+ irc> chats>> set-at ;
346 GENERIC: (remove-chat) ( irc-chat -- )
348 M: irc-nick-chat (remove-chat)
349 name>> unregister-chat ;
351 M: irc-channel-chat (remove-chat)
352 [ part new annotate-message irc> out-messages>> mailbox-put ] keep
353 name>> unregister-chat ;
355 M: irc-server-chat (remove-chat)
356 drop +server-chat+ unregister-chat ;
358 : (connect-irc) ( irc-client -- )
360 [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
362 [ t swap (>>is-running) ]
363 [ in-messages>> [ irc-connected ] dip mailbox-put ]
366 : with-irc-client ( irc-client quot: ( -- ) -- )
367 [ \ current-irc-client ] dip with-variable ; inline
371 : connect-irc ( irc-client -- )
372 dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
374 : attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
376 : detach-chat ( irc-chat -- )
377 [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
379 : speak ( message irc-chat -- )
380 [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
382 : hear ( irc-chat -- message ) in-messages>> mailbox-get ;