Merge branch 'master' of git://www.tiodante.com/git/factor

db4
erg 2008-10-06 14:33:07 -05:00
commit 12ffb52da6
7 changed files with 294 additions and 314 deletions

View File

@ -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 <irc-profile> <irc-client> bot set"
"! Connect to the server"
"bot get connect-irc"
"! Create a channel listener"
"\"#mychannel123\" <irc-channel-listener> mychannel set"
"! Register and start listener (this joins the channel)"
"mychannel get bot get add-listener"
"! Create a channel chat"
"\"#mychannel123\" <irc-channel-chat> 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"
}
;

View File

@ -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 <irc-profile>
<irc-client>
t >>is-ready
t >>is-running
<test-stream> >>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-channel-listener> irc> add-listener ;
: %add-named-chat ( chat -- ) irc> attach-chat ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: %join ( channel -- ) <irc-channel-chat> 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 <irc-profile> <irc-client>
[ 2drop <test-stream> 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" <irc-channel-chat> [ %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" <irc-channel-listener> [ %add-named-listener ] keep
"#factortest" <irc-channel-chat> [ %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" <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
[ 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" <irc-nick-listener> [ %add-named-listener ] keep
":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
"ircuser" <irc-nick-chat> [ %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" <irc-channel-listener> [ %add-named-listener ] keep
"#factortest" <irc-channel-chat> [ %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" <irc-channel-listener> [ %add-named-listener ] keep
":somedude!n=user@isp.net JOIN :#factortest" %push-line
[ { H{ { "ircuser" +normal+ } } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>>
] unit-test
] with-irc
[ { H{ { "somedude2" +normal+ } } } [
"#factortest" <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user@isp.net PART #factortest" %push-line
[ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-chat>
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" <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user@isp.net QUIT" %push-line
[ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-chat>
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" <irc-channel-listener>
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" <irc-channel-chat>
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" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user2@isp.net NICK :somedude2" %push-line
[ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-chat>
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" <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 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" <irc-channel-listener>
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" <irc-channel-chat>
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" <irc-channel-listener>
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" <irc-channel-chat>
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

View File

@ -17,17 +17,17 @@ IN: irc.client
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> 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 ;
: <irc-client> ( profile -- irc-client )
f <mailbox> <mailbox> <mailbox> H{ } clone f
[ <inet> latin1 <client> ] 15 seconds irc-client boa ;
[ f <mailbox> <mailbox> H{ } clone f ] keep nickname>>
[ <inet> latin1 <client> ] 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 ) <mailbox> <mailbox> irc-listener boa ;
! chat objects
: <irc-server-chat> ( -- irc-server-chat )
<mailbox> f irc-server-chat boa ;
: <irc-server-listener> ( -- irc-server-listener )
<mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-chat> ( name -- irc-channel-chat )
[ <mailbox> f ] dip f 60 seconds H{ } clone
irc-channel-chat boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
[ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener )
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
: <irc-nick-chat> ( name -- irc-nick-chat )
[ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
@ -63,22 +61,17 @@ SYMBOL: +nick+
TUPLE: participant-changed nick action parameter ;
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-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
<PRIVATE
: end-loops ( irc-client -- )
[ listeners>> 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* ;
<PRIVATE
@ -90,74 +83,68 @@ SYMBOL: current-irc-client
! ======================================
: 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 ;
: 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 <participant-changed> ] dip to-listener ] 2bi ;
[ [ +part+ f <participant-changed> ] 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 <participant-changed> ] dip to-listener ] 2bi ;
[ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
rot listener>
rot chat>
[ participants>> set-at ]
[ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
[ [ [ +mode+ ] dip <participant-changed> ] 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 <participant-changed> ] dip name>> to-listener ] bi
[ [ f f f <participant-changed> ] 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 ;

View File

@ -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

View File

@ -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" ;
<PRIVATE
! ======================================
@ -124,8 +120,7 @@ PRIVATE>
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

View File

@ -8,7 +8,7 @@ IN: irc.ui.commands
: say ( string -- )
irc-tab get
[ window>> client>> profile>> nickname>> <own-message> 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-client-message>
irc-tab get listener>> write-message ;
irc-tab get listener>> speak ;
: quote ( string -- )
drop ; ! THIS WILL CHANGE

View File

@ -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 ;
: <irc-pane> ( 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
<irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @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 ;
: <irc-channel-tab> ( listener ui-window -- irc-tab )
: <irc-channel-tab> ( chat ui-window -- irc-tab )
irc-channel-tab new-irc-tab
<pile> [ <scroller> @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 ;
: <irc-server-tab> ( listener -- irc-tab )
: <irc-server-tab> ( chat -- irc-tab )
f irc-server-tab new-irc-tab ;
: <irc-nick-tab> ( listener ui-window -- irc-tab )
: <irc-nick-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 <irc-channel-listener> ] dip
[ dup <irc-channel-chat> ] dip
[ <irc-channel-tab> swap ] keep
add-page ;
: query-nick ( nick ui-window -- )
[ dup <irc-nick-listener> ] dip
[ dup <irc-nick-chat> ] dip
[ <irc-nick-tab> swap ] keep
add-page ;
@ -232,8 +232,8 @@ M: irc-tab pref-dim*
: ui-connect ( profile -- ui-window )
<irc-client>
{ [ [ <irc-server-listener> ] dip add-listener ]
[ listeners>> +server-listener+ swap at <irc-server-tab> dup
{ [ [ <irc-server-chat> ] dip attach-chat ]
[ chats>> +server-chat+ swap at <irc-server-tab> dup
"Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
[ >>client ]
[ connect-irc ] } cleave ;