diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor new file mode 100644 index 0000000000..2a66f3a701 --- /dev/null +++ b/extra/irc/client/client-docs.factor @@ -0,0 +1,89 @@ +USING: help.markup help.syntax quotations kernel ; +IN: irc.client + +HELP: irc-client "IRC Client object" +"blah" ; + +HELP: irc-server-listener "Listener for server messages unmanaged by other listeners" +"blah" ; + +HELP: irc-channel-listener "Listener for irc channels" +"blah" ; + +HELP: irc-nick-listener "Listener for irc users" +"blah" ; + +HELP: irc-profile "IRC Client profile object" +"blah" ; + +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-client" "an irc client object" } { "irc-listener" "an irc listener object" } } +{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ; + +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." } ; + +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 "Setup objects:" } +{ $subsection irc-profile } +{ $heading "Words:" } +{ $subsection connect-irc } +{ $subsection terminate-irc } +{ $subsection add-listener } +{ $heading "IRC messages" } +"Some of the RFC defined irc messages as objects:" +{ $table + { { $link irc-message } "base of all irc messages" } + { { $link logged-in } "logged in to server" } + { { $link ping } "ping message" } + { { $link join } "channel join" } + { { $link part } "channel part" } + { { $link quit } "quit from irc" } + { { $link privmsg } "private message (to client or channel)" } + { { $link kick } "kick from channel" } + { { $link roomlist } "list of participants in channel" } + { { $link nick-in-use } "chosen nick is in use by another client" } + { { $link notice } "notice message" } + { { $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 + { { $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." } } + +{ $heading "Example:" } +{ $code + "USING: irc.client concurrency.mailboxes ;" + "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)" + "bot get mychannel get add-listener" + "! Send a message to the channel" + "\"what's up?\" mychannel get out-messages>> mailbox-put" + "! Read a message from the channel" + "mychannel get in-messages>> mailbox-get" +} + ; + +ABOUT: "irc.client" \ No newline at end of file diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor new file mode 100644 index 0000000000..304ab25402 --- /dev/null +++ b/extra/irc/client/client-tests.factor @@ -0,0 +1,79 @@ +USING: kernel tools.test accessors arrays sequences qualified + io.streams.string io.streams.duplex namespaces threads + calendar irc.client.private ; +EXCLUDE: irc.client => join ; +IN: irc.client.tests + +! Utilities +: ( lines -- stream ) + "\n" join ; + +: make-client ( lines -- irc-client ) + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; + +: set-nick ( irc-client nickname -- ) + [ nick>> ] dip >>name drop ; + +: with-dummy-client ( quot -- ) + rot with-variable ; inline + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +{ "" } make-client dup "factorbot" set-nick current-irc-client [ + { t } [ irc> nick>> name>> me? ] unit-test + + { "factorbot" } [ irc> nick>> name>> ] unit-test + + { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + + { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line irc-message-origin ] unit-test + + { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" + parse-irc-line irc-message-origin ] unit-test +] with-variable + +! Test login and nickname set +{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." + "NOTICE AUTH :*** Checking ident" + "NOTICE AUTH :*** Found your hostname" + "NOTICE AUTH :*** No identd (auth) response" + ":some.where 001 factorbot :Welcome factorbot" + } make-client + [ connect-irc ] keep 1 seconds sleep + nick>> name>> ] unit-test + +! TODO: Channel join messages +! { ":factorbot!n=factorbo@some.where JOIN :#factortest" +! ":ircserver.net MODE #factortest +ns" +! ":ircserver.net 353 factorbot @ #factortest :@factorbot " +! ":ircserver.net 366 factorbot #factortest :End of /NAMES list." +! ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" +! } make-client dup "factorbot" set-nick +! TODO: user join +! ":somedude!n=user@isp.net JOIN :#factortest" +! TODO: channel message +! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! TODO: direct private message +! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 19dca48e1d..e633f140fb 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators concurrency.mailboxes concurrency.futures io +USING: arrays combinators concurrency.mailboxes fry io strings io.encodings.8-bit io.sockets kernel namespaces sequences sequences.lib splitting threads calendar classes.tuple - ascii assocs accessors destructors ; + classes ascii assocs accessors destructors continuations ; IN: irc.client ! ====================================== @@ -18,28 +18,42 @@ SYMBOL: current-irc-client TUPLE: irc-profile server port nickname password ; C: irc-profile -TUPLE: irc-channel-profile name password ; -: ( -- irc-channel-profile ) irc-channel-profile new ; - ! "live" objects TUPLE: nick name channels log ; C: nick TUPLE: irc-client profile nick stream in-messages out-messages join-messages - listeners is-running ; + listeners is-running connect reconnect-time ; : ( profile -- irc-client ) f V{ } clone V{ } clone - f H{ } clone f irc-client boa ; + f H{ } clone f + [ latin1 ] 15 seconds irc-client boa ; TUPLE: irc-listener in-messages out-messages ; -: ( -- irc-listener ) - irc-listener boa ; +TUPLE: irc-server-listener < irc-listener ; +TUPLE: irc-channel-listener < irc-listener name password timeout ; +TUPLE: irc-nick-listener < irc-listener name ; +UNION: irc-named-listener irc-nick-listener irc-channel-listener ; + +: ( -- irc-listener ) irc-listener boa ; + +: ( -- irc-server-listener ) + irc-server-listener boa ; + +: ( name -- irc-channel-listener ) + rot f 60 seconds irc-channel-listener boa ; + +: ( name -- irc-nick-listener ) + rot irc-nick-listener boa ; ! ====================================== ! Message objects ! ====================================== -SINGLETON: irc-end ! Message used when the client isn't running anymore +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 +UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: logged-in < irc-message name ; @@ -55,14 +69,20 @@ TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name channel mode ; TUPLE: unhandled < irc-message ; +: terminate-irc ( irc-client -- ) + [ in-messages>> irc-end swap mailbox-put ] + [ f >>is-running drop ] + [ stream>> dispose ] + tri ; + ( -- irc-client ) current-irc-client get ; -: irc-stream> ( -- stream ) irc-client> stream>> ; +: irc> ( -- 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 ; @@ -79,7 +99,7 @@ TUPLE: unhandled < irc-message ; " hostname servername :irc.factor" irc-print ; : /CONNECT ( server port -- stream ) - latin1 drop ; + irc> connect>> call drop ; : /JOIN ( channel password -- ) "JOIN " irc-write @@ -106,48 +126,12 @@ TUPLE: unhandled < irc-message ; : /PONG ( text -- ) "PONG " irc-write irc-print ; -! ====================================== -! Server message handling -! ====================================== - -USE: prettyprint - -GENERIC: handle-incoming-irc ( irc-message -- ) - -M: irc-message handle-incoming-irc ( irc-message -- ) - . ; - -M: logged-in handle-incoming-irc ( logged-in -- ) - name>> irc-client> nick>> (>>name) ; - -M: ping handle-incoming-irc ( ping -- ) - trailing>> /PONG ; - -M: nick-in-use handle-incoming-irc ( nick-in-use -- ) - name>> "_" append /NICK ; - -M: privmsg handle-incoming-irc ( privmsg -- ) - dup name>> irc-client> listeners>> at - [ in-messages>> mailbox-put ] [ drop ] if* ; - -M: join handle-incoming-irc ( join -- ) - irc-client> join-messages>> mailbox-put ; - -! ====================================== -! Client message handling -! ====================================== - -GENERIC: handle-outgoing-irc ( obj -- ) - -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - ! ====================================== ! Message parsing ! ====================================== : split-at-first ( seq separators -- before after ) - dupd [ member? ] curry find + dupd '[ , member? ] find [ cut 1 tail ] [ swap ] if ; @@ -188,50 +172,115 @@ M: privmsg handle-outgoing-irc ( privmsg -- ) } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; +! ====================================== +! Server message handling +! ====================================== + +: me? ( string -- ? ) + irc> nick>> name>> = ; + +: irc-message-origin ( irc-message -- name ) + dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; + +: broadcast-message-to-listeners ( message -- ) + irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + +GENERIC: handle-incoming-irc ( irc-message -- ) + +M: irc-message handle-incoming-irc ( irc-message -- ) + f irc> listeners>> at + [ in-messages>> mailbox-put ] [ drop ] if* ; + +M: logged-in handle-incoming-irc ( logged-in -- ) + name>> irc> nick>> (>>name) ; + +M: ping handle-incoming-irc ( ping -- ) + trailing>> /PONG ; + +M: nick-in-use handle-incoming-irc ( nick-in-use -- ) + name>> "_" append /NICK ; + +M: privmsg handle-incoming-irc ( privmsg -- ) + dup irc-message-origin irc> listeners>> [ at ] keep + '[ f , at ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ; + +M: join handle-incoming-irc ( join -- ) + irc> join-messages>> mailbox-put ; + +M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) + broadcast-message-to-listeners ; + +! ====================================== +! Client message handling +! ====================================== + +GENERIC: handle-outgoing-irc ( obj -- ) + +M: privmsg handle-outgoing-irc ( privmsg -- ) + [ name>> ] [ trailing>> ] bi /PRIVMSG ; + ! ====================================== ! Reader/Writer ! ====================================== -: stream-readln-or-close ( stream -- str/f ) - dup stream-readln [ nip ] [ dispose f ] if* ; +: irc-mailbox-get ( mailbox quot -- ) + swap 5 seconds + '[ , , , mailbox-get-timeout swap call ] + [ drop ] recover ; inline : handle-reader-message ( irc-message -- ) - irc-client> in-messages>> mailbox-put ; + irc> in-messages>> mailbox-put ; -: handle-stream-close ( -- ) - irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ; +DEFER: (connect-irc) + +: (handle-disconnect) ( -- ) + irc> + [ in-messages>> irc-disconnected swap mailbox-put ] + [ dup reconnect-time>> sleep (connect-irc) ] + [ profile>> nickname>> /LOGIN ] + tri ; + +: handle-disconnect ( error -- ) + drop irc> is-running>> [ (handle-disconnect) ] when ; + +: (reader-loop) ( -- ) + irc> stream>> [ + |dispose stream-readln [ + parse-irc-line handle-reader-message + ] [ + irc> terminate-irc + ] if* + ] with-destructors ; : reader-loop ( -- ) - irc-client> stream>> stream-readln-or-close [ - parse-irc-line handle-reader-message - ] [ - handle-stream-close - ] if* ; + [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc-client> out-messages>> mailbox-get handle-outgoing-irc ; + irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc-client> in-messages>> mailbox-get handle-incoming-irc ; + irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; -! FIXME: Hack, this should be handled better -GENERIC: add-name ( name obj -- obj ) -M: object add-name nip ; -M: privmsg add-name swap >>name ; - -: listener-loop ( name -- ) ! FIXME: take different values from the stack? - dup irc-client> listeners>> at [ - out-messages>> mailbox-get add-name - irc-client> out-messages>> - mailbox-put - ] [ drop ] if* ; +: strings>privmsg ( name string -- privmsg ) + privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; + +: maybe-annotate-with-name ( name obj -- obj ) + { + { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + } cond ; + +: listener-loop ( name listener -- ) + out-messages>> swap + '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] + irc-mailbox-get ; : spawn-irc-loop ( quot name -- ) - [ [ irc-client> is-running>> ] compose ] dip + [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -243,23 +292,33 @@ M: privmsg add-name swap >>name ; ! Listener join request handling ! ====================================== -: make-registered-listener ( join -- listener ) - swap trailing>> - dup [ listener-loop ] curry "listener" spawn-irc-loop - [ irc-client> listeners>> set-at ] curry keep ; +: set+run-listener ( name irc-listener -- ) + [ '[ , , listener-loop ] "listener" spawn-irc-loop ] + [ swap irc> listeners>> set-at ] + 2bi ; -: make-join-future ( name -- future ) - [ [ swap trailing>> = ] curry ! compare name with channel name - irc-client> join-messages>> 60 seconds rot mailbox-get-timeout? - make-registered-listener ] - curry future ; +GENERIC: (add-listener) ( irc-listener -- ) +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 ; -PRIVATE> +M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) + [ name>> ] keep set+run-listener ; + +M: irc-server-listener (add-listener) ( irc-server-listener -- ) + f swap set+run-listener ; : (connect-irc) ( irc-client -- ) - [ profile>> [ server>> ] keep port>> /CONNECT ] keep - swap >>stream - t >>is-running drop ; + [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep + swap >>stream + t >>is-running + in-messages>> irc-connected swap mailbox-put ; + +PRIVATE> : connect-irc ( irc-client -- ) dup current-irc-client [ @@ -267,9 +326,6 @@ PRIVATE> spawn-irc ] with-variable ; -: listen-to ( irc-client name -- future ) - swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ; - -! shorcut for privmsgs, etc -: sender>> ( obj -- string ) - prefix>> parse-name ; +GENERIC: add-listener ( irc-client irc-listener -- ) +M: irc-listener add-listener ( irc-client irc-listener -- ) + current-irc-client swap '[ , (add-listener) ] with-variable ;