From: Bruno Deferrari Date: Thu, 9 Apr 2009 03:04:42 +0000 (-0300) Subject: irc.client: Big refactor X-Git-Tag: 0.94~2141^2~4 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=85d595d8b68635cf8ba884847db92aab6a444a21 irc.client: Big refactor --- diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor new file mode 100644 index 0000000000..f54e18ac4b --- /dev/null +++ b/extra/irc/client/base/base.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs concurrency.mailboxes io kernel namespaces +strings words.symbol irc.client.chats irc.messages ; +EXCLUDE: sequences => join ; +IN: irc.client.base + +SYMBOL: current-irc-client + +: irc> ( -- irc-client ) current-irc-client get ; +: stream> ( -- stream ) irc> stream>> ; +: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; +: chats> ( -- seq ) irc> chats>> values ; +: me? ( string -- ? ) irc> nick>> = ; + +: with-irc ( irc-client quot: ( -- ) -- ) + \ current-irc-client swap with-variable ; inline + +UNION: to-target privmsg notice ; +UNION: to-channel join part topic kick rpl-channel-modes + rpl-notopic rpl-topic rpl-names rpl-names-end ; +UNION: to-one-chat to-target to-channel mode ; +UNION: to-many-chats nick quit ; +UNION: to-all-chats irc-end irc-disconnected irc-connected ; +PREDICATE: to-me < to-target target>> me? ; + +GENERIC: chat-name ( irc-message -- name ) +M: mode chat-name name>> ; +M: to-target chat-name target>> ; +M: to-me chat-name sender>> ; +M: to-channel chat-name channel>> ; + +GENERIC: chat> ( obj -- chat/f ) +M: string chat> irc> chats>> at ; +M: symbol chat> irc> chats>> at ; +M: to-one-chat chat> chat-name +server-chat+ or chat> ; diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor new file mode 100644 index 0000000000..66fd1a207d --- /dev/null +++ b/extra/irc/client/chats/chats-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax quotations kernel ; +IN: irc.client.chats + +HELP: irc-client "IRC Client object" ; + +HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; + +HELP: irc-channel-chat "Chat for irc channels" ; + +HELP: irc-nick-chat "Chat for irc users" ; + +HELP: irc-profile "IRC Client profile object" ; + +HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ; + +HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ; + +HELP: irc-disconnected "Message sent to notify chats that connection was lost." ; + +HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ; diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor new file mode 100644 index 0000000000..7910afb22a --- /dev/null +++ b/extra/irc/client/chats/chats.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit +destructors arrays sequences ; +IN: irc.client.chats + +CONSTANT: irc-port 6667 ! Default irc port + +TUPLE: irc-chat in-messages client ; +TUPLE: irc-server-chat < irc-chat ; +TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ; +TUPLE: irc-nick-chat < irc-chat name ; +SYMBOL: +server-chat+ + +: ( -- irc-server-chat ) + irc-server-chat new + >>in-messages ; + +: ( name -- irc-channel-chat ) + irc-channel-chat new + swap >>name + >>in-messages + f >>password + H{ } clone >>participants + t >>clear-participants ; + +: ( name -- irc-nick-chat ) + irc-nick-chat new + swap >>name + >>in-messages ; + +TUPLE: irc-profile server port nickname password ; +C: irc-profile + +TUPLE: irc-client profile stream in-messages out-messages + chats is-running nick connect reconnect-time is-ready + exceptions ; + +: ( profile -- irc-client ) + dup nickname>> irc-client new + swap >>nick + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + 15 seconds >>reconnect-time + V{ } clone >>exceptions + [ latin1 ] >>connect ; + +SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index d95d2bc2c6..ad674cb0c1 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,16 +1,7 @@ -USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; +USING: help.markup help.syntax quotations kernel +irc.messages irc.messages.base irc.messages.parser irc.client.chats ; IN: irc.client -HELP: irc-client "IRC Client object" ; - -HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; - -HELP: irc-channel-chat "Chat for irc channels" ; - -HELP: irc-nick-chat "Chat for irc users" ; - -HELP: irc-profile "IRC Client profile object" ; - HELP: connect-irc "Connecting to an irc server" { $values { "irc-client" "an irc client object" } } { $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; @@ -69,6 +60,7 @@ ARTICLE: "irc.client" "IRC Client" { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } } + { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table @@ -79,7 +71,7 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Example:" } { $code - "USING: irc.client ;" + "USING: irc.client irc.client.chats ;" "SYMBOL: bot" "SYMBOL: mychannel" "! Create the profile and client objects" @@ -91,7 +83,7 @@ ARTICLE: "irc.client" "IRC Client" "! Register and start chat (this joins the channel)" "mychannel get bot get attach-chat" "! Send a message to the channel" - "\"what's up?\" mychannel get speak" + "\"Hello World!\" mychannel get speak" "! Read a message from the channel" "mychannel get hear" } diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor deleted file mode 100644 index 9e96cc249b..0000000000 --- a/extra/irc/client/client-tests.factor +++ /dev/null @@ -1,230 +0,0 @@ -USING: kernel tools.test accessors arrays sequences - io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages - concurrency.mailboxes classes assocs combinators irc.messages.parser ; -EXCLUDE: irc.messages => join ; -RENAME: join irc.messages => join_ -IN: irc.client.tests - -! Streams for testing -TUPLE: mb-writer lines last-line disposed ; -TUPLE: mb-reader lines disposed ; -: ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ; -: ( -- mb-reader ) f mb-reader boa ; -: push-line ( line test-reader-stream -- ) lines>> mailbox-put ; -: ( -- stream ) ; -M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ; -M: mb-writer stream-flush ( mb-writer -- ) drop ; -M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ; -M: mb-writer stream-nl ( mb-writer -- ) - [ [ last-line>> concat ] [ lines>> ] bi push ] keep - V{ } clone >>last-line drop ; -M: mb-reader dispose f swap push-line ; -M: mb-writer dispose drop ; - -: spawn-client ( -- irc-client ) - "someserver" irc-port "factorbot" f - - t >>is-ready - t >>is-running - >>stream - dup [ spawn-irc yield ] with-irc-client ; - -! to be used inside with-irc-client quotations -: %add-named-chat ( chat -- ) irc> attach-chat ; -: %push-line ( line -- ) irc> stream>> in>> push-line yield ; -: %join ( channel -- ) irc> attach-chat ; -: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; - -: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) - [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; - -: with-irc ( quot: ( -- ) -- ) - [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TESTS -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { t } [ irc> nick>> me? ] unit-test - - { "factorbot" } [ irc> nick>> ] unit-test - -! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - - { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message forward-name ] unit-test - - { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - string>irc-message forward-name ] unit-test -] with-irc - -{ privmsg "#channel" "hello" } [ - "#channel" "hello" strings>privmsg - [ class ] [ target>> ] [ trailing>> ] tri -] unit-test - -! Test login and nickname set -[ { "factorbot2" } [ - ":some.where 001 factorbot2 :Welcome factorbot2" %push-line - irc> nick>> - ] unit-test -] with-irc - -! Test connect -{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ - "someserver" irc-port "factorbot" f - [ 2drop t ] >>connect - [ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri -] unit-test - -! Test join -[ { "JOIN #factortest" } [ - "#factortest" %join %pop-output-line - ] unit-test -] with-irc - -[ { join_ "#factortest" } [ - "#factortest" [ %add-named-chat ] keep - { ":factorbot!n=factorbo@some.where JOIN :#factortest" - ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." - ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } [ %push-line ] each - in-messages>> 0.1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi - ] unit-test -] with-irc - -[ { T{ participant-changed f "somebody" +join+ } } [ - "#factortest" [ %add-named-chat ] keep - ":somebody!n=somebody@some.where JOIN :#factortest" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { privmsg "#factortest" "hello" } [ - "#factortest" [ %add-named-chat ] keep - ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line - [ privmsg? ] read-matching-message - [ class ] [ target>> ] [ trailing>> ] tri - ] unit-test -] with-irc - -[ { privmsg "factorbot" "hello" } [ - "ircuser" [ %add-named-chat ] keep - ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line - [ privmsg? ] read-matching-message - [ class ] [ target>> ] [ trailing>> ] tri - ] unit-test -] with-irc - -[ { mode } [ - "#factortest" [ %add-named-chat ] keep - ":ircserver.net MODE #factortest +ns" %push-line - [ mode? ] read-matching-message class - ] unit-test -] with-irc - -! Participant lists tests -[ { H{ { "ircuser" +normal+ } } } [ - "#factortest" [ %add-named-chat ] keep - ":ircuser!n=user@isp.net JOIN :#factortest" %push-line - participants>> - ] unit-test -] with-irc - -[ { H{ { "ircuser2" +normal+ } } } [ - "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user@isp.net PART #factortest" %push-line - participants>> - ] unit-test -] with-irc - -[ { H{ { "ircuser2" +normal+ } } } [ - "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user@isp.net QUIT" %push-line - participants>> - ] unit-test -] with-irc - -[ { H{ { "ircuser2" +normal+ } } } [ - "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line - participants>> - ] unit-test -] with-irc - -[ { H{ { "ircuser2" +normal+ } } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line - participants>> - ] unit-test -] with-irc - -[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - participants>> - ] unit-test -] with-irc - -! Namelist change notification -[ { T{ participant-changed f f f f } } [ - "#factortest" [ %add-named-chat ] keep - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { T{ participant-changed f "ircuser" +part+ f } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user@isp.net QUIT" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -! Mode change -[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [ - "#factortest" [ %add-named-chat ] keep - ":ircserver.net MODE #factortest +o ircuser" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -! Send privmsg -[ { "PRIVMSG #factortest :hello" } [ - "#factortest" [ %add-named-chat ] keep - "hello" swap speak %pop-output-line - ] unit-test -] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index f2d671e30d..ae48d3ac4e 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -1,380 +1,15 @@ ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar - accessors destructors namespaces io assocs arrays fry - continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser ; -RENAME: join sequences => sjoin -EXCLUDE: sequences => join ; +USING: accessors concurrency.mailboxes destructors +irc.client.base irc.client.chats irc.client.internals kernel +namespaces sequences ; IN: irc.client -! ====================================== -! Setup and running objects -! ====================================== - -CONSTANT: irc-port 6667 ! Default irc port - -TUPLE: irc-profile server port nickname password ; -C: irc-profile - -TUPLE: irc-client profile stream in-messages out-messages - chats is-running nick connect reconnect-time is-ready ; - -: ( profile -- irc-client ) - irc-client new - swap >>profile - >>in-messages - >>out-messages - H{ } clone >>chats - dup profile>> nickname>> >>nick - [ latin1 ] >>connect - 15 seconds >>reconnect-time ; - -TUPLE: irc-chat in-messages client ; -TUPLE: irc-server-chat < irc-chat ; -TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ; -TUPLE: irc-nick-chat < irc-chat name ; -SYMBOL: +server-chat+ - -! participant modes -SYMBOL: +operator+ -SYMBOL: +voice+ -SYMBOL: +normal+ - -: participant-mode ( n -- mode ) - H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; - -! participant changed actions -SYMBOL: +join+ -SYMBOL: +part+ -SYMBOL: +mode+ -SYMBOL: +nick+ - -! chat objects -: ( -- irc-server-chat ) - f irc-server-chat boa ; - -: ( name -- irc-channel-chat ) - [ f ] dip f 60 seconds H{ } clone t - irc-channel-chat boa ; - -: ( name -- irc-nick-chat ) - [ f ] dip irc-nick-chat boa ; - -! ====================================== -! Message objects -! ====================================== - -TUPLE: participant-changed nick action parameter ; -C: participant-changed - -SINGLETON: irc-chat-end ! sent to a chat 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 - -: terminate-irc ( irc-client -- ) - dup is-running>> [ - f >>is-running - [ stream>> dispose ] keep - [ in-messages>> ] [ out-messages>> ] bi 2array - [ irc-end swap mailbox-put ] each - ] [ drop ] if ; - - ( -- irc-client ) current-irc-client get ; -: irc-write ( s -- ) irc> stream>> stream-write ; -: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ; -: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; -: chat> ( name -- chat/f ) irc> chats>> at ; -: channel-mode? ( mode -- ? ) name>> first "#&" member? ; -: me? ( string -- ? ) irc> nick>> = ; - -GENERIC: to-chat ( message obj -- ) - -M: string to-chat - chat> [ +server-chat+ chat> ] unless* - [ to-chat ] [ drop ] if* ; - -M: irc-chat to-chat in-messages>> mailbox-put ; -M: sequence to-chat [ to-chat ] with each ; - -: unregister-chat ( name -- ) - irc> chats>> - [ at [ irc-chat-end ] dip to-chat ] - [ delete-at ] - 2bi ; - -: (remove-participant) ( nick chat -- ) - [ participants>> delete-at ] - [ [ +part+ f ] dip to-chat ] 2bi ; - -: remove-participant ( nick channel -- ) - chat> [ (remove-participant) ] [ drop ] if* ; - -: chats-with-participant ( nick -- seq ) - irc> chats>> values - [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] - with filter ; - -: remove-participant-from-all ( nick -- ) - dup chats-with-participant [ (remove-participant) ] with each ; - -: notify-rename ( newnick oldnick chat -- ) - [ participant-changed new +nick+ >>action - [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ; - -: rename-participant ( newnick oldnick chat -- ) - [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ] - [ notify-rename ] 3bi ; - -: rename-participant-in-all ( oldnick newnick -- ) - swap dup chats-with-participant [ rename-participant ] with with each ; - -: add-participant ( mode nick channel -- ) - chat> - [ participants>> set-at ] - [ [ +join+ f ] dip to-chat ] 2bi ; - -: change-participant-mode ( channel mode nick -- ) - rot chat> - [ participants>> set-at ] - [ [ participant-changed new - [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ] - 3bi ; ! FIXME - -! ====================================== -! IRC client messages -! ====================================== - -: /NICK ( nick -- ) - "NICK " irc-write irc-print ; - -: /LOGIN ( nick -- ) - dup /NICK - "USER " irc-write irc-write - " hostname servername :irc.factor" irc-print ; - -: /CONNECT ( server port -- stream ) - irc> connect>> call( host port -- stream local ) drop ; - -: /JOIN ( channel password -- ) - "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; - -: /PONG ( text -- ) - "PONG " irc-write irc-print ; - -! ====================================== -! Server message handling -! ====================================== - -GENERIC: initialize-chat ( chat -- ) -M: irc-chat initialize-chat drop ; -M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; - -GENERIC: forward-name ( irc-message -- name ) -M: join forward-name trailing>> ; -M: part forward-name channel>> ; -M: kick forward-name channel>> ; -M: mode forward-name name>> ; -M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; - -UNION: single-forward join part kick mode privmsg ; -UNION: multiple-forward nick quit ; -UNION: broadcast-forward irc-end irc-disconnected irc-connected ; -GENERIC: forward-message ( irc-message -- ) - -M: irc-message forward-message - +server-chat+ chat> [ to-chat ] [ drop ] if* ; - -M: single-forward forward-message dup forward-name to-chat ; - -M: multiple-forward forward-message - dup sender>> chats-with-participant to-chat ; - -M: broadcast-forward forward-message - irc> chats>> values [ to-chat ] with each ; - -GENERIC: process-message ( irc-message -- ) -M: object process-message drop ; -M: rpl-welcome process-message - nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri - values [ initialize-chat ] each ; -M: ping process-message trailing>> /PONG ; -M: rpl-nickname-in-use process-message name>> "_" append /NICK ; - -M: join process-message - [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri - dup chat> [ add-participant ] [ 3drop ] if ; - -M: part process-message - [ sender>> ] [ channel>> ] bi remove-participant ; - -M: kick process-message - [ [ user>> ] [ channel>> ] bi remove-participant ] - [ dup user>> me? [ unregister-chat ] [ drop ] if ] - bi ; - -M: quit process-message - sender>> remove-participant-from-all ; - -M: nick process-message - [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; - -M: mode process-message ( mode -- ) - dup channel-mode? [ - [ name>> ] [ mode>> ] [ parameter>> ] tri - [ change-participant-mode ] [ 2drop ] if* - ] [ drop ] if ; - -: >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; - -: names-reply>participants ( names-reply -- participants ) - nicks>> [ blank? ] trim " " split - [ >nick/mode 2array ] map >hashtable ; - -: maybe-clean-participants ( channel-chat -- ) - dup clean-participants>> [ - H{ } clone >>participants f >>clean-participants - ] when drop ; - -M: rpl-names process-message - [ names-reply>participants ] [ channel>> chat> ] bi [ - [ maybe-clean-participants ] - [ participants>> 2array assoc-combine ] - [ (>>participants) ] tri - ] [ drop ] if* ; - -M: rpl-names-end process-message - channel>> chat> [ - t >>clean-participants - [ f f f ] dip name>> to-chat - ] when* ; - -! ====================================== -! Client message handling -! ====================================== - -GENERIC: handle-outgoing-irc ( irc-message -- ? ) -M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>string irc-print t ; - -! ====================================== -! Reader/Writer -! ====================================== - -: handle-reader-message ( irc-message -- ) - irc> in-messages>> mailbox-put ; - -DEFER: (connect-irc) - -: (handle-disconnect) ( -- ) - irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] - [ dup reconnect-time>> sleep (connect-irc) ] - [ nick>> /LOGIN ] - tri ; - -! FIXME: do something with the exception, store somewhere to help debugging -: handle-disconnect ( error -- ? ) - drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; - -: (reader-loop) ( -- ? ) - irc> stream>> [ - |dispose stream-readln [ - string>irc-message handle-reader-message t - ] [ - f handle-disconnect - ] if* - ] with-destructors ; - -: reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover ; - -: writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; - -! ====================================== -! Processing loops -! ====================================== - -: in-multiplexer-loop ( -- ? ) - irc> in-messages>> mailbox-get - [ forward-message ] [ process-message ] [ irc-end? not ] tri ; - -: strings>privmsg ( name string -- privmsg ) - " :" prepend append "PRIVMSG " prepend string>irc-message ; - -: maybe-annotate-with-name ( name obj -- obj ) - { { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] - } cond ; - -GENERIC: annotate-message ( chat object -- object ) -M: object annotate-message nip ; -M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>target ; -M: string annotate-message [ name>> ] dip strings>privmsg ; - -: spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-server - [ writer-loop ] "irc-writer-loop" spawn-server - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server - 3drop ; - -GENERIC: (attach-chat) ( irc-chat -- ) - -M: irc-chat (attach-chat) - [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] - [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] - bi ; - -M: irc-server-chat (attach-chat) - irc> >>client +server-chat+ irc> chats>> set-at ; - -GENERIC: (remove-chat) ( irc-chat -- ) - -M: irc-nick-chat (remove-chat) - name>> unregister-chat ; - -M: irc-channel-chat (remove-chat) - [ part new annotate-message irc> out-messages>> mailbox-put ] keep - name>> unregister-chat ; - -M: irc-server-chat (remove-chat) - drop +server-chat+ unregister-chat ; - -: (connect-irc) ( irc-client -- ) - { - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] - [ (>>stream) ] - [ t swap (>>is-running) ] - [ in-messages>> [ irc-connected ] dip mailbox-put ] - } cleave ; - -: with-irc-client ( irc-client quot: ( -- ) -- ) - [ \ current-irc-client ] dip with-variable ; inline - -PRIVATE> - : connect-irc ( irc-client -- ) - dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; - -: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; - -: detach-chat ( irc-chat -- ) - [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; - -: speak ( message irc-chat -- ) - [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ; + [ (connect-irc) (do-login) spawn-irc ] with-irc ; +: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ; +: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ; +: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ; +: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ; diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor new file mode 100644 index 0000000000..e358e59058 --- /dev/null +++ b/extra/irc/client/internals/internals-tests.factor @@ -0,0 +1,213 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test accessors arrays sequences +io io.streams.duplex namespaces threads destructors +calendar concurrency.mailboxes classes assocs combinators +irc.messages.parser irc.client.base irc.client.chats +irc.client.participants irc.client.internals ; +EXCLUDE: irc.messages => join ; +RENAME: join irc.messages => join_ +IN: irc.client.internals.tests + +! Streams for testing +TUPLE: mb-writer lines last-line disposed ; +TUPLE: mb-reader lines disposed ; +: ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ; +: ( -- mb-reader ) f mb-reader boa ; +: push-line ( line test-reader-stream -- ) lines>> mailbox-put ; +: ( -- stream ) ; +M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ; +M: mb-writer stream-flush ( mb-writer -- ) drop ; +M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ; +M: mb-writer stream-nl ( mb-writer -- ) + [ [ last-line>> concat ] [ lines>> ] bi push ] keep + V{ } clone >>last-line drop ; +M: mb-reader dispose f swap push-line ; +M: mb-writer dispose drop ; + +: spawn-client ( -- irc-client ) + "someserver" irc-port "factorbot" f + + t >>is-ready + t >>is-running + >>stream + dup [ spawn-irc yield ] with-irc ; + +! to be used inside with-irc quotations +: %add-named-chat ( chat -- ) (attach-chat) ; +: %push-line ( line -- ) irc> stream>> in>> push-line yield ; +: %push-lines ( lines -- ) [ %push-line ] each ; +: %join ( channel -- ) (attach-chat) ; +: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; + +: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; + +: with-irc ( quot: ( -- ) -- ) + [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! TESTS +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { t } [ irc> nick>> me? ] unit-test + + { "factorbot" } [ irc> nick>> ] unit-test + + { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message chat-name ] unit-test + + { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" + string>irc-message chat-name ] unit-test +] with-irc + +{ privmsg "#channel" "hello" } [ + "#channel" "hello" strings>privmsg + [ class ] [ target>> ] [ trailing>> ] tri +] unit-test + +! Test login and nickname set +[ { "factorbot2" } [ + ":some.where 001 factorbot2 :Welcome factorbot2" %push-line + irc> nick>> + ] unit-test +] with-irc + +! Test connect +{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ + "someserver" irc-port "factorbot" f + [ 2drop t ] >>connect + [ + (connect-irc) + (do-login) + irc> stream>> out>> lines>> + (terminate-irc) + ] with-irc +] unit-test + +! Test join +[ { "JOIN #factortest" } [ + "#factortest" %join %pop-output-line + ] unit-test +] with-irc + +[ { join_ "#factortest"} [ + "#factortest" [ %add-named-chat ] keep + { ":factorbot!n=factorbo@some.where JOIN :#factortest" + ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" + } %push-lines + [ join? ] read-matching-message + [ class ] [ channel>> ] bi + ] unit-test +] with-irc + +[ { privmsg "#factortest" "hello" } [ + "#factortest" [ %add-named-chat ] keep + ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ target>> ] [ trailing>> ] tri + ] unit-test +] with-irc + +[ { privmsg "factorbot" "hello" } [ + "ircuser" [ %add-named-chat ] keep + ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ target>> ] [ trailing>> ] tri + ] unit-test +] with-irc + +[ { mode "#factortest" "+ns" } [ + "#factortest" [ %add-named-chat ] keep + ":ircserver.net MODE #factortest +ns" %push-line + [ mode? ] read-matching-message + [ class ] [ name>> ] [ mode>> ] tri + ] unit-test +] with-irc + +! Participant lists tests +[ { { "ircuser" } } [ + "#factortest" [ %add-named-chat ] keep + ":ircuser!n=user@isp.net JOIN :#factortest" %push-line + participants>> keys + ] unit-test +] with-irc + +[ { { "ircuser2" } } [ + "#factortest" + { "ircuser2" "ircuser" } [ over join-participant ] each + [ %add-named-chat ] keep + ":ircuser!n=user@isp.net PART #factortest" %push-line + participants>> keys + ] unit-test +] with-irc + +[ { { "ircuser2" } } [ + "#factortest" + { "ircuser2" "ircuser" } [ over join-participant ] each + [ %add-named-chat ] keep + ":ircuser!n=user@isp.net QUIT" %push-line + participants>> keys + ] unit-test +] with-irc + +[ { { "ircuser2" } } [ + "#factortest" + { "ircuser2" "ircuser" } [ over join-participant ] each + [ %add-named-chat ] keep + ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line + participants>> keys + ] unit-test +] with-irc + +[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [ + "#factortest" + "ircuser" over join-participant + [ %add-named-chat ] keep + ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line + participants>> + ] unit-test +] with-irc + +[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } } + { "ircuser" T{ participant { nick "ircuser" } } } + { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [ + "#factortest" + "ircuser" over join-participant + [ %add-named-chat ] keep + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 353 factorbot @ #factortest :ircuser2 " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced " + ":ircserver.net 353 factorbot @ #factortest :ircuser " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + } %push-lines + participants>> + ] unit-test +] with-irc + +[ { mode "#factortest" "+o" "ircuser" } [ + "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant + ":ircserver.net MODE #factortest +o ircuser" %push-line + [ mode? ] read-matching-message + { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave + ] unit-test +] with-irc + +[ { T{ participant { nick "ircuser" } { operator t } } } [ + "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant + ":ircserver.net MODE #factortest +o ircuser" %push-line + participants>> "ircuser" swap at + ] unit-test +] with-irc + +! Send privmsg +[ { "PRIVMSG #factortest :hello" } [ + "#factortest" [ %add-named-chat ] keep + "hello" swap (speak) %pop-output-line + ] unit-test +] with-irc diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor new file mode 100644 index 0000000000..2081ae4510 --- /dev/null +++ b/extra/irc/client/internals/internals.factor @@ -0,0 +1,162 @@ +! 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 ; +IN: irc.client.internals + +: /NICK ( nick -- ) "NICK " prepend irc-print ; +: /PONG ( text -- ) "PONG " 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 ; + +: /JOIN ( channel password -- ) + [ " :" swap 3append ] when* "JOIN " prepend irc-print ; + +: (connect-irc) ( -- ) + irc> { + [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] + [ (>>stream) ] + [ t swap (>>is-running) ] + [ in-messages>> [ irc-connected ] dip mailbox-put ] + } cleave ; + +: (do-login) ( -- ) irc> nick>> /LOGIN ; + +GENERIC: initialize-chat ( chat -- ) +M: irc-chat initialize-chat drop ; +M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; + +GENERIC: chat-put ( message obj -- ) +M: irc-chat chat-put in-messages>> mailbox-put ; +M: symbol chat-put chat> [ chat-put ] [ drop ] if* ; +M: string chat-put chat> +server-chat+ or chat-put ; +M: sequence chat-put [ chat-put ] with each ; + +: delete-chat ( name -- ) irc> chats>> delete-at ; +: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ; + +! 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: process-message ( irc-message -- ) +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 ; +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 ; + +M: rpl-welcome process-message + irc> + swap nickname>> >>nick + t >>is-ready + chats>> values [ initialize-chat ] each ; + +M: kick process-message + [ [ user>> ] [ chat> ] bi part-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] + bi ; + +M: participant-mode process-message ( participant-mode -- ) + [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ; + +M: rpl-names process-message + [ nicks>> ] [ chat> ] bi dup ?clear-participants + '[ _ join-participant ] each ; + +M: rpl-names-end process-message chat> t >>clear-participants drop ; + +! Client message handling + +GENERIC: handle-outgoing-irc ( irc-message -- ? ) +M: irc-end handle-outgoing-irc drop f ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; + +! Reader/Writer + +: 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) ; + +: handle-disconnect ( error -- ? ) + [ irc> exceptions>> push ] when* + irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; + +GENERIC: handle-input ( line/f -- ? ) +M: string handle-input string>irc-message handle-reader-message t ; +M: f handle-input handle-disconnect ; + +: (reader-loop) ( -- ? ) + stream> [ |dispose stream-readln handle-input ] with-destructors ; + +: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ; +: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ; + +! Processing loops + +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> mailbox-get + [ process-message ] [ forward-message ] [ irc-end? not ] tri ; + +: strings>privmsg ( name string -- privmsg ) + " :" prepend append "PRIVMSG " prepend string>irc-message ; + +GENERIC: annotate-message ( chat object -- object ) +M: object annotate-message nip ; +M: to-channel annotate-message swap name>> >>channel ; +M: to-target annotate-message swap name>> >>target ; +M: mode annotate-message swap name>> >>name ; +M: string annotate-message [ name>> ] dip strings>privmsg ; + +: spawn-irc ( -- ) + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; + +GENERIC: (attach-chat) ( irc-chat -- ) + +M: irc-chat (attach-chat) + irc> + [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ] + [ is-ready>> [ initialize-chat ] [ drop ] if ] + 2bi ; + +M: irc-server-chat (attach-chat) + 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>> 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 diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor new file mode 100644 index 0000000000..8d367dbb95 --- /dev/null +++ b/extra/irc/client/participants/participants.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators fry hashtables +irc.client.base irc.client.chats kernel sequences splitting ; +IN: irc.client.participants + +TUPLE: participant nick operator voice ; +: ( name -- participant ) + { + { [ "@" ?head ] [ t f ] } + { [ "+" ?head ] [ f t ] } + [ f f ] + } cond participant boa ; + +GENERIC: has-participant? ( name irc-chat -- ? ) +M: irc-chat has-participant? 2drop f ; +M: irc-channel-chat has-participant? participants>> key? ; + +: rename-X ( new old assoc quot: ( obj value -- obj ) -- ) + '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline + +: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ; +: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ; +: part-participant ( nick irc-chat -- ) participants>> delete-at ; +: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ; + +: quit-participant ( nick -- ) + dup participant-chats [ part-participant ] with each ; + +: rename-participant* ( new old -- ) + [ dup participant-chats [ rename-participant ] with with each ] + [ dup chat> [ rename-nick-chat ] [ 2drop ] if ] + 2bi ; + +: join-participant ( nick irc-channel-chat -- ) + participants>> [ dup nick>> ] dip set-at ; + +: apply-mode ( ? participant mode -- ) + { + { CHAR: o [ (>>operator) ] } + { CHAR: v [ (>>voice) ] } + [ 3drop ] + } case ; + +: apply-modes ( mode-line participant -- ) + [ unclip CHAR: + = ] dip + '[ [ _ _ ] dip apply-mode ] each ; + +: change-participant-mode ( mode channel nick -- ) + swap chat> participants>> at apply-modes ; + +: ?clear-participants ( channel-chat -- ) + dup clear-participants>> [ + f >>clear-participants participants>> clear-assoc + ] [ drop ] if ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index e0f9a15eff..32d19906f0 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order words assocs strings - irc.messages.base ; +arrays classes.tuple math.order words assocs strings irc.messages.base ; EXCLUDE: sequences => join ; IN: irc.messages @@ -16,7 +15,7 @@ IRC: service "SERVICE" nickname _ distribution type _ : info ; IRC: quit "QUIT" : comment ; IRC: squit "SQUIT" server : comment ; ! channel operations -IRC: join "JOIN" channel ; +IRC: join "JOIN" : channel ; IRC: part "PART" channel : comment ; IRC: topic "TOPIC" channel : topic ; IRC: names "NAMES" channel ; @@ -61,3 +60,9 @@ IRC: rpl-names-end "366" nickname channel : comment ; ! error replies IRC: rpl-nickname-in-use "433" _ name ; IRC: rpl-nick-collision "436" nickname : comment ; + +M: rpl-names post-process-irc-message ( rpl-names -- ) + [ [ blank? ] trim " " split ] change-nicks drop ; + +PREDICATE: channel-mode < mode name>> first "#&" member? ; +PREDICATE: participant-mode < channel-mode parameter>> ;