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

Merge branch 'master' of git://factorforge.org/git/william42

db4
Slava Pestov 2008-08-01 17:22:17 -05:00
parent 8e58db1514 804a76afc8
commit c6f51c11bd
5 changed files with 309 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
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,39 +32,144 @@ 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 0.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 0.1 seconds sleep ]
[ join-messages>> 0.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 ]
! TODO: channel message } cleave
! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" [ action>> ] [ nick>> ] bi
! TODO: direct private message ] unit-test
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
{ privmsg "#factortest" "hello" } [
{ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
{ privmsg "factorbot" "hello" } [
{ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ listeners>> [ "somedude" ] dip at
[ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
! Participants lists tests
{ H{ { "somedude" +normal+ } } } [
{ ":somedude!n=user@isp.net JOIN :#factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net PART #factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net QUIT" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
! Namelist notification
{ T{ participant-changed f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
] unit-test

107
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 ;
@ -51,7 +49,8 @@ SYMBOL: +mode+
<mailbox> <mailbox> irc-server-listener boa ; <mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener ) : <irc-channel-listener> ( name -- irc-channel-listener )
[ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ; [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener ) : <irc-nick-listener> ( name -- irc-nick-listener )
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ; [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
@ -63,19 +62,24 @@ SYMBOL: +mode+
TUPLE: participant-changed nick action ; TUPLE: participant-changed nick action ;
C: <participant-changed> participant-changed C: <participant-changed> participant-changed
SINGLETON: irc-listener-end ! send to a listener 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
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
! ====================================== ! ======================================
@ -85,7 +89,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: 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 ;
: listener> ( name -- listener/f ) irc> listeners>> at ; : listener> ( name -- listener/f ) irc> listeners>> at ;
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
[ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- ) GENERIC: to-listener ( message obj -- )
@ -93,6 +99,12 @@ M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless* listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ; [ to-listener ] [ drop ] if* ;
: unregister-listener ( name -- )
irc> listeners>>
[ at [ irc-listener-end ] dip to-listener ]
[ delete-at ]
2bi ;
M: irc-listener to-listener ( message irc-listener -- ) M: irc-listener to-listener ( message irc-listener -- )
in-messages>> mailbox-put ; in-messages>> mailbox-put ;
@ -105,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- )
with filter ; with filter ;
: remove-participant-from-all ( nick -- ) : remove-participant-from-all ( nick -- )
dup listeners-with-participant [ delete-at ] with each ; dup listeners-with-participant [ participants>> delete-at ] with each ;
: add-participant ( mode nick channel -- ) : add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ; listener> [ participants>> set-at ] [ 2drop ] if* ;
@ -206,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ; dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
{ [ maybe-forward-join ] ! keep { [ maybe-forward-join ]
[ dup trailing>> to-listener ] [ dup trailing>> to-listener ]
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ] [ handle-participant-change ]
} cleave ; } cleave ;
@ -219,19 +231,18 @@ M: part handle-incoming-irc ( part -- )
tri ; tri ;
M: kick handle-incoming-irc ( kick -- ) M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ] { [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ] [ handle-participant-change ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] [ dup who>> me? [ unregister-listener ] [ drop ] if ]
} cleave ; } cleave ;
M: quit handle-incoming-irc ( quit -- ) M: quit handle-incoming-irc ( quit -- )
{ [ dup prefix>> parse-name listeners-with-participant [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ] [ to-listener ] with each ]
[ handle-participant-change ] [ prefix>> parse-name remove-participant-from-all ]
[ prefix>> parse-name remove-participant-from-all ] [ handle-participant-change ]
[ ] tri ;
} cleave call-next-method ;
: >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 ;
@ -241,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- )
[ >nick/mode 2array ] map >hashtable ; [ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- ) M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ] [ drop ] if* ; [ (>>participants) ]
[ [ f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ; broadcast-message-to-listeners ;
@ -256,12 +269,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
! ====================================== ! ======================================
@ -273,7 +280,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 ;
@ -291,35 +298,37 @@ DEFER: (connect-irc)
] if* ] if*
] with-destructors ; ] with-destructors ;
: reader-loop ( -- ) : reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect ] recover ; [ (reader-loop) ] [ handle-disconnect ] recover t ;
: writer-loop ( -- ) : writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ; irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
! ====================================== ! ======================================
! Processing loops ! Processing loops
! ====================================== ! ======================================
: in-multiplexer-loop ( -- ) : in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get handle-incoming-irc ; irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
: strings>privmsg ( name string -- privmsg ) : strings>privmsg ( name string -- privmsg )
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 -- ) : listener-loop ( name -- ? )
out-messages>> mailbox-get maybe-annotate-with-name dup listener> [
irc> out-messages>> mailbox-put ; out-messages>> [ maybe-annotate-with-name
irc> out-messages>> mailbox-put ] with
maybe-mailbox-get t
] [ drop f ] if* ;
: spawn-irc-loop ( quot name -- ) : spawn-irc-loop ( quot: ( -- ? ) name -- )
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
spawn-server drop ; spawn-server drop ;
: spawn-irc ( -- ) : spawn-irc ( -- )
@ -332,9 +341,8 @@ DEFER: (connect-irc)
! ====================================== ! ======================================
: set+run-listener ( name irc-listener -- ) : set+run-listener ( name irc-listener -- )
[ '[ , , listener-loop ] "listener" spawn-irc-loop ] over irc> listeners>> set-at
[ swap irc> listeners>> set-at ] '[ , listener-loop ] "listener" spawn-irc-loop ;
2bi ;
GENERIC: (add-listener) ( irc-listener -- ) GENERIC: (add-listener) ( irc-listener -- )
@ -371,16 +379,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 ;

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

@ -35,3 +35,23 @@ 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
nick new
":someuser!n=user@some.where NICK :someuser2" >>line
"someuser!n=user@some.where" >>prefix
"NICK" >>command
{ } >>parameters
"someuser2" >>trailing
1array
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test

72
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
@ -12,12 +12,13 @@ TUPLE: ping < irc-message ;
TUPLE: join < irc-message ; TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ; TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ; TUPLE: quit < irc-message ;
TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ; TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ; 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 +26,44 @@ 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: nick irc-command-string ( nick -- string ) drop "NICK" ;
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: nick irc-command-parameters ( nick -- 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 +106,20 @@ 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 ] } { "NICK" [ nick ] }
{ "QUIT" [ \ quit ] } { "PRIVMSG" [ privmsg ] }
{ "MODE" [ \ mode ] } { "QUIT" [ quit ] }
{ "KICK" [ \ kick ] } { "MODE" [ mode ] }
[ drop \ unhandled ] { "KICK" [ kick ] }
[ 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 ;

64
extra/irc/ui/ui.factor
View File

@ -5,10 +5,12 @@ USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
io io.styles namespaces calendar calendar.format models io io.styles namespaces calendar calendar.format models continuations
irc.client irc.client.private irc.messages irc.messages.private irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load ; irc.ui.commandparser irc.ui.load qualified ;
RENAME: join sequences => sjoin
IN: irc.ui IN: irc.ui
@ -18,7 +20,7 @@ SYMBOL: client
TUPLE: ui-window client tabs ; TUPLE: ui-window client tabs ;
TUPLE: irc-tab < frame listener client listmodel ; TUPLE: irc-tab < frame listener client userlist ;
: write-color ( str color -- ) : write-color ( str color -- )
foreground associate format ; foreground associate format ;
@ -71,14 +73,21 @@ M: quit write-irc
" has left IRC" red write-color " has left IRC" red write-color
trailing>> dot-or-parens red write-color ; trailing>> dot-or-parens red write-color ;
: full-mode ( message -- mode )
parameters>> rest " " sjoin ;
M: mode write-irc M: mode write-irc
"* " blue write-color "* " blue write-color
[ name>> write ] keep [ prefix>> parse-name write ] keep
" has applied mode " blue write-color " has applied mode " blue write-color
[ mode>> write ] keep [ full-mode write ] keep
" to " blue write-color " to " blue write-color
channel>> write ; channel>> write ;
M: unhandled write-irc
"UNHANDLED: " write
line>> blue write-color ;
M: irc-end write-irc M: irc-end write-irc
drop "* You have left IRC" red write-color ; drop "* You have left IRC" red write-color ;
@ -88,11 +97,17 @@ M: irc-disconnected write-irc
M: irc-connected write-irc M: irc-connected write-irc
drop "* Connected" green write-color ; drop "* Connected" green write-color ;
M: irc-listener-end write-irc
drop ;
M: irc-message write-irc M: irc-message write-irc
drop ; ! catch all unimplemented writes, THIS WILL CHANGE drop ; ! catch all unimplemented writes, THIS WILL CHANGE
: time-happened ( irc-message -- timestamp )
[ timestamp>> ] [ 2drop now ] recover ;
: print-irc ( irc-message -- ) : print-irc ( irc-message -- )
[ timestamp>> timestamp>hms write " " write ] [ time-happened timestamp>hms write " " write ]
[ write-irc nl ] bi ; [ write-irc nl ] bi ;
: send-message ( message -- ) : send-message ( message -- )
@ -101,16 +116,15 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- ) GENERIC: handle-inbox ( tab message -- )
: filter-participants ( assoc val -- alist ) : filter-participants ( pack alist val color -- )
[ >alist ] dip '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
'[ second , = ] filter ;
: update-participants ( tab -- ) : update-participants ( tab -- )
[ listmodel>> ] [ listener>> participants>> ] bi [ userlist>> [ clear-gadget ] keep ]
[ +operator+ filter-participants ] [ listener>> participants>> ] bi
[ +voice+ filter-participants ] [ +operator+ green filter-participants ]
[ +normal+ filter-participants ] tri [ +voice+ blue filter-participants ]
append append swap set-model ; [ +normal+ black filter-participants ] 2tri ;
M: participant-changed handle-inbox M: participant-changed handle-inbox
drop update-participants ; drop update-participants ;
@ -147,11 +161,6 @@ irc-editor "general" f {
{ T{ key-down f f "ENTER" } editor-send } { T{ key-down f f "ENTER" } editor-send }
} define-command-map } define-command-map
: <irc-list> ( -- gadget model )
[ drop ]
[ first2 [ <label> ] dip >>color ]
{ } <model> [ <list> ] keep ;
: <irc-tab> ( listener client -- irc-tab ) : <irc-tab> ( listener client -- irc-tab )
irc-tab new-frame irc-tab new-frame
swap client>> >>client swap >>listener swap client>> >>client swap >>listener
@ -160,19 +169,19 @@ irc-editor "general" f {
: <irc-channel-tab> ( listener client -- irc-tab ) : <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab> <irc-tab>
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel <pile> [ <scroller> @right grid-add ] keep >>userlist ;
[ update-participants ] keep ;
: <irc-server-tab> ( listener client -- irc-tab ) : <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ; <irc-tab> ;
M: irc-tab graft* M: irc-tab graft*
[ listener>> ] [ client>> ] bi [ listener>> ] [ client>> ] bi add-listener ;
add-listener ;
M: irc-tab ungraft* M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi [ listener>> ] [ client>> ] bi remove-listener ;
remove-listener ;
M: irc-tab pref-dim*
drop { 480 480 } ;
: join-channel ( name ui-window -- ) : join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip [ dup <irc-channel-listener> ] dip
@ -187,8 +196,9 @@ M: irc-tab ungraft*
: ui-connect ( profile -- ui-window ) : ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap <irc-client> ui-window new over >>client swap
[ connect-irc ] [ connect-irc ]
[ [ <irc-server-listener> ] dip add-listener ]
[ listeners>> +server-listener+ swap at over <irc-tab> [ listeners>> +server-listener+ swap at over <irc-tab>
"Server" associate <tabbed> >>tabs ] bi ; "Server" associate <tabbed> >>tabs ] tri ;
: server-open ( server port nick password channels -- ) : server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip [ <irc-profile> ui-connect [ irc-window ] keep ] dip