steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

irc.client: Rename listeners to chats, rename some words, better handling of channel joins for chats attached before login, fixes, etc

db4
Bruno Deferrari 2008-10-05 21:18:58 -02:00
parent f12357e4e1
commit a712fd3d0b
3 changed files with 146 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
extra/irc/client/client-docs.factor
View File

@ -3,11 +3,11 @@ IN: irc.client
HELP: irc-client "IRC Client object" ; HELP: irc-client "IRC Client object" ;
HELP: irc-server-listener "Listener for server messages unmanaged by other listeners" ; HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-listener "Listener for irc channels" ; HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-listener "Listener for irc users" ; HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ; HELP: irc-profile "IRC Client profile object" ;
@ -15,48 +15,43 @@ HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } } { $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; { $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" HELP: attach-chat "Chatting with irc channels/users/etc"
{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } } { $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ; { $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ;
HELP: join-irc-channel "Joining channels" HELP: dettach-chat "Stop an unregister chat"
{ $values { "irc-client-listener" "an irc client listener object" } } { $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
{ $description "Joins to the channel being listened by " { $snippet "irc-listener" } "." } ; { $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
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: terminate-irc "Terminates an irc client" HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } } { $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" HELP: speak "Sends a message through a chat"
{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } } { $values { "message" "a string or irc message object" } { "irc-chat" "an irc chat object" } }
{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ; { $description "Sends " { $snippet "message" } " through " { $snippet "irc-chat" } ". Strings are automatically promoted to privmsg objects." } ;
HELP: read-message "Reads a message from a listener" HELP: hear "Reads a message from a chat"
{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } } { $values { "irc-chat" "an irc chat object" } { "message" "an irc message object" } }
{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ; { $description "Reads " { $snippet "message" } " from " { $snippet "irc-chat" } "." } ;
ARTICLE: "irc.client" "IRC Client" ARTICLE: "irc.client" "IRC Client"
"An IRC Client library" "An IRC Client library"
{ $heading "IRC objects:" } { $heading "IRC objects:" }
{ $subsection irc-client } { $subsection irc-client }
{ $heading "Listener objects:" } { $heading "Chat objects:" }
{ $subsection irc-server-listener } { $subsection irc-server-chat }
{ $subsection irc-channel-listener } { $subsection irc-channel-chat }
{ $subsection irc-nick-listener } { $subsection irc-nick-chat }
{ $heading "Setup objects:" } { $heading "Setup objects:" }
{ $subsection irc-profile } { $subsection irc-profile }
{ $heading "Words:" } { $heading "Words:" }
{ $subsection connect-irc } { $subsection connect-irc }
{ $subsection terminate-irc } { $subsection terminate-irc }
{ $subsection add-listener } { $subsection attach-chat }
{ $subsection remove-listener } { $subsection dettach-chat }
{ $subsection join-irc-channel } { $subsection hear }
{ $subsection read-message } { $subsection speak }
{ $subsection write-message }
{ $heading "IRC messages" } { $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:" "Some of the RFC defined irc messages as objects:"
{ $table { $table
@ -77,10 +72,10 @@ ARTICLE: "irc.client" "IRC Client"
{ $heading "Special messages" } { $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server." "Some special messages that are created by the library and not by the irc server."
{ $table { $table
{ { $link irc-listener-end } "sent to a listener when it has been dettached from the client, the listener should stop after it receives this message. " } { { $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, listeners 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 listeners that connection was lost." } { { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" } { $heading "Example:" }
{ $code { $code
@ -91,16 +86,14 @@ ARTICLE: "irc.client" "IRC Client"
"\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set" "\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set"
"! Connect to the server" "! Connect to the server"
"bot get connect-irc" "bot get connect-irc"
"! Create a channel listener" "! Create a channel chat"
"\"#mychannel123\" <irc-channel-listener> mychannel set" "\"#mychannel123\" <irc-channel-chat> mychannel set"
"! Register and start listener (this joins the channel)" "! Register and start chat (this joins the channel)"
"mychannel get bot get add-listener" "mychannel get bot get attach-chat"
"! Join to the channel"
"mychannel get join-irc-channel"
"! Send a message to the channel" "! 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" "! Read a message from the channel"
"mychannel get read-message" "mychannel get hear"
} }
; ;

54
extra/irc/client/client-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel tools.test accessors arrays sequences qualified 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 calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ; concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ; EXCLUDE: irc.messages => join ;
@ -19,22 +19,23 @@ M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
M: mb-writer stream-nl ( mb-writer -- ) M: mb-writer stream-nl ( mb-writer -- )
[ [ last-line>> concat ] [ lines>> ] bi push ] keep [ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ; V{ } clone >>last-line drop ;
M: mb-reader dispose drop ;
M: mb-writer dispose drop ;
: spawn-client ( -- irc-client ) : spawn-client ( -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> "someserver" irc-port "factorbot" f <irc-profile>
<irc-client> <irc-client>
t >>is-ready
t >>is-running t >>is-running
<test-stream> >>stream <test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ; dup [ spawn-irc yield ] with-irc-client ;
! to be used inside with-irc-client quotations ! to be used inside with-irc-client quotations
: %add-named-listener ( listener -- ) irc> add-listener ; : %add-named-chat ( chat -- ) irc> attach-chat ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: %join ( channel -- ) : %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
<irc-channel-listener>
[ irc> add-listener ] [ join-irc-channel ] bi ;
: 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? ; [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- ) : with-irc ( quot: ( -- ) -- )
@ -68,7 +69,8 @@ M: mb-writer stream-nl ( mb-writer -- )
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client> "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
[ 2drop <test-stream> t ] >>connect [ 2drop <test-stream> t ] >>connect
[ connect-irc ] keep stream>> out>> lines>> [ connect-irc ] keep
stream>> [ in>> [ f ] dip push-line ] [ out>> lines>> ] bi
] unit-test ] unit-test
! Test join ! Test join
@ -79,7 +81,7 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { join_ "#factortest" } [ [ { join_ "#factortest" } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
@ -91,14 +93,14 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { T{ participant-changed f "somebody" +join+ } } [ [ { T{ participant-changed f "somebody" +join+ } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message [ participant-changed? ] read-matching-message
] unit-test ] unit-test
] with-irc ] with-irc
[ { privmsg "#factortest" "hello" } [ [ { privmsg "#factortest" "hello" } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message [ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
@ -106,7 +108,7 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { privmsg "factorbot" "hello" } [ [ { privmsg "factorbot" "hello" } [
"ircuser" <irc-nick-listener> [ %add-named-listener ] keep "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message [ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
@ -114,7 +116,7 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { mode } [ [ { mode } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line ":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class [ mode? ] read-matching-message class
] unit-test ] unit-test
@ -122,46 +124,46 @@ M: mb-writer stream-nl ( mb-writer -- )
! Participant lists tests ! Participant lists tests
[ { H{ { "ircuser" +normal+ } } } [ [ { H{ { "ircuser" +normal+ } } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser!n=user@isp.net PART #factortest" %push-line ":ircuser!n=user@isp.net PART #factortest" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line ":ircuser!n=user@isp.net QUIT" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>> participants>>
] unit-test ] unit-test
@ -169,7 +171,7 @@ M: mb-writer stream-nl ( mb-writer -- )
! Namelist change notification ! Namelist change notification
[ { T{ participant-changed f f f f } } [ [ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message [ participant-changed? ] read-matching-message
@ -177,18 +179,18 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { T{ participant-changed f "ircuser" +part+ f } } [ [ { T{ participant-changed f "ircuser" +part+ f } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line ":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message [ participant-changed? ] read-matching-message
] unit-test ] unit-test
] with-irc ] with-irc
[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [ [ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message [ participant-changed? ] read-matching-message
] unit-test ] unit-test

167
extra/irc/client/client.factor
View File

@ -18,16 +18,16 @@ TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages TUPLE: irc-client profile stream in-messages out-messages
listeners is-running nick connect reconnect-time ; chats is-running nick connect reconnect-time is-ready ;
: <irc-client> ( profile -- irc-client ) : <irc-client> ( profile -- irc-client )
[ f <mailbox> <mailbox> H{ } clone f ] keep nickname>> [ f <mailbox> <mailbox> H{ } clone f ] keep nickname>>
[ <inet> latin1 <client> ] 15 seconds irc-client boa ; [ <inet> latin1 <client> ] 15 seconds f irc-client boa ;
TUPLE: irc-listener in-messages client ; TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-listener < irc-listener ; TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-channel-chat < irc-chat name password timeout participants ;
TUPLE: irc-nick-listener < irc-listener name ; TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-listener+ SYMBOL: +server-chat+
! participant modes ! participant modes
SYMBOL: +operator+ SYMBOL: +operator+
@ -43,18 +43,16 @@ SYMBOL: +part+
SYMBOL: +mode+ SYMBOL: +mode+
SYMBOL: +nick+ SYMBOL: +nick+
! listener objects ! chat objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ; : <irc-server-chat> ( -- irc-server-chat )
<mailbox> f irc-server-chat boa ;
: <irc-server-listener> ( -- irc-server-listener ) : <irc-channel-chat> ( name -- irc-channel-chat )
<mailbox> f irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
[ <mailbox> f ] dip f 60 seconds H{ } clone [ <mailbox> f ] dip f 60 seconds H{ } clone
irc-channel-listener boa ; irc-channel-chat boa ;
: <irc-nick-listener> ( name -- irc-nick-listener ) : <irc-nick-chat> ( name -- irc-nick-chat )
[ <mailbox> f ] dip irc-nick-listener boa ; [ <mailbox> f ] dip irc-nick-chat boa ;
! ====================================== ! ======================================
! Message objects ! Message objects
@ -63,15 +61,15 @@ SYMBOL: +nick+
TUPLE: participant-changed nick action parameter ; TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed C: <participant-changed> 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-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established SINGLETON: irc-connected ! sent when connection is established
SINGLETON: irc-ready ! sent after the client is logged in
: terminate-irc ( irc-client -- ) : terminate-irc ( irc-client -- )
[ is-running>> ] keep and [ [ is-running>> ] keep and [
f >>is-running f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array [ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each [ irc-end swap mailbox-put ] each
] when* ; ] when* ;
@ -85,66 +83,65 @@ SYMBOL: current-irc-client
! ====================================== ! ======================================
: irc> ( -- irc-client ) current-irc-client get ; : irc> ( -- irc-client ) current-irc-client get ;
: irc-stream> ( -- stream ) irc> stream>> ; : irc-write ( s -- ) irc> stream>> stream-write ;
: irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : 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? ; : channel-mode? ( mode -- ? ) name>> first "#&" member? ;
: me? ( string -- ? ) irc> nick>> = ; : me? ( string -- ? ) irc> nick>> = ;
GENERIC: to-listener ( message obj -- ) GENERIC: to-chat ( message obj -- )
M: string to-listener M: string to-chat
listener> [ +server-listener+ listener> ] unless* chat> [ +server-chat+ chat> ] unless*
[ to-listener ] [ drop ] if* ; [ to-chat ] [ drop ] if* ;
M: irc-listener to-listener in-messages>> mailbox-put ; M: irc-chat to-chat in-messages>> mailbox-put ;
: unregister-listener ( name -- ) : unregister-chat ( name -- )
irc> listeners>> irc> chats>>
[ at [ irc-listener-end ] dip to-listener ] [ at [ irc-chat-end ] dip to-chat ]
[ delete-at ] [ delete-at ]
2bi ; 2bi ;
: (remove-participant) ( nick listener -- ) : (remove-participant) ( nick chat -- )
[ participants>> delete-at ] [ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ; [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- ) : remove-participant ( nick channel -- )
listener> [ (remove-participant) ] [ drop ] if* ; chat> [ (remove-participant) ] [ drop ] if* ;
: listeners-with-participant ( nick -- seq ) : chats-with-participant ( nick -- seq )
irc> listeners>> values irc> chats>> values
[ [ irc-channel-listener? ] keep and [ participants>> key? ] [ drop f ] if* ] [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ; with filter ;
: to-listeners-with-participant ( message nickname -- ) : to-chats-with-participant ( message nickname -- )
listeners-with-participant [ to-listener ] with each ; chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- ) : 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 [ participant-changed new +nick+ >>action
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ; [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
: rename-participant ( newnick oldnick listener -- ) : rename-participant ( newnick oldnick chat -- )
[ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ] [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ; [ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- ) : 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 -- ) : add-participant ( mode nick channel -- )
listener> chat>
[ participants>> set-at ] [ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ; [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- ) : change-participant-mode ( channel mode nick -- )
rot listener> rot chat>
[ participants>> set-at ] [ participants>> set-at ]
[ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME [ [ [ +mode+ ] dip <participant-changed> ] dip to-chat ] 3bi ; ! FIXME
DEFER: me? DEFER: me?
@ -174,6 +171,10 @@ DEFER: me?
! Server message handling ! 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 ) GENERIC: forward-name ( irc-message -- name )
M: join forward-name trailing>> ; M: join forward-name trailing>> ;
M: part forward-name channel>> ; M: part forward-name channel>> ;
@ -187,32 +188,34 @@ UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- ) GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message M: irc-message forward-message
+server-listener+ listener> [ to-listener ] [ drop ] if* ; +server-chat+ chat> [ to-chat ] [ drop ] if* ;
M: single-forward forward-message dup forward-name to-listener ; M: single-forward forward-message dup forward-name to-chat ;
M: multiple-forward forward-message M: multiple-forward forward-message
dup irc-message-sender to-listeners-with-participant ; dup irc-message-sender to-chats-with-participant ;
M: broadcast-forward forward-message M: broadcast-forward forward-message
irc> listeners>> values [ to-listener ] with each ; irc> chats>> values [ to-chat ] with each ;
GENERIC: process-message ( irc-message -- ) GENERIC: process-message ( irc-message -- )
M: object process-message drop ; M: object process-message drop ;
M: logged-in process-message name>> irc> (>>nick) ; M: logged-in process-message
name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
values [ initialize-chat ] each ;
M: ping process-message trailing>> /PONG ; M: ping process-message trailing>> /PONG ;
M: nick-in-use process-message name>> "_" append /NICK ; M: nick-in-use process-message name>> "_" append /NICK ;
M: join process-message M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup listener> [ add-participant ] [ 3drop ] if ; dup chat> [ add-participant ] [ 3drop ] if ;
M: part process-message M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ; [ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: kick process-message M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] [ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ; bi ;
M: quit process-message M: quit process-message
@ -235,9 +238,9 @@ M: nick process-message
[ >nick/mode 2array ] map >hashtable ; [ >nick/mode 2array ] map >hashtable ;
M: names-reply process-message M: names-reply process-message
[ names-reply>participants ] [ channel>> listener> ] bi [ [ names-reply>participants ] [ channel>> chat> ] bi [
[ (>>participants) ] [ (>>participants) ]
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi [ [ f f f <participant-changed> ] dip name>> to-chat ] bi
] [ drop ] if* ; ] [ drop ] if* ;
! ====================================== ! ======================================
@ -265,8 +268,8 @@ DEFER: (connect-irc)
tri ; tri ;
! FIXME: do something with the exception, store somewhere to help debugging ! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- ) : handle-disconnect ( error -- ? )
drop irc> is-running>> [ (handle-disconnect) ] when ; drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? ) : (reader-loop) ( -- ? )
irc> stream>> [ irc> stream>> [
@ -278,7 +281,7 @@ DEFER: (connect-irc)
] with-destructors ; ] with-destructors ;
: reader-loop ( -- ? ) : reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect t ] recover ; [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? ) : writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ; irc> out-messages>> mailbox-get handle-outgoing-irc ;
@ -300,7 +303,7 @@ DEFER: (connect-irc)
[ nip ] [ nip ]
} cond ; } cond ;
GENERIC: annotate-message ( listener object -- object ) GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ; M: object annotate-message nip ;
M: part annotate-message swap name>> >>channel ; M: part annotate-message swap name>> >>channel ;
M: privmsg annotate-message swap name>> >>name ; M: privmsg annotate-message swap name>> >>name ;
@ -312,25 +315,27 @@ M: string annotate-message [ name>> ] dip strings>privmsg ;
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ; 3drop ;
GENERIC: (add-listener) ( irc-listener -- ) 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 ;
M: irc-listener (add-listener) M: irc-server-chat (attach-chat)
[ irc> >>client ] [ name>> ] bi irc> listeners>> set-at ; irc> >>client +server-chat+ irc> chats>> set-at ;
M: irc-server-listener (add-listener) GENERIC: (remove-chat) ( irc-chat -- )
irc> >>client +server-listener+ irc> listeners>> set-at ;
GENERIC: (remove-listener) ( irc-listener -- ) M: irc-nick-chat (remove-chat)
name>> unregister-chat ;
M: irc-nick-listener (remove-listener) M: irc-channel-chat (remove-chat)
name>> unregister-listener ;
M: irc-channel-listener (remove-listener)
[ part new annotate-message irc> out-messages>> mailbox-put ] keep [ part new annotate-message irc> out-messages>> mailbox-put ] keep
name>> unregister-listener ; name>> unregister-chat ;
M: irc-server-listener (remove-listener) M: irc-server-chat (remove-chat)
drop +server-listener+ unregister-listener ; drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- ) : (connect-irc) ( irc-client -- )
{ {
@ -348,16 +353,12 @@ PRIVATE>
: connect-irc ( irc-client -- ) : connect-irc ( irc-client -- )
dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
: add-listener ( irc-listener irc-client -- ) : attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
swap '[ _ (add-listener) ] with-irc-client ;
: remove-listener ( irc-listener -- ) : dettach-chat ( irc-chat -- )
[ client>> ] keep '[ _ (remove-listener) ] with-irc-client ; [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
: join-irc-channel ( irc-channel-listener -- ) : speak ( message irc-chat -- )
dup client>> [ [ name>> ] [ password>> ] bi /JOIN ] with-irc-client ;
: write-message ( message irc-listener -- )
[ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ; [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
: read-message ( irc-listener -- message ) in-messages>> mailbox-get ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ;