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

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

db4
Slava Pestov 2008-09-21 19:16:41 -05:00
parent a9f2fbd4a2 b1b7fa11f0
commit 0a4a776d02
4 changed files with 161 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- )
[ [ last-line>> concat ] [ lines>> ] bi push ] keep [ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ; V{ } clone >>last-line drop ;
: spawn-client ( lines listeners -- irc-client ) : spawn-client ( -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> "someserver" irc-port "factorbot" f <irc-profile>
<irc-client> <irc-client>
t >>is-running t >>is-running

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

@ -68,12 +68,17 @@ 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
<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 -- ) : terminate-irc ( irc-client -- )
[ is-running>> ] keep and [ [ is-running>> ] keep and [
[ [ irc-end ] dip in-messages>> mailbox-put ] [ end-loops ] [ [ f ] dip (>>is-running) ] bi
[ [ f ] dip (>>is-running) ]
[ stream>> dispose ]
tri
] when* ; ] when* ;
<PRIVATE <PRIVATE
@ -90,7 +95,8 @@ SYMBOL: current-irc-client
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ; : listener> ( name -- listener/f ) irc> listeners>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
: me? ( string -- ? ) irc> profile>> nickname>> = ;
GENERIC: to-listener ( message obj -- ) GENERIC: to-listener ( message obj -- )
@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- )
swap dup listeners-with-participant [ rename-participant ] with with each ; swap dup listeners-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- ) : add-participant ( mode nick channel -- )
listener> [ listener>
[ participants>> set-at ] [ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
] [ 2drop ] if* ;
: change-participant-mode ( channel mode nick -- )
rot listener>
[ participants>> set-at ]
[ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
DEFER: me? DEFER: me?
@ -174,14 +184,11 @@ DEFER: me?
! Server message handling ! Server message handling
! ====================================== ! ======================================
: me? ( string -- ? )
irc> profile>> nickname>> = ;
GENERIC: forward-name ( irc-message -- name ) GENERIC: forward-name ( irc-message -- name )
M: join forward-name ( join -- name ) trailing>> ; M: join forward-name ( join -- name ) trailing>> ;
M: part forward-name ( part -- name ) channel>> ; M: part forward-name ( part -- name ) channel>> ;
M: kick forward-name ( kick -- name ) channel>> ; M: kick forward-name ( kick -- name ) channel>> ;
M: mode forward-name ( mode -- name ) channel>> ; M: mode forward-name ( mode -- name ) name>> ;
M: privmsg forward-name ( privmsg -- name ) M: privmsg forward-name ( privmsg -- name )
dup name>> me? [ irc-message-sender ] [ name>> ] if ; dup name>> me? [ irc-message-sender ] [ name>> ] if ;
@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- )
name>> "_" append /NICK ; name>> "_" append /NICK ;
M: join process-message ( join -- ) M: join process-message ( join -- )
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup listener> [ add-participant ] [ 3drop ] if ;
M: part process-message ( part -- ) M: part process-message ( part -- )
[ irc-message-sender ] [ channel>> ] bi remove-participant ; [ irc-message-sender ] [ channel>> ] bi remove-participant ;
@ -236,6 +244,12 @@ M: quit process-message ( quit -- )
M: nick process-message ( nick -- ) M: nick process-message ( nick -- )
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
! M: mode process-message ( mode -- )
! [ channel-mode? ] keep and [
! [ name>> ] [ mode>> ] [ parameter>> ] tri
! [ change-participant-mode ] [ 2drop ] if*
! ] when* ;
: >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 ;
@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- )
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ; ] [ drop ] if* ;
: handle-incoming-irc ( irc-message -- )
[ forward-message ] [ process-message ] bi ;
! ====================================== ! ======================================
! Client message handling ! Client message handling
! ====================================== ! ======================================
: handle-outgoing-irc ( irc-message -- ) GENERIC: handle-outgoing-irc ( irc-message -- ? )
irc-message>client-line irc-print ; 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 ;
! ====================================== ! ======================================
! Reader/Writer ! Reader/Writer
@ -279,27 +292,28 @@ DEFER: (connect-irc)
: handle-disconnect ( error -- ) : handle-disconnect ( error -- )
drop irc> is-running>> [ (handle-disconnect) ] when ; drop irc> is-running>> [ (handle-disconnect) ] when ;
: (reader-loop) ( -- ) : (reader-loop) ( -- ? )
irc> stream>> [ irc> stream>> [
|dispose stream-readln [ |dispose stream-readln [
parse-irc-line handle-reader-message parse-irc-line handle-reader-message t
] [ ] [
irc> terminate-irc irc> terminate-irc f
] if* ] if*
] with-destructors ; ] with-destructors ;
: reader-loop ( -- ? ) : reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect ] recover t ; [ (reader-loop) ] [ handle-disconnect t ] recover ;
: writer-loop ( -- ? ) : writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc t ; irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ====================================== ! ======================================
! Processing loops ! Processing loops
! ====================================== ! ======================================
: in-multiplexer-loop ( -- ? ) : in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get handle-incoming-irc t ; irc> in-messages>> mailbox-get
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg ) : strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@ -310,22 +324,22 @@ DEFER: (connect-irc)
[ nip ] [ nip ]
} cond ; } 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 -- ? ) : listener-loop ( name -- ? )
dup listener> [ dup listener> [
out-messages>> mailbox-get out-messages>> mailbox-get
maybe-annotate-with-name maybe-annotate-with-name handle-listener-out
irc> out-messages>> mailbox-put
t
] [ drop f ] if* ; ] [ drop f ] if* ;
: spawn-irc-loop ( quot: ( -- ? ) name -- )
[ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
spawn-server drop ;
: spawn-irc ( -- ) : spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-irc-loop [ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-irc-loop [ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ; [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
! ====================================== ! ======================================
! Listener join request handling ! Listener join request handling
@ -333,7 +347,7 @@ DEFER: (connect-irc)
: set+run-listener ( name irc-listener -- ) : set+run-listener ( name irc-listener -- )
over irc> listeners>> set-at over irc> listeners>> set-at
'[ _ listener-loop ] "listener" spawn-irc-loop ; '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
GENERIC: (add-listener) ( irc-listener -- ) GENERIC: (add-listener) ( irc-listener -- )

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

@ -6,54 +6,60 @@ IN: irc.messages.tests
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
irc-message new { T{ irc-message
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
"someuser!n=user@some.where" >>prefix { prefix "someuser!n=user@some.where" }
"PRIVMSG" >>command { command "PRIVMSG" }
{ "#factortest" } >>parameters { parameters { "#factortest" } }
"hi" >>trailing { trailing "hi" } } }
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test string>irc-message f >>timestamp ] unit-test
privmsg new { T{ privmsg
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
"someuser!n=user@some.where" >>prefix { prefix "someuser!n=user@some.where" }
"PRIVMSG" >>command { command "PRIVMSG" }
{ "#factortest" } >>parameters { parameters { "#factortest" } }
"hi" >>trailing { trailing "hi" }
"#factortest" >>name { name "#factortest" } } }
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test parse-irc-line f >>timestamp ] unit-test
join new { T{ join
":someuser!n=user@some.where JOIN :#factortest" >>line { line ":someuser!n=user@some.where JOIN :#factortest" }
"someuser!n=user@some.where" >>prefix { prefix "someuser!n=user@some.where" }
"JOIN" >>command { command "JOIN" }
{ } >>parameters { parameters { } }
"#factortest" >>trailing { trailing "#factortest" } } }
1array
[ ":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 { T{ mode
":ircserver.net MODE #factortest +ns" >>line { line ":ircserver.net MODE #factortest +ns" }
"ircserver.net" >>prefix { prefix "ircserver.net" }
"MODE" >>command { command "MODE" }
{ "#factortest" "+ns" } >>parameters { parameters { "#factortest" "+ns" } }
"#factortest" >>channel { name "#factortest" }
"+ns" >>mode { mode "+ns" } } }
1array
[ ":ircserver.net MODE #factortest +ns" [ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test parse-irc-line f >>timestamp ] unit-test
nick new { T{ mode
":someuser!n=user@some.where NICK :someuser2" >>line { line ":ircserver.net MODE #factortest +o someuser" }
"someuser!n=user@some.where" >>prefix { prefix "ircserver.net" }
"NICK" >>command { command "MODE" }
{ } >>parameters { parameters { "#factortest" "+o" "someuser" } }
"someuser2" >>trailing { name "#factortest" }
1array { mode "+o" }
{ parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
parse-irc-line f >>timestamp ] unit-test
{ T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" }
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2" [ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test parse-irc-line f >>timestamp ] unit-test

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

@ -1,9 +1,10 @@
! 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 quotations ; arrays classes.tuple math.order ;
RENAME: join sequences => sjoin RENAME: join sequences => sjoin
EXCLUDE: sequences => join ; EXCLUDE: sequences => join ;
EXCLUDE: inverse => _ ;
IN: irc.messages IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: irc-message line prefix command parameters trailing timestamp ;
@ -18,8 +19,8 @@ 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 channel mode ; TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who = channel ; TUPLE: names-reply < irc-message who channel ;
TUPLE: unhandled < irc-message ; TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message ) : <irc-client-message> ( command parameters trailing -- irc-message )
@ -28,41 +29,58 @@ TUPLE: unhandled < irc-message ;
<PRIVATE <PRIVATE
GENERIC: irc-command-string ( irc-message -- string ) GENERIC: command-string>> ( irc-message -- string )
M: irc-message irc-command-string ( irc-message -- string ) command>> ; M: irc-message command-string>> ( irc-message -- string ) command>> ;
M: ping irc-command-string ( ping -- string ) drop "PING" ; M: ping command-string>> ( ping -- string ) drop "PING" ;
M: join irc-command-string ( join -- string ) drop "JOIN" ; M: join command-string>> ( join -- string ) drop "JOIN" ;
M: part irc-command-string ( part -- string ) drop "PART" ; M: part command-string>> ( part -- string ) drop "PART" ;
M: quit irc-command-string ( quit -- string ) drop "QUIT" ; M: quit command-string>> ( quit -- string ) drop "QUIT" ;
M: nick irc-command-string ( nick -- string ) drop "NICK" ; M: nick command-string>> ( nick -- string ) drop "NICK" ;
M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
M: mode irc-command-string ( mode -- string ) drop "MODE" ; M: mode command-string>> ( mode -- string ) drop "MODE" ;
M: kick irc-command-string ( kick -- string ) drop "KICK" ; M: kick command-string>> ( kick -- string ) drop "KICK" ;
GENERIC: irc-command-parameters ( irc-message -- seq ) GENERIC: command-parameters>> ( irc-message -- seq )
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
M: ping irc-command-parameters ( ping -- seq ) drop { } ; M: ping command-parameters>> ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ; M: join command-parameters>> ( join -- seq ) drop { } ;
M: part irc-command-parameters ( part -- seq ) channel>> 1array ; M: part command-parameters>> ( part -- seq ) channel>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ; M: quit command-parameters>> ( quit -- seq ) drop { } ;
M: nick irc-command-parameters ( nick -- seq ) drop { } ; M: nick command-parameters>> ( nick -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
M: kick irc-command-parameters ( kick -- seq ) M: kick command-parameters>> ( kick -- seq )
[ channel>> ] [ who>> ] bi 2array ; [ channel>> ] [ who>> ] bi 2array ;
M: mode irc-command-parameters ( mode -- seq ) M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ; [ 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 -- )
[ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
M: names-reply (>>command-parameters) ( params names-reply -- )
[ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
M: mode (>>command-parameters) ( params mode -- )
{ { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
{ [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
} switch ;
PRIVATE> 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 )
[ irc-command-string ] [ command-string>> ]
[ irc-command-parameters " " sjoin ] [ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ; tri 3array " " sjoin ;
@ -77,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string )
! ====================================== ! ======================================
: split-at-first ( seq separators -- before after ) : split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
[ cut 1 tail ]
[ swap ]
if ;
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
@ -96,6 +111,15 @@ M: irc-message irc-message>server-line ( irc-message -- string )
: split-trailing ( string -- string string/f ) : split-trailing ( string -- string string/f )
":" split1 ; ":" split1 ;
: copy-message-in ( origin dest -- )
{ [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
[ [ line>> ] dip (>>line) ]
[ [ prefix>> ] dip (>>prefix) ]
[ [ command>> ] dip (>>command) ]
[ [ trailing>> ] dip (>>trailing) ]
[ [ timestamp>> ] dip (>>timestamp) ]
} 2cleave ;
PRIVATE> PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ; UNION: sender-in-prefix privmsg join part quit kick mode nick ;
@ -124,7 +148,4 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
{ "MODE" [ mode ] } { "MODE" [ mode ] }
{ "KICK" [ kick ] } { "KICK" [ kick ] }
[ drop unhandled ] [ drop unhandled ]
} case } case new [ copy-message-in ] keep ;
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head >quotation ] keep
'[ @ _ boa ] call ;