irc.client: Manage participant list changes, forward quit messages to all channels with participant, mode tests.

extra/irc/client/client-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel tools.test accessors arrays sequences qualified
        io.streams.string io.streams.duplex namespaces threads
        calendar irc.client.private irc.client irc.messages.private
-       concurrency.mailboxes classes ;
+       concurrency.mailboxes classes assocs ;
 EXCLUDE: irc.messages => join ;
 RENAME: join irc.messages => join_
 IN: irc.client.tests
@@ -42,7 +42,7 @@ IN: irc.client.tests
                     ":some.where 001 factorbot :Welcome factorbot"
                   } make-client
                   [ connect-irc ] keep 1 seconds sleep
-                    profile>> nickname>> ] unit-test
+                  profile>> nickname>> ] unit-test
 
 { join_ "#factortest" } [
            { ":factorbot!n=factorbo@some.where JOIN :#factortest"
@@ -52,11 +52,19 @@ IN: irc.client.tests
              ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
              } make-client dup "factorbot" set-nick
              [ connect-irc ] keep 1 seconds sleep
-             join-messages>> 5 seconds mailbox-get-timeout
+             join-messages>> 1 seconds mailbox-get-timeout
              [ class ] [ trailing>> ] bi ] unit-test
-! TODO: user join
+
-! ":somedude!n=user@isp.net JOIN :#factortest"
+{ +join+ "somebody" } [
+           { ":somebody!n=somebody@some.where JOIN :#factortest"
+             } make-client dup "factorbot" set-nick
+             [ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+             [ connect-irc ]
+             [ listeners>> [ "#factortest" ] dip at
+               [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
+             [ action>> ] [ nick>> ] bi
+             ] unit-test
 ! TODO: channel message
-! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
+! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
 ! TODO: direct private message
 ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"

extra/irc/client/client.factor

@@ -36,9 +36,14 @@ SYMBOL: +operator+
 SYMBOL: +voice+
 SYMBOL: +normal+
 
-: participant-mode ( n -- assoc )
+: participant-mode ( n -- mode )
     H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
 
+! participant changed actions
+SYMBOL: +join+
+SYMBOL: +part+
+SYMBOL: +mode+
+
 ! listener objects
 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
 
@@ -55,6 +60,9 @@ SYMBOL: +normal+
 ! Message objects
 ! ======================================
 
+TUPLE: participant-changed nick action ;
+C: <participant-changed> participant-changed
+
 SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
@@ -79,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
 : unregister-listener ( name -- ) irc> listeners>> delete-at ;
 
-: to-listener ( message name -- )
+GENERIC: to-listener ( message obj -- )
+
+M: string to-listener ( message string -- )
     listener> [ +server-listener+ listener> ] unless*
-    [ in-messages>> mailbox-put ] [ drop ] if* ;
+    [ to-listener ] [ drop ] if* ;
+
+M: irc-listener to-listener ( message irc-listener -- )
+    in-messages>> mailbox-put ;
 
 : remove-participant ( nick channel -- )
     listener> [ participants>> delete-at ] [ drop ] if* ;
 
-: remove-participant-from-all ( nick -- )
+: listeners-with-participant ( nick -- seq )
-    irc> listeners>>
+    irc> listeners>> values
-    [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
+    [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
-    assoc-each ;
+    with filter ;
 
-: add-participant ( nick mode channel -- )
+: remove-participant-from-all ( nick -- )
+    dup listeners-with-participant [ delete-at ] with each ;
+
+: add-participant ( mode nick channel -- )
     listener> [ participants>> set-at ] [ 2drop ] if* ;
 
 DEFER: me?
@@ -151,12 +167,31 @@ DEFER: me?
     dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
 
 : broadcast-message-to-listeners ( message -- )
-    irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
+    irc> listeners>> values [ to-listener ] with each ;
+
+GENERIC: handle-participant-change ( irc-message -- )
+
+M: join handle-participant-change ( join -- )
+    [ prefix>> parse-name +join+ <participant-changed> ]
+    [ trailing>> ] bi to-listener ;
+
+M: part handle-participant-change ( part -- )
+    [ prefix>> parse-name +part+ <participant-changed> ]
+    [ channel>> ] bi to-listener ;
+
+M: kick handle-participant-change ( kick -- )
+    [ who>> +part+ <participant-changed> ]
+    [ channel>> ] bi to-listener ;
+
+M: quit handle-participant-change ( quit -- )
+    prefix>> parse-name
+    [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
+    [ to-listener ] with each ;
 
 GENERIC: handle-incoming-irc ( irc-message -- )
 
 M: irc-message handle-incoming-irc ( irc-message -- )
-    +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+    +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 
 M: logged-in handle-incoming-irc ( logged-in -- )
     name>> irc> profile>> (>>nickname) ;
@@ -171,24 +206,32 @@ M: privmsg handle-incoming-irc ( privmsg -- )
     dup irc-message-origin to-listener ;
 
 M: join handle-incoming-irc ( join -- )
-    [ maybe-forward-join ]
+    { [ maybe-forward-join ] ! keep
-    [ dup trailing>> to-listener ]
+      [ dup trailing>> to-listener ]
-    [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+      [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
-    tri ;
+      [ handle-participant-change ]
+    } cleave ;
 
 M: part handle-incoming-irc ( part -- )
-    [ dup channel>> to-listener ] keep
+    [ dup channel>> to-listener ]
-    [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
+    [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
-
+    [ handle-participant-change ]
-M: kick handle-incoming-irc ( kick -- )
-    [ dup channel>>  to-listener ]
-    [ [ who>> ] [ channel>> ] bi remove-participant ] 
-    [ dup who>> me? [ unregister-listener ] [ drop ] if ]
     tri ;
 
+M: kick handle-incoming-irc ( kick -- )
+    { [ dup channel>>  to-listener ]
+      [ [ who>> ] [ channel>> ] bi remove-participant ]
+      [ handle-participant-change ]
+      [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    } cleave ;
+
 M: quit handle-incoming-irc ( quit -- )
-    [ prefix>> parse-name remove-participant-from-all ] keep
+    { [ dup prefix>> parse-name listeners-with-participant
-    call-next-method ;
+        [ to-listener ] with each ]
+      [ handle-participant-change ]
+      [ prefix>> parse-name remove-participant-from-all ]
+      [ ]
+    } cleave call-next-method ;
 
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -234,7 +277,7 @@ DEFER: (connect-irc)
 
 : (handle-disconnect) ( -- )
     irc>
-        [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
+        [ [ irc-disconnected ] dip to-listener ]
         [ dup reconnect-time>> sleep (connect-irc) ]
         [ profile>> nickname>> /LOGIN ]
     tri ;

extra/irc/messages/messages.factor

@@ -34,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string )
     tri 3array " " sjoin ;
 
 GENERIC: irc-message>server-line ( irc-message -- string )
+
 M: irc-message irc-message>server-line ( irc-message -- string )
    drop "not implemented yet" ;