! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays concurrency.mailboxes continuations destructors
-hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
-strings words.symbol irc.messages.base irc.client.participants fry threads
-combinators irc.messages.parser ;
-EXCLUDE: sequences => join ;
+USING: accessors arrays assocs combinators concurrency.mailboxes
+continuations destructors io irc.client.base irc.client.chats
+irc.client.participants irc.messages irc.messages.base
+irc.messages.parser kernel math sequences strings threads
+words.symbol ;
IN: irc.client.internals
+: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
+ dup 0 > [
+ [ drop call( host port -- stream ) ]
+ [ drop 15 sleep 1 - do-connect ]
+ recover
+ ] [ 4drop f ] if ;
+
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
+: /PASS ( password -- ) "PASS " prepend irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " prepend " hostname servername :irc.factor" append irc-print ;
: /CONNECT ( server port -- stream )
- irc> connect>> call( host port -- stream local ) drop ;
+ irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
: /JOIN ( channel password -- )
- [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+ [ " :" glue ] when* "JOIN " prepend irc-print ;
+
+: try-connect ( -- stream/f )
+ irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
+
+: (terminate-irc) ( -- )
+ irc> dup is-running>> [
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
+ ] [ drop ] if ;
: (connect-irc) ( -- )
- irc> {
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
- [ (>>stream) ]
- [ t swap (>>is-running) ]
- [ in-messages>> [ irc-connected ] dip mailbox-put ]
- } cleave ;
+ try-connect [
+ [ irc> ] dip >>stream t >>is-running
+ in-messages>> [ irc-connected ] dip mailbox-put
+ ] [ (terminate-irc) ] if* ;
-: (do-login) ( -- ) irc> nick>> /LOGIN ;
+: (do-login) ( -- )
+ irc>
+ [ profile>> password>> [ /PASS ] when* ]
+ [ nick>> /LOGIN ]
+ bi ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
! Server message handling
-GENERIC: forward-message ( irc-message -- )
-M: irc-message forward-message +server-chat+ chat-put ;
-M: to-one-chat forward-message dup chat> chat-put ;
-M: to-all-chats forward-message chats> chat-put ;
-M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
+GENERIC: message-forwards ( irc-message -- seq )
+M: irc-message message-forwards drop +server-chat+ ;
+M: to-one-chat message-forwards chat> ;
+M: to-all-chats message-forwards drop chats> ;
+M: to-many-chats message-forwards sender>> participant-chats ;
GENERIC: process-message ( irc-message -- )
-M: object process-message drop ;
+M: object process-message drop ;
M: ping process-message trailing>> /PONG ;
-M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
-M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
+! FIXME: it shouldn't be checking for the presence of chat here...
+M: irc.messages:join
+ process-message [ sender>> ] [ chat> ] bi
+ [ join-participant ] [ drop ] if* ;
+M: part process-message [ sender>> ] [ chat> ] bi [ part-participant ] [ drop ] if* ;
M: quit process-message sender>> quit-participant ;
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
- irc> in-messages>> irc-disconnected swap mailbox-put
- irc> reconnect-time>> sleep
- (connect-irc)
- (do-login) ;
+ irc-disconnected irc> in-messages>> mailbox-put
+ (connect-irc) (do-login) ;
: handle-disconnect ( error -- ? )
[ irc> exceptions>> push ] when*
! Processing loops
: in-multiplexer-loop ( -- ? )
- irc> in-messages>> mailbox-get
- [ process-message ] [ forward-message ] [ irc-end? not ] tri ;
+ irc> in-messages>> mailbox-get {
+ [ message-forwards ]
+ [ process-message ]
+ [ swap chat-put ]
+ [ irc-end? not ]
+ } cleave ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
2bi ;
M: irc-server-chat (attach-chat)
- irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
+ irc> [ client<< ] [ chats>> +server-chat+ set-at ] 2bi ;
GENERIC: remove-chat ( irc-chat -- )
M: irc-nick-chat remove-chat name>> unregister-chat ;
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
M: irc-channel-chat remove-chat
- [ part new annotate-message irc-send ]
+ [ name>> "PART " prepend string>irc-message irc-send ]
[ name>> unregister-chat ] bi ;
-: (terminate-irc) ( -- )
- irc> dup is-running>> [
- f >>is-running
- [ stream>> dispose ] keep
- [ in-messages>> ] [ out-messages>> ] bi 2array
- [ irc-end swap mailbox-put ] each
- ] [ drop ] if ;
-
-: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
\ No newline at end of file
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;