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

irc.client: Fixes, tests, etc

db4
Bruno Deferrari 2008-07-26 15:32:16 -03:00
parent bf9bf85a72
commit b855b098a7
4 changed files with 145 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
USING: kernel tools.test accessors arrays sequences qualified USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs ; concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ; EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_ RENAME: join irc.messages => join_
IN: irc.client.tests IN: irc.client.tests
@ -11,16 +11,16 @@ IN: irc.client.tests
"\n" join <string-reader> <string-writer> <duplex-stream> ; "\n" join <string-reader> <string-writer> <duplex-stream> ;
: make-client ( lines -- irc-client ) : make-client ( lines -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> <irc-client> "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
swap [ 2nip <test-stream> f ] curry >>connect ; swap [ 2nip <test-stream> f ] curry >>connect ;
: set-nick ( irc-client nickname -- ) : set-nick ( irc-client nickname -- )
swap profile>> (>>nickname) ; swap profile>> (>>nickname) ;
: with-dummy-client ( quot -- ) : with-dummy-client ( irc-client quot -- )
rot with-variable ; inline [ current-irc-client ] dip with-variable ; inline
{ "" } make-client dup "factorbot" set-nick current-irc-client [ { "" } make-client dup "factorbot" set-nick [
{ t } [ irc> profile>> nickname>> me? ] unit-test { t } [ irc> profile>> nickname>> me? ] unit-test
{ "factorbot" } [ irc> profile>> nickname>> ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test
@ -32,55 +32,72 @@ IN: irc.client.tests
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line irc-message-origin ] unit-test parse-irc-line irc-message-origin ] unit-test
] with-variable ] with-dummy-client
! Test login and nickname set ! Test login and nickname set
{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." { "factorbot" } [
"NOTICE AUTH :*** Checking ident" { "NOTICE AUTH :*** Looking up your hostname..."
"NOTICE AUTH :*** Found your hostname" "NOTICE AUTH :*** Checking ident"
"NOTICE AUTH :*** No identd (auth) response" "NOTICE AUTH :*** Found your hostname"
":some.where 001 factorbot :Welcome factorbot" "NOTICE AUTH :*** No identd (auth) response"
} make-client ":some.where 001 factorbot :Welcome factorbot"
[ connect-irc ] keep 1 seconds sleep } make-client
profile>> nickname>> ] unit-test { [ connect-irc ]
[ drop 1 seconds sleep ]
[ profile>> nickname>> ]
[ terminate-irc ]
} cleave ] unit-test
{ join_ "#factortest" } [ { join_ "#factortest" } [
{ ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net MODE #factortest +ns" ":ircserver.net MODE #factortest +ns"
":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."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} make-client dup "factorbot" set-nick } make-client
[ connect-irc ] keep 1 seconds sleep { [ "factorbot" set-nick ]
join-messages>> 1 seconds mailbox-get-timeout [ connect-irc ]
[ class ] [ trailing>> ] bi ] unit-test [ drop 1 seconds sleep ]
[ join-messages>> 1 seconds mailbox-get-timeout ]
[ terminate-irc ]
} cleave
[ class ] [ trailing>> ] bi ] unit-test
{ +join+ "somebody" } [ { +join+ "somebody" } [
{ ":somebody!n=somebody@some.where JOIN :#factortest" { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client
} make-client dup "factorbot" set-nick { [ "factorbot" set-nick ]
[ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] [ listeners>>
[ connect-irc ] [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ listeners>> [ "#factortest" ] dip at [ connect-irc ]
[ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri [ listeners>> [ "#factortest" ] dip at
[ action>> ] [ nick>> ] bi [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
] unit-test [ terminate-irc ]
} cleave
[ action>> ] [ nick>> ] bi
] unit-test
{ privmsg "#factortest" "hello" } [ { privmsg "#factortest" "hello" } [
{ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client
} make-client dup "factorbot" set-nick { [ "factorbot" set-nick ]
[ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] [ listeners>>
[ connect-irc ] [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ listeners>> [ "#factortest" ] dip at [ connect-irc ]
[ read-message drop ] [ read-message ] bi ] tri [ listeners>> [ "#factortest" ] dip at
[ class ] [ name>> ] [ trailing>> ] tri [ read-message drop ] [ read-message ] bi ]
] unit-test [ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
{ privmsg "factorbot" "hello" } [ { privmsg "factorbot" "hello" } [
{ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client
} make-client dup "factorbot" set-nick { [ "factorbot" set-nick ]
[ listeners>> [ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ] [ listeners>>
[ connect-irc ] [ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
[ listeners>> [ "somedude" ] dip at [ connect-irc ]
[ read-message drop ] [ read-message ] bi ] tri [ listeners>> [ "somedude" ] dip at
[ class ] [ name>> ] [ trailing>> ] tri [ read-message drop ] [ read-message ] bi ]
] unit-test [ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test

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

@ -12,8 +12,6 @@ IN: irc.client
! Setup and running objects ! Setup and running objects
! ====================================== ! ======================================
SYMBOL: current-irc-client
: irc-port 6667 ; ! Default irc port : irc-port 6667 ; ! Default irc port
TUPLE: irc-profile server port nickname password ; TUPLE: irc-profile server port nickname password ;
@ -71,13 +69,17 @@ SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: terminate-irc ( irc-client -- ) : terminate-irc ( irc-client -- )
[ [ irc-end ] dip in-messages>> mailbox-put ] [ is-running>> ] keep and [
[ [ f ] dip (>>is-running) ] [ [ irc-end ] dip in-messages>> mailbox-put ]
[ stream>> dispose ] [ [ f ] dip (>>is-running) ]
tri ; [ stream>> dispose ]
tri
] when* ;
<PRIVATE <PRIVATE
SYMBOL: current-irc-client
! ====================================== ! ======================================
! Utils ! Utils
! ====================================== ! ======================================
@ -88,7 +90,7 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: listener> ( name -- listener/f ) irc> listeners>> at ; : listener> ( name -- listener/f ) irc> listeners>> at ;
: maybe-mailbox-get ( mailbox quot -- ) : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
[ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- ) GENERIC: to-listener ( message obj -- )
@ -240,8 +242,8 @@ M: quit handle-incoming-irc ( quit -- )
[ to-listener ] with each ] [ to-listener ] with each ]
[ handle-participant-change ] [ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ] [ prefix>> parse-name remove-participant-from-all ]
[ ] [ call-next-method ]
} cleave call-next-method ; } cleave ;
: >nick/mode ( string -- nick mode ) : >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -266,12 +268,6 @@ GENERIC: handle-outgoing-irc ( obj -- )
M: irc-message handle-outgoing-irc ( irc-message -- ) M: irc-message handle-outgoing-irc ( irc-message -- )
irc-message>client-line irc-print ; irc-message>client-line irc-print ;
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
M: part handle-outgoing-irc ( part -- )
[ channel>> ] [ trailing>> "" or ] bi /PART ;
! ====================================== ! ======================================
! Reader/Writer ! Reader/Writer
! ====================================== ! ======================================
@ -283,7 +279,7 @@ DEFER: (connect-irc)
: (handle-disconnect) ( -- ) : (handle-disconnect) ( -- )
irc> irc>
[ [ irc-disconnected ] dip to-listener ] [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ] [ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ] [ profile>> nickname>> /LOGIN ]
tri ; tri ;
@ -318,10 +314,9 @@ DEFER: (connect-irc)
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
: maybe-annotate-with-name ( name obj -- obj ) : maybe-annotate-with-name ( name obj -- obj )
{ { { [ dup string? ] [ strings>privmsg ] }
{ [ dup string? ] [ strings>privmsg ] } { [ dup privmsg instance? ] [ swap >>name ] }
{ [ dup privmsg instance? ] [ swap >>name ] } [ nip ]
[ nip ]
} cond ; } cond ;
: listener-loop ( name -- ? ) : listener-loop ( name -- ? )
@ -331,7 +326,7 @@ DEFER: (connect-irc)
maybe-mailbox-get t maybe-mailbox-get t
] [ drop f ] if* ; ] [ drop f ] if* ;
: spawn-irc-loop ( quot name -- ) : spawn-irc-loop ( quot: ( -- ? ) name -- )
[ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
spawn-server drop ; spawn-server drop ;
@ -383,16 +378,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
t >>is-running t >>is-running
in-messages>> [ irc-connected ] dip mailbox-put ; in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot -- ) : with-irc-client ( irc-client quot: ( -- ) -- )
[ current-irc-client ] dip with-variable ; inline [ current-irc-client ] dip with-variable ; inline
PRIVATE> PRIVATE>
: connect-irc ( irc-client -- ) : connect-irc ( irc-client -- )
dup [ [ irc>
[ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
spawn-irc spawn-irc ] with-irc-client ;
] with-irc-client ;
: add-listener ( irc-listener irc-client -- ) : add-listener ( irc-listener irc-client -- )
swap '[ , (add-listener) ] with-irc-client ; swap '[ , (add-listener) ] with-irc-client ;

10
extra/irc/messages/messages-tests.factor
View File

@ -35,3 +35,13 @@ join new
[ ":someuser!n=user@some.where JOIN :#factortest" [ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test parse-irc-line f >>timestamp ] unit-test
mode new
":ircserver.net MODE #factortest +ns" >>line
"ircserver.net" >>prefix
"MODE" >>command
{ "#factortest" "+ns" } >>parameters
"#factortest" >>channel
"+ns" >>mode
1array
[ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test

68
extra/irc/messages/messages.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Bruno Deferrari ! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators qualified USING: kernel fry splitting ascii calendar accessors combinators qualified
arrays classes.tuple math.order ; arrays classes.tuple math.order quotations ;
RENAME: join sequences => sjoin RENAME: join sequences => sjoin
EXCLUDE: sequences => join ; EXCLUDE: sequences => join ;
IN: irc.messages IN: irc.messages
@ -17,7 +17,7 @@ TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ; TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: nick-in-use < irc-message asterisk name ;
TUPLE: notice < irc-message type ; TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name channel mode ; TUPLE: mode < irc-message channel mode ;
TUPLE: names-reply < irc-message who = channel ; TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ; TUPLE: unhandled < irc-message ;
@ -25,12 +25,42 @@ TUPLE: unhandled < irc-message ;
irc-message new now >>timestamp irc-message new now >>timestamp
[ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
<PRIVATE
GENERIC: irc-command-string ( irc-message -- string )
M: irc-message irc-command-string ( irc-message -- string ) command>> ;
M: ping irc-command-string ( ping -- string ) drop "PING" ;
M: join irc-command-string ( join -- string ) drop "JOIN" ;
M: part irc-command-string ( part -- string ) drop "PART" ;
M: quit irc-command-string ( quit -- string ) drop "QUIT" ;
M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
M: notice irc-command-string ( notice -- string ) drop "NOTICE" ;
M: mode irc-command-string ( mode -- string ) drop "MODE" ;
M: kick irc-command-string ( kick -- string ) drop "KICK" ;
GENERIC: irc-command-parameters ( irc-message -- seq )
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
M: ping irc-command-parameters ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ;
M: part irc-command-parameters ( part -- seq ) name>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
M: notice irc-command-parameters ( norice -- seq ) type>> 1array ;
M: kick irc-command-parameters ( kick -- seq )
[ channel>> ] [ who>> ] bi 2array ;
M: mode irc-command-parameters ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string ) 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 ( irc-message -- string )
[ command>> ] [ irc-command-string ]
[ parameters>> " " sjoin ] [ irc-command-parameters " " sjoin ]
[ trailing>> dup [ CHAR: : prefix ] when ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ; tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string ) GENERIC: irc-message>server-line ( irc-message -- string )
@ -73,19 +103,19 @@ PRIVATE>
: parse-irc-line ( string -- message ) : parse-irc-line ( string -- message )
string>irc-message string>irc-message
dup command>> { dup command>> {
{ "PING" [ \ ping ] } { "PING" [ ping ] }
{ "NOTICE" [ \ notice ] } { "NOTICE" [ notice ] }
{ "001" [ \ logged-in ] } { "001" [ logged-in ] }
{ "433" [ \ nick-in-use ] } { "433" [ nick-in-use ] }
{ "353" [ \ names-reply ] } { "353" [ names-reply ] }
{ "JOIN" [ \ join ] } { "JOIN" [ join ] }
{ "PART" [ \ part ] } { "PART" [ part ] }
{ "PRIVMSG" [ \ privmsg ] } { "PRIVMSG" [ privmsg ] }
{ "QUIT" [ \ quit ] } { "QUIT" [ quit ] }
{ "MODE" [ \ mode ] } { "MODE" [ mode ] }
{ "KICK" [ \ kick ] } { "KICK" [ kick ] }
[ drop \ unhandled ] [ drop unhandled ]
} case } case
[ [ tuple-slots ] [ parameters>> ] bi append ] dip [ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ; [ all-slots over [ length ] bi@ min head >quotation ] keep
'[ @ , boa nip ] call ;