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
71 : terminate-irc ( irc-client -- )
72 [ is-running>> ] keep and [
73 [ [ irc-end ] dip in-messages>> mailbox-put ]
74 [ [ f ] dip (>>is-running) ]
81 SYMBOL: current-irc-client
83 ! ======================================
85 ! ======================================
87 : irc> ( -- irc-client ) current-irc-client get ;
88 : irc-stream> ( -- stream ) irc> stream>> ;
89 : irc-write ( s -- ) irc-stream> stream-write ;
90 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
91 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
92 : listener> ( name -- listener/f ) irc> listeners>> at ;
94 : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
95 [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
97 GENERIC: to-listener ( message obj -- )
99 M: string to-listener ( message string -- )
100 listener> [ +server-listener+ listener> ] unless*
101 [ to-listener ] [ drop ] if* ;
103 M: irc-listener to-listener ( message irc-listener -- )
104 in-messages>> mailbox-put ;
106 : unregister-listener ( name -- )
108 [ at [ irc-listener-end ] dip to-listener ]
112 : (remove-participant) ( nick listener -- )
113 [ participants>> delete-at ]
114 [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
116 : remove-participant ( nick channel -- )
117 listener> [ (remove-participant) ] [ drop ] if* ;
119 : listeners-with-participant ( nick -- seq )
120 irc> listeners>> values
121 [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
124 : to-listeners-with-participant ( message nickname -- )
125 listeners-with-participant [ to-listener ] with each ;
127 : remove-participant-from-all ( nick -- )
128 dup listeners-with-participant [ (remove-participant) ] with each ;
130 : notify-rename ( newnick oldnick listener -- )
131 [ participant-changed new +nick+ >>action
132 [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
134 : rename-participant ( newnick oldnick listener -- )
135 [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
136 [ notify-rename ] 3bi ;
138 : rename-participant-in-all ( oldnick newnick -- )
139 swap dup listeners-with-participant [ rename-participant ] with with each ;
141 : add-participant ( mode nick channel -- )
143 [ participants>> set-at ]
144 [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
149 : maybe-forward-join ( join -- )
150 [ irc-message-sender me? ] keep and
151 [ irc> join-messages>> mailbox-put ] when* ;
153 ! ======================================
154 ! IRC client messages
155 ! ======================================
158 "NICK " irc-write irc-print ;
162 "USER " irc-write irc-write
163 " hostname servername :irc.factor" irc-print ;
165 : /CONNECT ( server port -- stream )
166 irc> connect>> call drop ;
168 : /JOIN ( channel password -- )
170 [ [ " :" ] dip 3append ] when* irc-print ;
173 "PONG " irc-write irc-print ;
175 ! ======================================
176 ! Server message handling
177 ! ======================================
179 : me? ( string -- ? )
180 irc> profile>> nickname>> = ;
182 GENERIC: forward-name ( irc-message -- name )
183 M: join forward-name ( join -- name ) trailing>> ;
184 M: part forward-name ( part -- name ) channel>> ;
185 M: kick forward-name ( kick -- name ) channel>> ;
186 M: mode forward-name ( mode -- name ) channel>> ;
187 M: privmsg forward-name ( privmsg -- name )
188 dup name>> me? [ irc-message-sender ] [ name>> ] if ;
190 UNION: single-forward join part kick mode privmsg ;
191 UNION: multiple-forward nick quit ;
192 UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
193 GENERIC: forward-message ( irc-message -- )
195 M: irc-message forward-message ( irc-message -- )
196 +server-listener+ listener> [ to-listener ] [ drop ] if* ;
198 M: single-forward forward-message ( forward-single -- )
199 dup forward-name to-listener ;
201 M: multiple-forward forward-message ( multiple-forward -- )
202 dup irc-message-sender to-listeners-with-participant ;
204 M: join forward-message ( join -- )
205 [ maybe-forward-join ] [ call-next-method ] bi ;
207 M: broadcast-forward forward-message ( irc-broadcasted-message -- )
208 irc> listeners>> values [ to-listener ] with each ;
210 GENERIC: process-message ( irc-message -- )
212 M: object process-message ( object -- )
215 M: logged-in process-message ( logged-in -- )
216 name>> irc> profile>> (>>nickname) ;
218 M: ping process-message ( ping -- )
221 M: nick-in-use process-message ( nick-in-use -- )
222 name>> "_" append /NICK ;
224 M: join process-message ( join -- )
225 [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
227 M: part process-message ( part -- )
228 [ irc-message-sender ] [ channel>> ] bi remove-participant ;
230 M: kick process-message ( kick -- )
231 [ [ who>> ] [ channel>> ] bi remove-participant ]
232 [ dup who>> me? [ unregister-listener ] [ drop ] if ]
235 M: quit process-message ( quit -- )
236 irc-message-sender remove-participant-from-all ;
238 M: nick process-message ( nick -- )
239 [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
241 : >nick/mode ( string -- nick mode )
242 dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
244 : names-reply>participants ( names-reply -- participants )
245 trailing>> [ blank? ] trim " " split
246 [ >nick/mode 2array ] map >hashtable ;
248 M: names-reply process-message ( names-reply -- )
249 [ names-reply>participants ] [ channel>> listener> ] bi [
251 [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
254 : handle-incoming-irc ( irc-message -- )
255 [ forward-message ] [ process-message ] bi ;
257 ! ======================================
258 ! Client message handling
259 ! ======================================
261 : handle-outgoing-irc ( irc-message -- )
262 irc-message>client-line irc-print ;
264 ! ======================================
266 ! ======================================
268 : handle-reader-message ( irc-message -- )
269 irc> in-messages>> mailbox-put ;
273 : (handle-disconnect) ( -- )
275 [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
276 [ dup reconnect-time>> sleep (connect-irc) ]
277 [ profile>> nickname>> /LOGIN ]
280 ! FIXME: do something with the exception, store somewhere to help debugging
281 : handle-disconnect ( error -- )
282 drop irc> is-running>> [ (handle-disconnect) ] when ;
284 : (reader-loop) ( -- )
286 |dispose stream-readln [
287 parse-irc-line handle-reader-message
293 : reader-loop ( -- ? )
294 [ (reader-loop) ] [ handle-disconnect ] recover t ;
296 : writer-loop ( -- ? )
297 irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
299 ! ======================================
301 ! ======================================
303 : in-multiplexer-loop ( -- ? )
304 irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
306 : strings>privmsg ( name string -- privmsg )
307 privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
309 : maybe-annotate-with-name ( name obj -- obj )
310 { { [ dup string? ] [ strings>privmsg ] }
311 { [ dup privmsg instance? ] [ swap >>name ] }
315 : listener-loop ( name -- ? )
317 out-messages>> [ maybe-annotate-with-name
318 irc> out-messages>> mailbox-put ] with
322 : spawn-irc-loop ( quot: ( -- ? ) name -- )
323 [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
327 [ reader-loop ] "irc-reader-loop" spawn-irc-loop
328 [ writer-loop ] "irc-writer-loop" spawn-irc-loop
329 [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
331 ! ======================================
332 ! Listener join request handling
333 ! ======================================
335 : set+run-listener ( name irc-listener -- )
336 over irc> listeners>> set-at
337 '[ _ listener-loop ] "listener" spawn-irc-loop ;
339 GENERIC: (add-listener) ( irc-listener -- )
341 M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
342 [ [ name>> ] [ password>> ] bi /JOIN ]
343 [ [ [ drop irc> join-messages>> ]
345 [ name>> '[ trailing>> _ = ] ]
346 tri mailbox-get-timeout? trailing>> ] keep set+run-listener
349 M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
350 [ name>> ] keep set+run-listener ;
352 M: irc-server-listener (add-listener) ( irc-server-listener -- )
353 [ +server-listener+ ] dip set+run-listener ;
355 GENERIC: (remove-listener) ( irc-listener -- )
357 M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
358 name>> unregister-listener ;
360 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
361 [ [ name>> ] [ out-messages>> ] bi
362 [ [ part new ] dip >>channel ] dip mailbox-put ] keep
363 name>> unregister-listener ;
365 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
366 drop +server-listener+ unregister-listener ;
368 : (connect-irc) ( irc-client -- )
369 [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
372 in-messages>> [ irc-connected ] dip mailbox-put ;
374 : with-irc-client ( irc-client quot: ( -- ) -- )
375 [ \ current-irc-client ] dip with-variable ; inline
379 : connect-irc ( irc-client -- )
381 [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
382 spawn-irc ] with-irc-client ;
384 : add-listener ( irc-listener irc-client -- )
385 swap '[ _ (add-listener) ] with-irc-client ;
387 : remove-listener ( irc-listener irc-client -- )
388 swap '[ _ (remove-listener) ] with-irc-client ;
390 : write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
391 : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;