factor: trim using lists

[factor.git] / extra / irc / client / internals / internals.factor

diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 5bae054e1836cc13adfd0e28d04787b13ab8d575..03632f41f5892f315765969f22f17f0c2017f212 100644 (file)
--- a/extra/irc/client/internals/internals.factor
+++ b/extra/irc/client/internals/internals.factor
@@ -1,34 +1,55 @@
 ! 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 ;
@@ -52,10 +73,13 @@ 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 ;
@@ -92,9 +116,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
 
 : (handle-disconnect) ( -- )
     irc-disconnected irc> in-messages>> mailbox-put
-    irc> reconnect-time>> sleep
-    (connect-irc)
-    (do-login) ;
+    (connect-irc) (do-login) ;
 
 : handle-disconnect ( error -- ? )
     [ irc> exceptions>> push ] when*
@@ -145,22 +167,14 @@ M: irc-chat (attach-chat)
     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 ;