Merge branch 'master' of git://factorcode.org/git/factor

diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
new file mode 100644 (file)
index 0000000..968330e
--- /dev/null
+++ b/extra/irc/client/client-tests.factor
@@ -0,0 +1,79 @@
+USING: kernel tools.test accessors arrays sequences qualified
+       io.streams.string io.streams.duplex namespaces threads
+       calendar irc.client.private ;
+EXCLUDE: irc.client => join ;
+IN: irc.client.tests
+
+! Utilities
+: <test-stream> ( lines -- stream )
+  "\n" join <string-reader> <string-writer> <duplex-stream> ;
+
+: make-client ( lines -- irc-client )
+   "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+   swap [ 2nip <test-stream> f ] curry >>connect ;
+
+: set-nick ( irc-client nickname -- )
+     [ nick>> ] dip >>name drop ;
+
+: with-dummy-client ( quot -- )
+     rot with-variable ; inline
+
+! Parsing tests
+irc-message new
+    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+    "someuser!n=user@some.where" >>prefix
+                       "PRIVMSG" >>command
+               { "#factortest" } >>parameters
+                            "hi" >>trailing
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+  string>irc-message f >>timestamp ] unit-test
+
+privmsg new
+    ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+    "someuser!n=user@some.where" >>prefix
+                       "PRIVMSG" >>command
+               { "#factortest" } >>parameters
+                            "hi" >>trailing
+                   "#factortest" >>name
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+  parse-irc-line f >>timestamp ] unit-test
+
+{ "" } make-client dup "factorbot" set-nick current-irc-client [
+    { t } [ irc-client> nick>> name>> me? ] unit-test
+
+    { "factorbot" } [ irc-client> nick>> name>> ] unit-test
+
+    { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
+    { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+                        parse-irc-line irc-message-origin ] unit-test
+
+    { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+                     parse-irc-line irc-message-origin ] unit-test
+] with-variable
+
+! Test login and nickname set
+{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..."
+                    "NOTICE AUTH :*** Checking ident"
+                    "NOTICE AUTH :*** Found your hostname"
+                    "NOTICE AUTH :*** No identd (auth) response"
+                    ":some.where 001 factorbot :Welcome factorbot"
+                  } make-client
+                  [ connect-irc ] keep 1 seconds sleep
+                    nick>> name>> ] unit-test
+
+! TODO: Channel join messages
+! { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+!   ":ircserver.net MODE #factortest +ns"
+!   ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+!   ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+!   ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+! } make-client dup "factorbot" set-nick
+! TODO: user join
+! ":somedude!n=user@isp.net JOIN :#factortest"
+! TODO: channel message
+! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
+! TODO: direct private message
+! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
\ No newline at end of file

diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 19dca48e1d2285fa213deadf853621888471cca4..5c9469ddd5baae9c2e4fa4a4f22e7a82900fb464 100644 (file)
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -3,7 +3,7 @@
 USING: arrays combinators concurrency.mailboxes concurrency.futures io
        io.encodings.8-bit io.sockets kernel namespaces sequences
        sequences.lib splitting threads calendar classes.tuple
-       ascii assocs accessors destructors ;
+       classes ascii assocs accessors destructors continuations ;
 IN: irc.client
 
 ! ======================================
@@ -26,10 +26,11 @@ TUPLE: nick name channels log ;
 C: <nick> nick
 
 TUPLE: irc-client profile nick stream in-messages out-messages join-messages
-       listeners is-running ;
+       listeners is-running connect ;
 : <irc-client> ( profile -- irc-client )
     f V{ } clone V{ } clone <nick>
-    f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+    f <mailbox> <mailbox> <mailbox> H{ } clone f
+    [ <inet> latin1 <client> ] irc-client boa ;
 
 TUPLE: irc-listener in-messages out-messages ;
 : <irc-listener> ( -- irc-listener )
@@ -79,7 +80,7 @@ TUPLE: unhandled < irc-message ;
     " hostname servername :irc.factor" irc-print ;
 
 : /CONNECT ( server port -- stream )
-    <inet> latin1 <client> drop ;
+    irc-client> connect>> call drop ;
 
 : /JOIN ( channel password -- )
     "JOIN " irc-write
@@ -106,42 +107,6 @@ TUPLE: unhandled < irc-message ;
 : /PONG ( text -- )
     "PONG " irc-write irc-print ;
 
-! ======================================
-! Server message handling
-! ======================================
-
-USE: prettyprint
-
-GENERIC: handle-incoming-irc ( irc-message -- )
-
-M: irc-message handle-incoming-irc ( irc-message -- )
-    . ;
-
-M: logged-in handle-incoming-irc ( logged-in -- )
-    name>> irc-client> nick>> (>>name) ;
-
-M: ping handle-incoming-irc ( ping -- )
-    trailing>> /PONG ;
-
-M: nick-in-use handle-incoming-irc ( nick-in-use -- )
-    name>> "_" append /NICK ;
-
-M: privmsg handle-incoming-irc ( privmsg -- )
-    dup name>> irc-client> listeners>> at
-    [ in-messages>> mailbox-put ] [ drop ] if* ;
-
-M: join handle-incoming-irc ( join -- )
-    irc-client> join-messages>> mailbox-put ;
-
-! ======================================
-! Client message handling
-! ======================================
-
-GENERIC: handle-outgoing-irc ( obj -- )
-
-M: privmsg handle-outgoing-irc ( privmsg -- )
-   [ name>> ] [ trailing>> ] bi /PRIVMSG ;
-
 ! ======================================
 ! Message parsing
 ! ======================================
@@ -188,10 +153,56 @@ M: privmsg handle-outgoing-irc ( privmsg -- )
     } case
     [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
 
+! ======================================
+! Server message handling
+! ======================================
+
+: me? ( string -- ? )
+    irc-client> nick>> name>> = ;
+
+: irc-message-origin ( irc-message -- name )
+    dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
+
+GENERIC: handle-incoming-irc ( irc-message -- )
+
+M: irc-message handle-incoming-irc ( irc-message -- )
+    drop ;
+
+M: logged-in handle-incoming-irc ( logged-in -- )
+    name>> irc-client> nick>> (>>name) ;
+
+M: ping handle-incoming-irc ( ping -- )
+    trailing>> /PONG ;
+
+M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+    name>> "_" append /NICK ;
+
+M: privmsg handle-incoming-irc ( privmsg -- )
+    dup irc-message-origin irc-client> listeners>> at
+    [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: join handle-incoming-irc ( join -- )
+    irc-client> join-messages>> mailbox-put ;
+
+M: irc-end handle-incoming-irc ( irc-end -- )
+    irc-client> listeners>> values [ in-messages>> mailbox-put ] with each ;
+
+! ======================================
+! Client message handling
+! ======================================
+
+GENERIC: handle-outgoing-irc ( obj -- )
+
+M: privmsg handle-outgoing-irc ( privmsg -- )
+   [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
 ! ======================================
 ! Reader/Writer
 ! ======================================
 
+: irc-mailbox-get ( mailbox quot -- )
+    swap 5 seconds  [ mailbox-get-timeout swap call ] 3curry [ drop ] recover ;
+
 : stream-readln-or-close ( stream -- str/f )
     dup stream-readln [ nip ] [ dispose f ] if* ;
 
@@ -209,26 +220,21 @@ M: privmsg handle-outgoing-irc ( privmsg -- )
     ] if* ;
 
 : writer-loop ( -- )
-    irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
+    irc-client> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
 
 ! ======================================
 ! Processing loops
 ! ======================================
 
 : in-multiplexer-loop ( -- )
-    irc-client> in-messages>> mailbox-get handle-incoming-irc ;
-
-! FIXME: Hack, this should be handled better
-GENERIC: add-name ( name obj -- obj )
-M: object add-name nip ;
-M: privmsg add-name swap >>name ;
-    
-: listener-loop ( name -- ) ! FIXME: take different values from the stack?
-    dup irc-client> listeners>> at [
-        out-messages>> mailbox-get add-name
-        irc-client> out-messages>>
-        mailbox-put
-    ] [ drop ] if* ;
+    irc-client> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
+
+: maybe-annotate-with-name ( name obj -- obj )
+    dup privmsg instance? [ swap >>name ] [ nip ] if ;
+
+: listener-loop ( name listener -- )
+    out-messages>> mailbox-get maybe-annotate-with-name
+    irc-client> out-messages>> mailbox-put ;
 
 : spawn-irc-loop ( quot name -- )
     [ [ irc-client> is-running>> ] compose ] dip
@@ -243,17 +249,27 @@ M: privmsg add-name swap >>name ;
 ! Listener join request handling
 ! ======================================
 
-: make-registered-listener ( join -- listener )
-    <irc-listener> swap trailing>>
-    dup [ listener-loop ] curry "listener" spawn-irc-loop
-    [ irc-client> listeners>> set-at ] curry keep ;
+: make-registered-listener ( name -- listener )
+    <irc-listener>
+    [ [ listener-loop ] 2curry "listener" spawn-irc-loop ]
+    [ swap [ irc-client> listeners>> set-at ] curry keep ]
+    2bi ;
 
 : make-join-future ( name -- future )
     [ [ swap trailing>> = ] curry ! compare name with channel name
       irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
-      make-registered-listener ]
+      trailing>> make-registered-listener ]
     curry future ;
 
+: make-user-future ( name -- future )
+    [ make-registered-listener ] curry future ;
+
+: maybe-join ( name password -- ? )
+    over "#" head? [ /JOIN t ] [ 2drop f ] if ;
+
+: make-listener-future ( name channel? -- future )
+    [ make-join-future ] [ make-user-future ] if ;
+
 PRIVATE>
 
 : (connect-irc) ( irc-client -- )
@@ -268,8 +284,6 @@ PRIVATE>
     ] with-variable ;
 
 : listen-to ( irc-client name -- future )
-    swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
-
-! shorcut for privmsgs, etc
-: sender>> ( obj -- string )
-    prefix>> parse-name ;
+    swap current-irc-client [
+        dup f maybe-join make-listener-future
+    ] with-variable ;