From 77e6f10ac3c3079f16c24e5d8fec8ac03610149e Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 18 Jul 2008 13:09:04 -0300 Subject: [PATCH 01/12] irc.client: Improvments to thread management. --- extra/irc/client/client.factor | 39 ++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 405d8ed9ed..bda00fcb95 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -63,6 +63,7 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed +SINGLETON: irc-listener-end ! send to a listener to top its execution 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 @@ -85,7 +86,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: unregister-listener ( name -- ) irc> listeners>> delete-at ; + +: maybe-mailbox-get ( mailbox quot -- ) + [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -93,6 +96,12 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +: unregister-listener ( name -- ) + irc> listeners>> + [ at [ irc-listener-end ] dip to-listener ] + [ delete-at ] + 2bi ; + M: irc-listener to-listener ( message irc-listener -- ) in-messages>> mailbox-put ; @@ -291,18 +300,18 @@ DEFER: (connect-irc) ] if* ] with-destructors ; -: reader-loop ( -- ) - [ (reader-loop) ] [ handle-disconnect ] recover ; +: reader-loop ( -- ? ) + [ (reader-loop) ] [ handle-disconnect ] recover t ; -: writer-loop ( -- ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; +: writer-loop ( -- ? ) + irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; ! ====================================== ! Processing loops ! ====================================== -: in-multiplexer-loop ( -- ) - irc> in-messages>> mailbox-get handle-incoming-irc ; +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -314,12 +323,15 @@ DEFER: (connect-irc) [ nip ] } cond ; -: listener-loop ( name listener -- ) - out-messages>> mailbox-get maybe-annotate-with-name - irc> out-messages>> mailbox-put ; +: listener-loop ( name -- ? ) + dup listener> [ + out-messages>> [ maybe-annotate-with-name + irc> out-messages>> mailbox-put ] with + maybe-mailbox-get t + ] [ drop f ] if* ; : spawn-irc-loop ( quot name -- ) - [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip + [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -332,9 +344,8 @@ DEFER: (connect-irc) ! ====================================== : set+run-listener ( name irc-listener -- ) - [ '[ , , listener-loop ] "listener" spawn-irc-loop ] - [ swap irc> listeners>> set-at ] - 2bi ; + over irc> listeners>> set-at + '[ , listener-loop ] "listener" spawn-irc-loop ; GENERIC: (add-listener) ( irc-listener -- ) From 55d7cb31689114c665bbdf8a79894004068717d2 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 18 Jul 2008 16:36:40 -0300 Subject: [PATCH 02/12] irc.client: Two more tests --- extra/irc/client/client-tests.factor | 24 ++++++++++++++++++++---- extra/irc/client/client.factor | 5 +++-- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 100724ea58..641cb57562 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -64,7 +64,23 @@ IN: irc.client.tests [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri [ action>> ] [ nick>> ] bi ] unit-test -! TODO: channel message -! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" -! TODO: direct private message -! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file + +{ privmsg "#factortest" "hello" } [ + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] tri + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +{ privmsg "factorbot" "hello" } [ + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" + } make-client dup "factorbot" set-nick + [ listeners>> [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] tri + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index bda00fcb95..f4ef2a6d57 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -51,7 +51,8 @@ SYMBOL: +mode+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone + irc-channel-listener boa ; : ( name -- irc-nick-listener ) [ ] dip irc-nick-listener boa ; @@ -63,7 +64,7 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed -SINGLETON: irc-listener-end ! send to a listener to top its execution +SINGLETON: irc-listener-end ! send to a listener to stop its execution 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 From b855b098a79fb62d6dbdc0f12a8b7c153baabb29 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 26 Jul 2008 15:32:16 -0300 Subject: [PATCH 03/12] irc.client: Fixes, tests, etc --- extra/irc/client/client-tests.factor | 115 +++++++++++++---------- extra/irc/client/client.factor | 46 ++++----- extra/irc/messages/messages-tests.factor | 10 ++ extra/irc/messages/messages.factor | 68 ++++++++++---- 4 files changed, 145 insertions(+), 94 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 641cb57562..e4b7cd20ed 100644 --- a/extra/irc/client/client-tests.factor +++ b/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 assocs ; + concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -11,16 +11,16 @@ IN: irc.client.tests "\n" join ; : make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; + swap profile>> (>>nickname) ; -: with-dummy-client ( quot -- ) - rot with-variable ; inline +: with-dummy-client ( irc-client quot -- ) + [ current-irc-client ] dip with-variable ; inline -{ "" } make-client dup "factorbot" set-nick current-irc-client [ +{ "" } make-client dup "factorbot" set-nick [ { t } [ irc> profile>> nickname>> me? ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test @@ -32,55 +32,72 @@ IN: irc.client.tests { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" parse-irc-line irc-message-origin ] unit-test -] with-variable +] with-dummy-client ! 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 - profile>> nickname>> ] unit-test +{ "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 ] + [ drop 1 seconds sleep ] + [ profile>> nickname>> ] + [ terminate-irc ] + } cleave ] unit-test { join_ "#factortest" } [ - { ":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 - [ connect-irc ] keep 1 seconds sleep - join-messages>> 1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi ] unit-test + { ":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 + { [ "factorbot" set-nick ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ join-messages>> 1 seconds mailbox-get-timeout ] + [ terminate-irc ] + } cleave + [ class ] [ trailing>> ] bi ] unit-test { +join+ "somebody" } [ - { ":somebody!n=somebody@some.where JOIN :#factortest" - } make-client dup "factorbot" set-nick - [ listeners>> [ "#factortest" [ ] 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 + { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave + [ action>> ] [ nick>> ] bi + ] unit-test { privmsg "#factortest" "hello" } [ - { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" - } make-client dup "factorbot" set-nick - [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message ] bi ] tri - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test { privmsg "factorbot" "hello" } [ - { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" - } make-client dup "factorbot" set-nick - [ listeners>> [ "somedude" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "somedude" ] dip at - [ read-message drop ] [ read-message ] bi ] tri - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test \ No newline at end of file + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index f4ef2a6d57..888332dc1f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,8 +12,6 @@ IN: irc.client ! Setup and running objects ! ====================================== -SYMBOL: current-irc-client - : irc-port 6667 ; ! Default irc port TUPLE: irc-profile server port nickname password ; @@ -71,13 +69,17 @@ SINGLETON: irc-connected ! sent when connection is established UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri ; + [ is-running>> ] keep and [ + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] + [ stream>> dispose ] + tri + ] when* ; [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: maybe-mailbox-get ( mailbox quot -- ) +: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -240,8 +242,8 @@ M: quit handle-incoming-irc ( quit -- ) [ to-listener ] with each ] [ handle-participant-change ] [ prefix>> parse-name remove-participant-from-all ] - [ ] - } cleave call-next-method ; + [ call-next-method ] + } cleave ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -266,12 +268,6 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: irc-message handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - -M: part handle-outgoing-irc ( part -- ) - [ channel>> ] [ trailing>> "" or ] bi /PART ; - ! ====================================== ! Reader/Writer ! ====================================== @@ -283,7 +279,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip to-listener ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -318,10 +314,9 @@ DEFER: (connect-irc) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) - { - { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] + { { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name -- ? ) @@ -331,7 +326,7 @@ DEFER: (connect-irc) maybe-mailbox-get t ] [ drop f ] if* ; -: spawn-irc-loop ( quot name -- ) +: spawn-irc-loop ( quot: ( -- ? ) name -- ) [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; @@ -383,16 +378,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) t >>is-running in-messages>> [ irc-connected ] dip mailbox-put ; -: with-irc-client ( irc-client quot -- ) +: with-irc-client ( irc-client quot: ( -- ) -- ) [ current-irc-client ] dip with-variable ; inline PRIVATE> : connect-irc ( irc-client -- ) - dup [ - [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi - spawn-irc - ] with-irc-client ; + [ irc> + [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi + spawn-irc ] with-irc-client ; : add-listener ( irc-listener irc-client -- ) swap '[ , (add-listener) ] with-irc-client ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 1bd6088f82..876841abb7 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -35,3 +35,13 @@ join new [ ":someuser!n=user@some.where JOIN :#factortest" parse-irc-line f >>timestamp ] unit-test +mode new + ":ircserver.net MODE #factortest +ns" >>line + "ircserver.net" >>prefix + "MODE" >>command + { "#factortest" "+ns" } >>parameters + "#factortest" >>channel + "+ns" >>mode +1array +[ ":ircserver.net MODE #factortest +ns" + parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 5813c72723..a5f82a5ae1 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order ; + arrays classes.tuple math.order quotations ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -17,7 +17,7 @@ TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name channel mode ; +TUPLE: mode < irc-message channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; @@ -25,12 +25,42 @@ TUPLE: unhandled < irc-message ; irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; +> ; +M: ping irc-command-string ( ping -- string ) drop "PING" ; +M: join irc-command-string ( join -- string ) drop "JOIN" ; +M: part irc-command-string ( part -- string ) drop "PART" ; +M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; +M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; +M: mode irc-command-string ( mode -- string ) drop "MODE" ; +M: kick irc-command-string ( kick -- string ) drop "KICK" ; + +GENERIC: irc-command-parameters ( irc-message -- seq ) + +M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; +M: ping irc-command-parameters ( ping -- seq ) drop { } ; +M: join irc-command-parameters ( join -- seq ) drop { } ; +M: part irc-command-parameters ( part -- seq ) name>> 1array ; +M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; +M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; +M: kick irc-command-parameters ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode irc-command-parameters ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; + +PRIVATE> + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] + [ irc-command-string ] + [ irc-command-parameters " " sjoin ] + [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) @@ -73,19 +103,19 @@ PRIVATE> : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ \ ping ] } - { "NOTICE" [ \ notice ] } - { "001" [ \ logged-in ] } - { "433" [ \ nick-in-use ] } - { "353" [ \ names-reply ] } - { "JOIN" [ \ join ] } - { "PART" [ \ part ] } - { "PRIVMSG" [ \ privmsg ] } - { "QUIT" [ \ quit ] } - { "MODE" [ \ mode ] } - { "KICK" [ \ kick ] } - [ drop \ unhandled ] + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; - + [ all-slots over [ length ] bi@ min head >quotation ] keep + '[ @ , boa nip ] call ; From 09c1fc390ba64b9a097f4e7ae93c88d54e45d4a5 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sun, 27 Jul 2008 20:15:38 -0400 Subject: [PATCH 04/12] Added server listener --- extra/irc/ui/ui.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 9b8d1a4d11..1520970f46 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -187,8 +187,9 @@ M: irc-tab ungraft* : ui-connect ( profile -- ui-window ) ui-window new over >>client swap [ connect-irc ] + [ [ ] dip add-listener ] [ listeners>> +server-listener+ swap at over - "Server" associate >>tabs ] bi ; + "Server" associate >>tabs ] tri ; : server-open ( server port nick password channels -- ) [ ui-connect [ irc-window ] keep ] dip From b30f22f125c3e4c949ad8cb4fd98b4cf8e881229 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 27 Jul 2008 21:19:28 -0300 Subject: [PATCH 05/12] irc.client: Fix removing of participant on quit --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 888332dc1f..42682154cd 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -117,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- ) with filter ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ delete-at ] with each ; + dup listeners-with-participant [ participants>> delete-at ] with each ; : add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; From 9f60dd601bfe417b153fdb68076abf69396da5be Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Mon, 28 Jul 2008 21:02:05 -0400 Subject: [PATCH 06/12] irc.ui: Fixed a few bugs --- extra/irc/ui/ui.factor | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 1520970f46..c91d797f25 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -6,9 +6,11 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels - io io.styles namespaces calendar calendar.format models + io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load ; + irc.ui.commandparser irc.ui.load qualified ; + +RENAME: join sequences => sjoin IN: irc.ui @@ -71,14 +73,21 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +: full-mode ( message -- mode ) + parameters>> rest " " sjoin ; + M: mode write-irc "* " blue write-color - [ name>> write ] keep + [ prefix>> parse-name write ] keep " has applied mode " blue write-color - [ mode>> write ] keep + [ full-mode write ] keep " to " blue write-color channel>> write ; +M: unhandled write-irc + "UNHANDLED: " write + line>> blue write-color ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -88,11 +97,17 @@ M: irc-disconnected write-irc M: irc-connected write-irc drop "* Connected" green write-color ; +M: irc-listener-end write-irc + drop ; + M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE +: time-happened ( irc-message -- timestamp ) + [ timestamp>> ] [ 2drop now ] recover ; + : print-irc ( irc-message -- ) - [ timestamp>> timestamp>hms write " " write ] + [ time-happened timestamp>hms write " " write ] [ write-irc nl ] bi ; : send-message ( message -- ) From a0782fb5991b0348ee11b2b7c51782aa55c42013 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 29 Jul 2008 00:48:25 -0300 Subject: [PATCH 07/12] irc.client: Don't forward quit messages to the server listener, tests for participant lists --- extra/irc/client/client-tests.factor | 58 ++++++++++++++++++++++++++++ extra/irc/client/client.factor | 15 ++++--- 2 files changed, 65 insertions(+), 8 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index e4b7cd20ed..166619f6cb 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -101,3 +101,61 @@ IN: irc.client.tests } cleave [ class ] [ name>> ] [ trailing>> ] tri ] unit-test + +! Participants lists tests +{ H{ { "somedude" f } } } [ + { ":somedude!n=user@isp.net JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude!n=user@isp.net PART #factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" f } } } [ + { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" f } + { "somedude" f } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 42682154cd..89286f6303 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -218,7 +218,7 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - { [ maybe-forward-join ] ! keep + { [ maybe-forward-join ] [ dup trailing>> to-listener ] [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] @@ -231,19 +231,18 @@ M: part handle-incoming-irc ( part -- ) tri ; M: kick handle-incoming-irc ( kick -- ) - { [ dup channel>> to-listener ] + { [ 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 -- ) - { [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ handle-participant-change ] - [ prefix>> parse-name remove-participant-from-all ] - [ call-next-method ] - } cleave ; + [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ prefix>> parse-name remove-participant-from-all ] + [ handle-participant-change ] + tri ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; From 5fd42c4e543ea6ffa7a42ae2be35afef9fa73854 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 29 Jul 2008 00:52:42 -0300 Subject: [PATCH 08/12] irc.client: For tests that need to wait, wait 0.1 seconds instead of 1 second. --- extra/irc/client/client-tests.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 166619f6cb..08307a2d5c 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -43,7 +43,7 @@ IN: irc.client.tests ":some.where 001 factorbot :Welcome factorbot" } make-client { [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ profile>> nickname>> ] [ terminate-irc ] } cleave ] unit-test @@ -57,8 +57,8 @@ IN: irc.client.tests } make-client { [ "factorbot" set-nick ] [ connect-irc ] - [ drop 1 seconds sleep ] - [ join-messages>> 1 seconds mailbox-get-timeout ] + [ drop 0.1 seconds sleep ] + [ join-messages>> 0.1 seconds mailbox-get-timeout ] [ terminate-irc ] } cleave [ class ] [ trailing>> ] bi ] unit-test @@ -109,7 +109,7 @@ IN: irc.client.tests [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -124,7 +124,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -139,7 +139,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave @@ -154,7 +154,7 @@ IN: irc.client.tests { "somedude" f } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] - [ drop 1 seconds sleep ] + [ drop 0.1 seconds sleep ] [ listeners>> [ "#factortest" ] dip at participants>> ] [ terminate-irc ] } cleave From fcc1ee9cdd68cc37ac4df359fa4919422d0e8374 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 31 Jul 2008 21:35:09 -0300 Subject: [PATCH 09/12] irc.client: nick command parsing, namelist notification after join, tests. Make +normal+ the default state for participants, not 'f' --- extra/irc/client/client-tests.factor | 34 +++++++++++++++++------- extra/irc/client/client.factor | 8 +++--- extra/irc/messages/messages-tests.factor | 12 ++++++++- extra/irc/messages/messages.factor | 4 +++ 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 08307a2d5c..e021ff4ff4 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -103,7 +103,7 @@ IN: irc.client.tests ] unit-test ! Participants lists tests -{ H{ { "somedude" f } } } [ +{ H{ { "somedude" +normal+ } } } [ { ":somedude!n=user@isp.net JOIN :#factortest" } make-client { [ "factorbot" set-nick ] [ listeners>> @@ -115,13 +115,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude!n=user@isp.net PART #factortest" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -130,13 +130,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude!n=user@isp.net QUIT" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -145,13 +145,13 @@ IN: irc.client.tests } cleave ] unit-test -{ H{ { "somedude2" f } } } [ +{ H{ { "somedude2" +normal+ } } } [ { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client { [ "factorbot" set-nick ] [ listeners>> [ "#factortest" [ - H{ { "somedude2" f } - { "somedude" f } } clone >>participants ] keep + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep ] dip set-at ] [ connect-irc ] [ drop 0.1 seconds sleep ] @@ -159,3 +159,17 @@ IN: irc.client.tests [ terminate-irc ] } cleave ] unit-test + +! Namelist notification +{ T{ participant-changed f f f } } [ + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 89286f6303..813de0f57c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -220,7 +220,7 @@ M: privmsg handle-incoming-irc ( privmsg -- ) M: join handle-incoming-irc ( join -- ) { [ maybe-forward-join ] [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] } cleave ; @@ -252,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- ) [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi - [ (>>participants) ] [ drop ] if* ; + [ names-reply>participants ] [ channel>> listener> ] bi [ + [ (>>participants) ] + [ [ f f ] dip name>> to-listener ] bi + ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 876841abb7..7ee0f41ab0 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -40,8 +40,18 @@ mode new "ircserver.net" >>prefix "MODE" >>command { "#factortest" "+ns" } >>parameters - "#factortest" >>channel + "#factortest" >>channel "+ns" >>mode 1array [ ":ircserver.net MODE #factortest +ns" + parse-irc-line f >>timestamp ] unit-test + +nick new + ":someuser!n=user@some.where NICK :someuser2" >>line + "someuser!n=user@some.where" >>prefix + "NICK" >>command + { } >>parameters + "someuser2" >>trailing +1array +[ ":someuser!n=user@some.where NICK :someuser2" parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index a5f82a5ae1..3b9cf0af2c 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -12,6 +12,7 @@ TUPLE: ping < irc-message ; TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; +TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; @@ -34,6 +35,7 @@ M: ping irc-command-string ( ping -- string ) drop "PING" ; M: join irc-command-string ( join -- string ) drop "JOIN" ; M: part irc-command-string ( part -- string ) drop "PART" ; M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: nick irc-command-string ( nick -- string ) drop "NICK" ; M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; M: mode irc-command-string ( mode -- string ) drop "MODE" ; @@ -46,6 +48,7 @@ M: ping irc-command-parameters ( ping -- seq ) drop { } ; M: join irc-command-parameters ( join -- seq ) drop { } ; M: part irc-command-parameters ( part -- seq ) name>> 1array ; M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: nick irc-command-parameters ( nick -- seq ) drop { } ; M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; M: kick irc-command-parameters ( kick -- seq ) @@ -110,6 +113,7 @@ PRIVATE> { "353" [ names-reply ] } { "JOIN" [ join ] } { "PART" [ part ] } + { "NICK" [ nick ] } { "PRIVMSG" [ privmsg ] } { "QUIT" [ quit ] } { "MODE" [ mode ] } From 804a76afc8be49b405402e78f90ecd5c698fdc50 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Thu, 31 Jul 2008 21:36:16 -0400 Subject: [PATCH 10/12] irc.ui: Userlists no longer use list gadgets --- extra/irc/ui/ui.factor | 36 +++++++++++++++--------------------- 1 file changed, 15 insertions(+), 21 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index c91d797f25..0ceeed1d35 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,7 +5,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private irc.ui.commandparser irc.ui.load qualified ; @@ -20,7 +20,7 @@ SYMBOL: client TUPLE: ui-window client tabs ; -TUPLE: irc-tab < frame listener client listmodel ; +TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; @@ -116,16 +116,15 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( assoc val -- alist ) - [ >alist ] dip - '[ second , = ] filter ; +: filter-participants ( pack alist val color -- ) + '[ , = [