diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 6bb6a6328e..1b9204c4f1 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,62 +1,57 @@ USING: help.markup help.syntax quotations kernel irc.messages ; IN: irc.client -HELP: irc-client "IRC Client object" -"blah" ; +HELP: irc-client "IRC Client object" ; -HELP: irc-server-listener "Listener for server messages unmanaged by other listeners" -"blah" ; +HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; -HELP: irc-channel-listener "Listener for irc channels" -"blah" ; +HELP: irc-channel-chat "Chat for irc channels" ; -HELP: irc-nick-listener "Listener for irc users" -"blah" ; +HELP: irc-nick-chat "Chat for irc users" ; -HELP: irc-profile "IRC Client profile object" -"blah" ; +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 } "." } ; -HELP: add-listener "Listening to irc channels/users/etc" -{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } } -{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ; +HELP: attach-chat "Chatting with irc channels/users/etc" +{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } +{ $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ; -HELP: remove-listener "Stop an unregister listener" -{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } } -{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ; +HELP: dettach-chat "Stop an unregister chat" +{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } } +{ $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ; HELP: terminate-irc "Terminates an irc client" { $values { "irc-client" "an irc client object" } } -{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ; +{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying chats." } ; -HELP: write-message "Sends a message through a listener" -{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } } -{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ; +HELP: speak "Sends a message through a chat" +{ $values { "message" "a string or irc message object" } { "irc-chat" "an irc chat object" } } +{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-chat" } ". Strings are automatically promoted to privmsg objects." } ; -HELP: read-message "Reads a message from a listener" -{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } } -{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ; +HELP: hear "Reads a message from a chat" +{ $values { "irc-chat" "an irc chat object" } { "message" "an irc message object" } } +{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-chat" } "." } ; ARTICLE: "irc.client" "IRC Client" "An IRC Client library" { $heading "IRC objects:" } { $subsection irc-client } -{ $heading "Listener objects:" } -{ $subsection irc-server-listener } -{ $subsection irc-channel-listener } -{ $subsection irc-nick-listener } +{ $heading "Chat objects:" } +{ $subsection irc-server-chat } +{ $subsection irc-channel-chat } +{ $subsection irc-nick-chat } { $heading "Setup objects:" } { $subsection irc-profile } { $heading "Words:" } { $subsection connect-irc } { $subsection terminate-irc } -{ $subsection add-listener } -{ $subsection remove-listener } -{ $subsection read-message } -{ $subsection write-message } +{ $subsection attach-chat } +{ $subsection dettach-chat } +{ $subsection hear } +{ $subsection speak } { $heading "IRC messages" } "Some of the RFC defined irc messages as objects:" { $table @@ -77,27 +72,28 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table - { { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." } - { { $link irc-disconnected } " sent to notify listeners that connection was lost." } - { { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } } + { { $link irc-chat-end } "sent to a chat when it has been dettached from the client, the chat should stop after it receives this message. " } + { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } + { { $link irc-disconnected } " sent to notify chats that connection was lost." } + { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } { $heading "Example:" } { $code - "USING: irc.client concurrency.mailboxes ;" + "USING: irc.client ;" "SYMBOL: bot" "SYMBOL: mychannel" "! Create the profile and client objects" "\"irc.freenode.org\" irc-port \"mybot123\" f bot set" "! Connect to the server" "bot get connect-irc" - "! Create a channel listener" - "\"#mychannel123\" mychannel set" - "! Register and start listener (this joins the channel)" - "mychannel get bot get add-listener" + "! Create a channel chat" + "\"#mychannel123\" mychannel set" + "! 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 write-message" + "\"what's up?\" mychannel get speak" "! Read a message from the channel" - "mychannel get read-message" + "mychannel get hear" } ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index c768c1a82e..fe85d6c375 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test accessors arrays sequences qualified - io io.streams.duplex namespaces threads + io io.streams.duplex namespaces threads destructors calendar irc.client.private irc.client irc.messages.private concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; @@ -19,20 +19,23 @@ 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 drop ; +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-listener ( listener -- ) [ name>> ] keep set+run-listener ; -: %join ( channel -- ) irc> add-listener ; +: %add-named-chat ( chat -- ) irc> attach-chat ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; +: %join ( channel -- ) irc> attach-chat ; -: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message ) +: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; : with-irc ( quot: ( -- ) -- ) @@ -42,9 +45,9 @@ M: mb-writer stream-nl ( mb-writer -- ) ! TESTS ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -[ { t } [ irc> profile>> nickname>> me? ] unit-test +[ { t } [ irc> nick>> me? ] unit-test - { "factorbot" } [ irc> profile>> nickname>> ] unit-test + { "factorbot" } [ irc> nick>> ] unit-test { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test @@ -58,30 +61,46 @@ M: mb-writer stream-nl ( mb-writer -- ) ! Test login and nickname set [ { "factorbot2" } [ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line - irc> profile>> nickname>> + 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 ] keep + stream>> [ in>> [ f ] dip push-line ] [ out>> lines>> ] bi +] unit-test + +! Test join +[ { "JOIN #factortest" } [ + "#factortest" %join + irc> stream>> out>> lines>> pop ] 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 - irc> join-messages>> 0.1 seconds mailbox-get-timeout + in-messages>> 0.1 seconds mailbox-get-timeout [ class ] [ trailing>> ] bi ] unit-test ] with-irc [ { T{ participant-changed f "somebody" +join+ } } [ - "#factortest" [ %add-named-listener ] keep + "#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-listener ] keep + "#factortest" [ %add-named-chat ] keep ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line [ privmsg? ] read-matching-message [ class ] [ name>> ] [ trailing>> ] tri @@ -89,90 +108,90 @@ M: mb-writer stream-nl ( mb-writer -- ) ] with-irc [ { privmsg "factorbot" "hello" } [ - "somedude" [ %add-named-listener ] keep - ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line + "ircuser" [ %add-named-chat ] keep + ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line [ privmsg? ] read-matching-message [ class ] [ name>> ] [ trailing>> ] tri ] unit-test ] with-irc [ { mode } [ - "#factortest" [ %add-named-listener ] keep + "#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{ { "somedude" +normal+ } } } [ - "#factortest" [ %add-named-listener ] keep - ":somedude!n=user@isp.net JOIN :#factortest" %push-line +[ { H{ { "ircuser" +normal+ } } } [ + "#factortest" [ %add-named-chat ] keep + ":ircuser!n=user@isp.net JOIN :#factortest" %push-line participants>> ] unit-test ] with-irc -[ { H{ { "somedude2" +normal+ } } } [ - "#factortest" - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude!n=user@isp.net PART #factortest" %push-line +[ { 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{ { "somedude2" +normal+ } } } [ - "#factortest" - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude!n=user@isp.net QUIT" %push-line +[ { 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{ { "somedude2" +normal+ } } } [ - "#factortest" - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line +[ { 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{ { "somedude2" +normal+ } } } [ - "#factortest" - H{ { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude!n=user2@isp.net NICK :somedude2" %push-line +[ { 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 ! Namelist change notification [ { T{ participant-changed f f f f } } [ - "#factortest" [ %add-named-listener ] keep + "#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 "somedude" +part+ f } } [ - "#factortest" - H{ { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude!n=user@isp.net QUIT" %push-line +[ { 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 "somedude" +nick+ "somedude2" } } [ - "#factortest" - H{ { "somedude" +normal+ } } clone >>participants - [ %add-named-listener ] keep - ":somedude!n=user2@isp.net NICK :somedude2" %push-line +[ { 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 diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 569f6c4bf7..d40c7d400d 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -17,17 +17,17 @@ IN: irc.client TUPLE: irc-profile server port nickname password ; C: irc-profile -TUPLE: irc-client profile stream in-messages out-messages join-messages - listeners is-running connect reconnect-time ; +TUPLE: irc-client profile stream in-messages out-messages + chats is-running nick connect reconnect-time is-ready ; : ( profile -- irc-client ) - f H{ } clone f - [ latin1 ] 15 seconds irc-client boa ; + [ f H{ } clone f ] keep nickname>> + [ latin1 ] 15 seconds f irc-client boa ; -TUPLE: irc-listener in-messages out-messages ; -TUPLE: irc-server-listener < irc-listener ; -TUPLE: irc-channel-listener < irc-listener name password timeout participants ; -TUPLE: irc-nick-listener < irc-listener name ; -SYMBOL: +server-listener+ +TUPLE: irc-chat in-messages client ; +TUPLE: irc-server-chat < irc-chat ; +TUPLE: irc-channel-chat < irc-chat name password timeout participants ; +TUPLE: irc-nick-chat < irc-chat name ; +SYMBOL: +server-chat+ ! participant modes SYMBOL: +operator+ @@ -43,18 +43,16 @@ SYMBOL: +part+ SYMBOL: +mode+ SYMBOL: +nick+ -! listener objects -: ( -- irc-listener ) irc-listener boa ; +! chat objects +: ( -- irc-server-chat ) + f irc-server-chat boa ; -: ( -- irc-server-listener ) - irc-server-listener boa ; +: ( name -- irc-channel-chat ) + [ f ] dip f 60 seconds H{ } clone + irc-channel-chat boa ; -: ( name -- irc-channel-listener ) - [ ] dip f 60 seconds H{ } clone - irc-channel-listener boa ; - -: ( name -- irc-nick-listener ) - [ ] dip irc-nick-listener boa ; +: ( name -- irc-nick-chat ) + [ f ] dip irc-nick-chat boa ; ! ====================================== ! Message objects @@ -63,22 +61,17 @@ SYMBOL: +nick+ TUPLE: participant-changed nick action parameter ; C: participant-changed -SINGLETON: irc-listener-end ! send to a listener to stop its execution +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 -> values [ out-messages>> ] map ] - [ in-messages>> ] - [ out-messages>> ] tri 2array prepend - [ irc-end swap mailbox-put ] each ; -PRIVATE> - : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ - [ end-loops ] [ [ f ] dip (>>is-running) ] bi + f >>is-running + [ stream>> dispose ] keep + [ in-messages>> ] [ out-messages>> ] bi 2array + [ irc-end swap mailbox-put ] each ] when* ; ( -- irc-client ) current-irc-client get ; -: irc-stream> ( -- stream ) irc> stream>> ; -: irc-write ( s -- ) irc-stream> stream-write ; -: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; +: 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 ; -: listener> ( name -- listener/f ) irc> listeners>> at ; +: chat> ( name -- chat/f ) irc> chats>> at ; : channel-mode? ( mode -- ? ) name>> first "#&" member? ; -: me? ( string -- ? ) irc> profile>> nickname>> = ; +: me? ( string -- ? ) irc> nick>> = ; -GENERIC: to-listener ( message obj -- ) +GENERIC: to-chat ( message obj -- ) -M: string to-listener ( message string -- ) - listener> [ +server-listener+ listener> ] unless* - [ to-listener ] [ drop ] if* ; +M: string to-chat + chat> [ +server-chat+ chat> ] unless* + [ to-chat ] [ drop ] if* ; -M: irc-listener to-listener ( message irc-listener -- ) - in-messages>> mailbox-put ; +M: irc-chat to-chat in-messages>> mailbox-put ; -: unregister-listener ( name -- ) - irc> listeners>> - [ at [ irc-listener-end ] dip to-listener ] +: unregister-chat ( name -- ) + irc> chats>> + [ at [ irc-chat-end ] dip to-chat ] [ delete-at ] 2bi ; -: (remove-participant) ( nick listener -- ) +: (remove-participant) ( nick chat -- ) [ participants>> delete-at ] - [ [ +part+ f ] dip to-listener ] 2bi ; + [ [ +part+ f ] dip to-chat ] 2bi ; : remove-participant ( nick channel -- ) - listener> [ (remove-participant) ] [ drop ] if* ; + chat> [ (remove-participant) ] [ drop ] if* ; -: listeners-with-participant ( nick -- seq ) - irc> listeners>> values - [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] +: chats-with-participant ( nick -- seq ) + irc> chats>> values + [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ] with filter ; -: to-listeners-with-participant ( message nickname -- ) - listeners-with-participant [ to-listener ] with each ; +: to-chats-with-participant ( message nickname -- ) + chats-with-participant [ to-chat ] with each ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ (remove-participant) ] with each ; + dup chats-with-participant [ (remove-participant) ] with each ; -: notify-rename ( newnick oldnick listener -- ) +: notify-rename ( newnick oldnick chat -- ) [ participant-changed new +nick+ >>action - [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ; + [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ; -: rename-participant ( newnick oldnick listener -- ) - [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ] +: rename-participant ( newnick oldnick chat -- ) + [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ] [ notify-rename ] 3bi ; : rename-participant-in-all ( oldnick newnick -- ) - swap dup listeners-with-participant [ rename-participant ] with with each ; + swap dup chats-with-participant [ rename-participant ] with with each ; : add-participant ( mode nick channel -- ) - listener> + chat> [ participants>> set-at ] - [ [ +join+ f ] dip to-listener ] 2bi ; + [ [ +join+ f ] dip to-chat ] 2bi ; : change-participant-mode ( channel mode nick -- ) - rot listener> + rot chat> [ participants>> set-at ] - [ [ [ +mode+ ] dip ] dip to-listener ] 3bi ; ! FIXME + [ [ [ +mode+ ] dip ] dip to-chat ] 3bi ; ! FIXME DEFER: me? -: maybe-forward-join ( join -- ) - [ irc-message-sender me? ] keep and - [ irc> join-messages>> mailbox-put ] when* ; - ! ====================================== ! IRC client messages ! ====================================== @@ -184,64 +171,57 @@ DEFER: me? ! 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 ( join -- name ) trailing>> ; -M: part forward-name ( part -- name ) channel>> ; -M: kick forward-name ( kick -- name ) channel>> ; -M: mode forward-name ( mode -- name ) name>> ; -M: privmsg forward-name ( privmsg -- name ) - dup name>> me? [ irc-message-sender ] [ name>> ] if ; +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 name>> me? [ irc-message-sender ] [ name>> ] 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 ( irc-message -- ) - +server-listener+ listener> [ to-listener ] [ drop ] if* ; +M: irc-message forward-message + +server-chat+ chat> [ to-chat ] [ drop ] if* ; -M: single-forward forward-message ( forward-single -- ) - dup forward-name to-listener ; +M: single-forward forward-message dup forward-name to-chat ; -M: multiple-forward forward-message ( multiple-forward -- ) - dup irc-message-sender to-listeners-with-participant ; - -M: join forward-message ( join -- ) - [ maybe-forward-join ] [ call-next-method ] bi ; - -M: broadcast-forward forward-message ( irc-broadcasted-message -- ) - irc> listeners>> values [ to-listener ] with each ; +M: multiple-forward forward-message + dup irc-message-sender to-chats-with-participant ; + +M: broadcast-forward forward-message + irc> chats>> values [ to-chat ] with each ; GENERIC: process-message ( irc-message -- ) +M: object process-message drop ; +M: logged-in process-message + name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri + values [ initialize-chat ] each ; +M: ping process-message trailing>> /PONG ; +M: nick-in-use process-message name>> "_" append /NICK ; -M: object process-message ( object -- ) - drop ; - -M: logged-in process-message ( logged-in -- ) - name>> irc> profile>> (>>nickname) ; - -M: ping process-message ( ping -- ) - trailing>> /PONG ; - -M: nick-in-use process-message ( nick-in-use -- ) - name>> "_" append /NICK ; - -M: join process-message ( join -- ) +M: join process-message [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri - dup listener> [ add-participant ] [ 3drop ] if ; + dup chat> [ add-participant ] [ 3drop ] if ; -M: part process-message ( part -- ) +M: part process-message [ irc-message-sender ] [ channel>> ] bi remove-participant ; -M: kick process-message ( kick -- ) +M: kick process-message [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-listener ] [ drop ] if ] + [ dup who>> me? [ unregister-chat ] [ drop ] if ] bi ; -M: quit process-message ( quit -- ) +M: quit process-message irc-message-sender remove-participant-from-all ; -M: nick process-message ( nick -- ) +M: nick process-message [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; ! M: mode process-message ( mode -- ) @@ -257,10 +237,10 @@ M: nick process-message ( nick -- ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; -M: names-reply process-message ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi [ +M: names-reply process-message + [ names-reply>participants ] [ channel>> chat> ] bi [ [ (>>participants) ] - [ [ f f f ] dip name>> to-listener ] bi + [ [ f f f ] dip name>> to-chat ] bi ] [ drop ] if* ; ! ====================================== @@ -268,9 +248,8 @@ M: names-reply process-message ( names-reply -- ) ! ====================================== GENERIC: handle-outgoing-irc ( irc-message -- ? ) -M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ; -M: irc-message handle-outgoing-irc ( irc-message -- ? ) - irc-message>client-line irc-print t ; +M: irc-end handle-outgoing-irc drop f ; +M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ; ! ====================================== ! Reader/Writer @@ -285,12 +264,12 @@ DEFER: (connect-irc) irc> [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] - [ profile>> nickname>> /LOGIN ] + [ nick>> /LOGIN ] tri ; ! FIXME: do something with the exception, store somewhere to help debugging -: handle-disconnect ( error -- ) - drop irc> is-running>> [ (handle-disconnect) ] when ; +: handle-disconnect ( error -- ? ) + drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; : (reader-loop) ( -- ? ) irc> stream>> [ @@ -302,7 +281,7 @@ DEFER: (connect-irc) ] with-destructors ; : reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect t ] recover ; + [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ; @@ -324,16 +303,11 @@ DEFER: (connect-irc) [ nip ] } cond ; -GENERIC: handle-listener-out ( irc-message -- ? ) -M: irc-end handle-listener-out ( irc-end -- ? ) drop f ; -M: irc-message handle-listener-out ( irc-message -- ? ) - irc> out-messages>> mailbox-put t ; - -: listener-loop ( name -- ? ) - dup listener> [ - out-messages>> mailbox-get - maybe-annotate-with-name handle-listener-out - ] [ drop f ] if* ; +GENERIC: annotate-message ( chat object -- object ) +M: object annotate-message nip ; +M: part annotate-message swap name>> >>channel ; +M: privmsg annotate-message swap name>> >>name ; +M: string annotate-message [ name>> ] dip strings>privmsg ; : spawn-irc ( -- ) [ reader-loop ] "irc-reader-loop" spawn-server @@ -341,48 +315,35 @@ M: irc-message handle-listener-out ( irc-message -- ? ) [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server 3drop ; -! ====================================== -! Listener join request handling -! ====================================== +GENERIC: (attach-chat) ( irc-chat -- ) +USE: prettyprint +M: irc-chat (attach-chat) + [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] + [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] + bi ; -: set+run-listener ( name irc-listener -- ) - over irc> listeners>> set-at - '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ; +M: irc-server-chat (attach-chat) + irc> >>client +server-chat+ irc> chats>> set-at ; -GENERIC: (add-listener) ( irc-listener -- ) +GENERIC: (remove-chat) ( irc-chat -- ) -M: irc-channel-listener (add-listener) ( irc-channel-listener -- ) - [ [ name>> ] [ password>> ] bi /JOIN ] - [ [ [ drop irc> join-messages>> ] - [ timeout>> ] - [ name>> '[ trailing>> _ = ] ] - tri mailbox-get-timeout? trailing>> ] keep set+run-listener - ] bi ; +M: irc-nick-chat (remove-chat) + name>> unregister-chat ; -M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) - [ name>> ] keep set+run-listener ; +M: irc-channel-chat (remove-chat) + [ part new annotate-message irc> out-messages>> mailbox-put ] keep + name>> unregister-chat ; -M: irc-server-listener (add-listener) ( irc-server-listener -- ) - [ +server-listener+ ] dip set+run-listener ; - -GENERIC: (remove-listener) ( irc-listener -- ) - -M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) - name>> unregister-listener ; - -M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) - [ [ name>> ] [ out-messages>> ] bi - [ [ part new ] dip >>channel ] dip mailbox-put ] keep - name>> unregister-listener ; - -M: irc-server-listener (remove-listener) ( irc-server-listener -- ) - drop +server-listener+ unregister-listener ; +M: irc-server-chat (remove-chat) + drop +server-chat+ unregister-chat ; : (connect-irc) ( irc-client -- ) - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep - swap >>stream - t >>is-running - in-messages>> [ irc-connected ] dip mailbox-put ; + { + [ 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 @@ -390,15 +351,14 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) PRIVATE> : connect-irc ( irc-client -- ) - [ irc> - [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi - spawn-irc ] with-irc-client ; + dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; -: add-listener ( irc-listener irc-client -- ) - swap '[ _ (add-listener) ] with-irc-client ; +: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; -: remove-listener ( irc-listener irc-client -- ) - swap '[ _ (remove-listener) ] with-irc-client ; +: dettach-chat ( irc-chat -- ) + [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; -: write-message ( message irc-listener -- ) out-messages>> mailbox-put ; -: read-message ( irc-listener -- message ) in-messages>> mailbox-get ; +: speak ( message irc-chat -- ) + [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ; + +: hear ( irc-chat -- message ) in-messages>> mailbox-get ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index b61dd16448..41272a43f2 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -62,4 +62,14 @@ IN: irc.messages.tests { parameters { } } { trailing "someuser2" } } } [ ":someuser!n=user@some.where NICK :someuser2" + parse-irc-line f >>timestamp ] unit-test + +{ T{ nick-in-use + { line ":ircserver.net 433 * nickname :Nickname is already in use" } + { prefix "ircserver.net" } + { command "433" } + { parameters { "*" "nickname" } } + { name "nickname" } + { trailing "Nickname is already in use" } } } +[ ":ircserver.net 433 * nickname :Nickname is already in use" 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 9201f822da..882cec5c8d 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -17,7 +17,7 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message asterisk name ; +TUPLE: nick-in-use < irc-message name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; @@ -31,45 +31,43 @@ TUPLE: unhandled < irc-message ; GENERIC: command-string>> ( irc-message -- string ) -M: irc-message command-string>> ( irc-message -- string ) command>> ; -M: ping command-string>> ( ping -- string ) drop "PING" ; -M: join command-string>> ( join -- string ) drop "JOIN" ; -M: part command-string>> ( part -- string ) drop "PART" ; -M: quit command-string>> ( quit -- string ) drop "QUIT" ; -M: nick command-string>> ( nick -- string ) drop "NICK" ; -M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; -M: notice command-string>> ( notice -- string ) drop "NOTICE" ; -M: mode command-string>> ( mode -- string ) drop "MODE" ; -M: kick command-string>> ( kick -- string ) drop "KICK" ; +M: irc-message command-string>> command>> ; +M: ping command-string>> drop "PING" ; +M: join command-string>> drop "JOIN" ; +M: part command-string>> drop "PART" ; +M: quit command-string>> drop "QUIT" ; +M: nick command-string>> drop "NICK" ; +M: privmsg command-string>> drop "PRIVMSG" ; +M: notice command-string>> drop "NOTICE" ; +M: mode command-string>> drop "MODE" ; +M: kick command-string>> drop "KICK" ; GENERIC: command-parameters>> ( irc-message -- seq ) -M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; -M: ping command-parameters>> ( ping -- seq ) drop { } ; -M: join command-parameters>> ( join -- seq ) drop { } ; -M: part command-parameters>> ( part -- seq ) channel>> 1array ; -M: quit command-parameters>> ( quit -- seq ) drop { } ; -M: nick command-parameters>> ( nick -- seq ) drop { } ; -M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; -M: notice command-parameters>> ( norice -- seq ) type>> 1array ; -M: kick command-parameters>> ( kick -- seq ) - [ channel>> ] [ who>> ] bi 2array ; -M: mode command-parameters>> ( mode -- seq ) - [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +M: irc-message command-parameters>> parameters>> ; +M: ping command-parameters>> drop { } ; +M: join command-parameters>> drop { } ; +M: part command-parameters>> channel>> 1array ; +M: quit command-parameters>> drop { } ; +M: nick command-parameters>> drop { } ; +M: privmsg command-parameters>> name>> 1array ; +M: notice command-parameters>> type>> 1array ; +M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ; +M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; GENERIC: (>>command-parameters) ( params irc-message -- ) -M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; -M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ; -M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ; -M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ; -M: part (>>command-parameters) ( params part -- ) - [ first ] dip (>>channel) ; -M: kick (>>command-parameters) ( params kick -- ) +M: irc-message (>>command-parameters) 2drop ; +M: logged-in (>>command-parameters) [ first ] dip (>>name) ; +M: privmsg (>>command-parameters) [ first ] dip (>>name) ; +M: notice (>>command-parameters) [ first ] dip (>>type) ; +M: part (>>command-parameters) [ first ] dip (>>channel) ; +M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ; +M: kick (>>command-parameters) [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; -M: names-reply (>>command-parameters) ( params names-reply -- ) +M: names-reply (>>command-parameters) [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; -M: mode (>>command-parameters) ( params mode -- ) +M: mode (>>command-parameters) { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; @@ -78,16 +76,14 @@ PRIVATE> GENERIC: irc-message>client-line ( irc-message -- string ) -M: irc-message irc-message>client-line ( irc-message -- string ) +M: irc-message irc-message>client-line [ command-string>> ] [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] 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" ; +M: irc-message irc-message>server-line drop "not implemented yet" ; UNION: sender-in-prefix privmsg join part quit kick mode nick ; GENERIC: irc-message-sender ( irc-message -- sender ) -M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) - prefix>> parse-name ; +M: sender-in-prefix irc-message-sender prefix>> parse-name ; : string>irc-message ( string -- object ) dup split-prefix split-trailing diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index 184a2b4de8..4bb77e7490 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -8,7 +8,7 @@ IN: irc.ui.commands : say ( string -- ) irc-tab get [ window>> client>> profile>> nickname>> print-irc ] - [ listener>> write-message ] 2bi ; + [ chat>> speak ] 2bi ; : join ( string -- ) irc-tab get window>> join-channel ; @@ -18,7 +18,7 @@ IN: irc.ui.commands : whois ( string -- ) "WHOIS" swap { } clone swap - irc-tab get listener>> write-message ; + irc-tab get listener>> speak ; : quote ( string -- ) drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 1e4bcf35f8..50dc9378a2 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -15,7 +15,7 @@ RENAME: join sequences => sjoin IN: irc.ui -SYMBOL: listener +SYMBOL: chat SYMBOL: client @@ -24,7 +24,7 @@ TUPLE: ui-window < tabbed client ; M: ui-window ungraft* client>> terminate-irc ; -TUPLE: irc-tab < frame listener client window ; +TUPLE: irc-tab < frame chat client window ; : write-color ( str color -- ) foreground associate format ; @@ -117,7 +117,7 @@ M: irc-disconnected write-irc M: irc-connected write-irc drop "* Connected" dark-green write-color ; -M: irc-listener-end write-irc +M: irc-chat-end write-irc drop ; M: irc-message write-irc @@ -135,7 +135,7 @@ M: object time-happened drop now ; : send-message ( message -- ) [ print-irc ] - [ listener get write-message ] bi ; + [ chat get speak ] bi ; GENERIC: handle-inbox ( tab message -- ) @@ -150,7 +150,7 @@ M: object handle-inbox : display ( stream tab -- ) '[ _ [ [ t ] - [ _ dup listener>> read-message handle-inbox ] + [ _ dup chat>> hear handle-inbox ] [ ] while ] with-output-stream ] "ircv" spawn drop ; : ( tab -- tab pane ) @@ -175,28 +175,28 @@ irc-editor "general" f { { T{ key-down f f "ENTER" } editor-send } } define-command-map -: new-irc-tab ( listener ui-window class -- irc-tab ) +: new-irc-tab ( chat ui-window class -- irc-tab ) new-frame swap >>window - swap >>listener + swap >>chat [ @center grid-add ] keep @bottom grid-add ; M: irc-tab graft* - [ listener>> ] [ window>> client>> ] bi add-listener ; + [ chat>> ] [ window>> client>> ] bi attach-chat ; M: irc-tab ungraft* - [ listener>> ] [ window>> client>> ] bi remove-listener ; + chat>> dettach-chat ; TUPLE: irc-channel-tab < irc-tab userlist ; -: ( listener ui-window -- irc-tab ) +: ( chat ui-window -- irc-tab ) irc-channel-tab new-irc-tab [ @right grid-add ] keep >>userlist ; : update-participants ( tab -- ) [ userlist>> [ clear-gadget ] keep ] - [ listener>> participants>> ] bi + [ chat>> participants>> ] bi [ +operator+ value-labels dark-green add-gadget-color ] [ +voice+ value-labels blue add-gadget-color ] [ +normal+ value-labels black add-gadget-color ] tri drop ; @@ -206,22 +206,22 @@ M: participant-changed handle-inbox TUPLE: irc-server-tab < irc-tab ; -: ( listener -- irc-tab ) +: ( chat -- irc-tab ) f irc-server-tab new-irc-tab ; -: ( listener ui-window -- irc-tab ) +: ( chat ui-window -- irc-tab ) irc-tab new-irc-tab ; M: irc-tab pref-dim* drop { 480 480 } ; : join-channel ( name ui-window -- ) - [ dup ] dip + [ dup ] dip [ swap ] keep add-page ; : query-nick ( nick ui-window -- ) - [ dup ] dip + [ dup ] dip [ swap ] keep add-page ; @@ -232,8 +232,8 @@ M: irc-tab pref-dim* : ui-connect ( profile -- ui-window ) - { [ [ ] dip add-listener ] - [ listeners>> +server-listener+ swap at dup + { [ [ ] dip attach-chat ] + [ chats>> +server-chat+ swap at dup "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ] [ >>client ] [ connect-irc ] } cleave ;