1 ! Copyright (C) 2009 Bruno Deferrari
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators concurrency.mailboxes
4 continuations destructors io irc.client.base irc.client.chats
5 irc.client.participants irc.messages irc.messages.base
6 irc.messages.parser kernel math sequences strings threads
8 IN: irc.client.internals
10 : do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
12 [ drop call( host port -- stream ) ]
13 [ drop 15 sleep 1 - do-connect ]
17 : /NICK ( nick -- ) "NICK " prepend irc-print ;
18 : /PONG ( text -- ) "PONG " prepend irc-print ;
19 : /PASS ( password -- ) "PASS " prepend irc-print ;
23 "USER " prepend " hostname servername :irc.factor" append irc-print ;
25 : /CONNECT ( server port -- stream )
26 irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
28 : /JOIN ( channel password -- )
29 [ " :" glue ] when* "JOIN " prepend irc-print ;
31 : try-connect ( -- stream/f )
32 irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
34 : (terminate-irc) ( -- )
35 irc> dup is-running>> [
37 [ stream>> dispose ] keep
38 [ in-messages>> ] [ out-messages>> ] bi 2array
39 [ irc-end swap mailbox-put ] each
42 : (connect-irc) ( -- )
44 [ irc> ] dip >>stream t >>is-running
45 in-messages>> [ irc-connected ] dip mailbox-put
46 ] [ (terminate-irc) ] if* ;
50 [ profile>> password>> [ /PASS ] when* ]
54 GENERIC: initialize-chat ( chat -- )
55 M: irc-chat initialize-chat drop ;
56 M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
58 GENERIC: chat-put ( message obj -- )
59 M: irc-chat chat-put in-messages>> mailbox-put ;
60 M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
61 M: string chat-put chat> +server-chat+ or chat-put ;
62 M: sequence chat-put [ chat-put ] with each ;
64 : delete-chat ( name -- ) irc> chats>> delete-at ;
65 : unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
67 ! Server message handling
69 GENERIC: message-forwards ( irc-message -- seq )
70 M: irc-message message-forwards drop +server-chat+ ;
71 M: to-one-chat message-forwards chat> ;
72 M: to-all-chats message-forwards drop chats> ;
73 M: to-many-chats message-forwards sender>> participant-chats ;
75 GENERIC: process-message ( irc-message -- )
76 M: object process-message drop ;
77 M: ping process-message trailing>> /PONG ;
78 ! FIXME: it shouldn't be checking for the presence of chat here...
80 process-message [ sender>> ] [ chat> ] bi
81 [ join-participant ] [ drop ] if* ;
82 M: part process-message [ sender>> ] [ chat> ] bi [ part-participant ] [ drop ] if* ;
83 M: quit process-message sender>> quit-participant ;
84 M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
85 M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
87 M: rpl-welcome process-message
89 swap nickname>> >>nick
91 chats>> values [ initialize-chat ] each ;
93 M: kick process-message
94 [ [ user>> ] [ chat> ] bi part-participant ]
95 [ dup user>> me? [ unregister-chat ] [ drop ] if ]
98 M: participant-mode process-message ( participant-mode -- )
99 [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
101 M: rpl-names process-message
102 [ nicks>> ] [ chat> ] bi dup ?clear-participants
103 '[ _ join-participant ] each ;
105 M: rpl-names-end process-message chat> t >>clear-participants drop ;
107 ! Client message handling
109 GENERIC: handle-outgoing-irc ( irc-message -- ? )
110 M: irc-end handle-outgoing-irc drop f ;
111 M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
115 : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
117 : (handle-disconnect) ( -- )
118 irc-disconnected irc> in-messages>> mailbox-put
119 (connect-irc) (do-login) ;
121 : handle-disconnect ( error -- ? )
122 [ irc> exceptions>> push ] when*
123 irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
125 GENERIC: handle-input ( line/f -- ? )
126 M: string handle-input string>irc-message handle-reader-message t ;
127 M: f handle-input handle-disconnect ;
129 : (reader-loop) ( -- ? )
130 stream> [ |dispose stream-readln handle-input ] with-destructors ;
132 : reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
133 : writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
137 : in-multiplexer-loop ( -- ? )
138 irc> in-messages>> mailbox-get {
145 : strings>privmsg ( name string -- privmsg )
146 " :" prepend append "PRIVMSG " prepend string>irc-message ;
148 GENERIC: annotate-message ( chat object -- object )
149 M: object annotate-message nip ;
150 M: to-channel annotate-message swap name>> >>channel ;
151 M: to-target annotate-message swap name>> >>target ;
152 M: mode annotate-message swap name>> >>name ;
153 M: string annotate-message [ name>> ] dip strings>privmsg ;
156 [ reader-loop ] "irc-reader-loop" spawn-server
157 [ writer-loop ] "irc-writer-loop" spawn-server
158 [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
161 GENERIC: (attach-chat) ( irc-chat -- )
163 M: irc-chat (attach-chat)
165 [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
166 [ is-ready>> [ initialize-chat ] [ drop ] if ]
169 M: irc-server-chat (attach-chat)
170 irc> [ client<< ] [ chats>> +server-chat+ set-at ] 2bi ;
172 GENERIC: remove-chat ( irc-chat -- )
173 M: irc-nick-chat remove-chat name>> unregister-chat ;
174 M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
176 M: irc-channel-chat remove-chat
177 [ name>> "PART " prepend string>irc-message irc-send ]
178 [ name>> unregister-chat ] bi ;
180 : (speak) ( message irc-chat -- ) swap annotate-message irc-send ;