--- /dev/null
+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
+: <test-stream> ( lines -- stream )
+ "\n" join <string-reader> <string-writer> <duplex-stream> ;
+
+: make-client ( lines -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ swap [ 2nip <test-stream> 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
! 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 io
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
! ======================================
C: <nick> nick
TUPLE: irc-client profile nick stream in-messages out-messages join-messages
- listeners is-running ;
+ listeners is-running connect reconnect-time ;
: <irc-client> ( profile -- irc-client )
f V{ } clone V{ } clone <nick>
- f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+ f <mailbox> <mailbox> <mailbox> H{ } clone f
+ [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
TUPLE: irc-listener in-messages out-messages ;
-: <irc-listener> ( -- irc-listener )
- <mailbox> <mailbox> 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 ) <mailbox> <mailbox> irc-listener boa ;
+
+: <irc-server-listener> ( -- irc-server-listener )
+ <mailbox> <mailbox> irc-server-listener boa ;
+
+: <irc-channel-listener> ( name -- irc-channel-listener )
+ <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+
+: <irc-nick-listener> ( name -- irc-nick-listener )
+ <mailbox> <mailbox> 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 instantiated
+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 ;
TUPLE: mode < irc-message name channel mode ;
TUPLE: unhandled < irc-message ;
+: terminate-irc ( irc-client -- )
+ [ stream>> dispose ]
+ [ in-messages>> irc-end swap mailbox-put ]
+ [ f >>is-running drop ]
+ tri ;
+
<PRIVATE
! ======================================
! Shortcuts
! ======================================
-: irc-client> ( -- 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 ;
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
- <inet> latin1 <client> drop ;
+ irc> connect>> call drop ;
: /JOIN ( channel password -- )
"JOIN " irc-write
: /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
! ======================================
} 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 -- )
+ drop ;
+
+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
+ [ 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
! ======================================
+: irc-mailbox-get ( mailbox quot -- )
+ swap 5 seconds [ mailbox-get-timeout swap call ] 3curry [ drop ] recover ;
+
: stream-readln-or-close ( stream -- str/f )
dup stream-readln [ nip ] [ dispose f ] if* ;
: handle-reader-message ( irc-message -- )
- irc-client> in-messages>> mailbox-put ;
-
-: handle-stream-close ( -- )
- irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+ irc> in-messages>> mailbox-put ;
+
+DEFER: (connect-irc)
+: handle-disconnect ( error -- )
+ drop irc>
+ [ in-messages>> irc-disconnected swap mailbox-put ]
+ [ reconnect-time>> sleep (connect-irc) ]
+ [ profile>> nickname>> /LOGIN ]
+ tri ;
+
+: (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 ;
-
-! 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* ;
+ irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
+
+: maybe-annotate-with-name ( name obj -- obj )
+ dup privmsg instance? [ swap >>name ] [ nip ] if ;
+
+: listener-loop ( name listener -- )
+ out-messages>> mailbox-get maybe-annotate-with-name
+ irc> out-messages>> mailbox-put ;
: spawn-irc-loop ( quot name -- )
- [ [ irc-client> is-running>> ] compose ] dip
+ [ [ irc> is-running>> ] compose ] dip
spawn-server drop ;
: spawn-irc ( -- )
! Listener join request handling
! ======================================
-: make-registered-listener ( join -- listener )
- <irc-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 ] 2curry "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>> [ swap trailing>> = ] curry ]
+ 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 ;
: (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] keep port>> /CONNECT ] keep
- swap >>stream
- t >>is-running drop ;
+ swap >>stream
+ t >>is-running
+ in-messages>> irc-connected swap mailbox-put ;
+
+PRIVATE>
: connect-irc ( irc-client -- )
dup current-irc-client [
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) ] curry with-variable ;