diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 932bdda472..c768c1a82e 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- ) [ [ last-line>> concat ] [ lines>> ] bi push ] keep V{ } clone >>last-line drop ; -: spawn-client ( lines listeners -- irc-client ) +: spawn-client ( -- irc-client ) "someserver" irc-port "factorbot" f t >>is-running diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 76382edf1b..569f6c4bf7 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -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-connected ! sent when connection is established +> 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 [ - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri + [ end-loops ] [ [ f ] dip (>>is-running) ] bi ] when* ; [ stream-print ] keep stream-flush ; : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; - +: channel-mode? ( mode -- ? ) name>> first "#&" member? ; +: me? ( string -- ? ) irc> profile>> nickname>> = ; 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 ; : add-participant ( mode nick channel -- ) - listener> [ - [ participants>> set-at ] - [ [ +join+ f ] dip to-listener ] 2bi - ] [ 2drop ] if* ; + listener> + [ participants>> set-at ] + [ [ +join+ f ] dip to-listener ] 2bi ; + +: change-participant-mode ( channel mode nick -- ) + rot listener> + [ participants>> set-at ] + [ [ [ +mode+ ] dip ] dip to-listener ] 3bi ; ! FIXME DEFER: me? @@ -174,14 +184,11 @@ DEFER: me? ! Server message handling ! ====================================== -: me? ( string -- ? ) - irc> profile>> nickname>> = ; - 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 ) channel>> ; +M: mode forward-name ( mode -- name ) name>> ; M: privmsg forward-name ( privmsg -- name ) dup name>> me? [ irc-message-sender ] [ name>> ] if ; @@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; 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 -- ) [ irc-message-sender ] [ channel>> ] bi remove-participant ; @@ -236,6 +244,12 @@ M: quit process-message ( quit -- ) M: nick process-message ( nick -- ) [ 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 ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- ) [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -: handle-incoming-irc ( irc-message -- ) - [ forward-message ] [ process-message ] bi ; - ! ====================================== ! Client message handling ! ====================================== -: handle-outgoing-irc ( irc-message -- ) - irc-message>client-line irc-print ; +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 ; ! ====================================== ! Reader/Writer @@ -279,27 +292,28 @@ DEFER: (connect-irc) : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; -: (reader-loop) ( -- ) +: (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message + parse-irc-line handle-reader-message t ] [ - irc> terminate-irc + irc> terminate-irc f ] if* ] with-destructors ; : reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover t ; + [ (reader-loop) ] [ handle-disconnect t ] recover ; : writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc t ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : 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 ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -310,22 +324,22 @@ 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 - irc> out-messages>> mailbox-put - t + maybe-annotate-with-name handle-listener-out ] [ drop f ] if* ; -: spawn-irc-loop ( quot: ( -- ? ) name -- ) - [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip - spawn-server drop ; - : spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-irc-loop - [ writer-loop ] "irc-writer-loop" spawn-irc-loop - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ; + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; ! ====================================== ! Listener join request handling @@ -333,7 +347,7 @@ DEFER: (connect-irc) : set+run-listener ( name irc-listener -- ) over irc> listeners>> set-at - '[ _ listener-loop ] "listener" spawn-irc-loop ; + '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ; GENERIC: (add-listener) ( irc-listener -- ) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 20f4f1b277..b61dd16448 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -6,54 +6,60 @@ IN: irc.messages.tests { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test -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 +{ T{ irc-message + { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } + { prefix "someuser!n=user@some.where" } + { command "PRIVMSG" } + { parameters { "#factortest" } } + { trailing "hi" } } } [ ":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 +{ T{ privmsg + { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } + { prefix "someuser!n=user@some.where" } + { command "PRIVMSG" } + { parameters { "#factortest" } } + { trailing "hi" } + { name "#factortest" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" parse-irc-line f >>timestamp ] unit-test -join new - ":someuser!n=user@some.where JOIN :#factortest" >>line - "someuser!n=user@some.where" >>prefix - "JOIN" >>command - { } >>parameters - "#factortest" >>trailing -1array +{ T{ join + { line ":someuser!n=user@some.where JOIN :#factortest" } + { prefix "someuser!n=user@some.where" } + { command "JOIN" } + { parameters { } } + { trailing "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" 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 +{ T{ mode + { line ":ircserver.net MODE #factortest +ns" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+ns" } } + { name "#factortest" } + { mode "+ns" } } } [ ":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 +{ T{ mode + { line ":ircserver.net MODE #factortest +o someuser" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+o" "someuser" } } + { name "#factortest" } + { 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" parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 16066199ed..9201f822da 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order quotations ; + arrays classes.tuple math.order ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; +EXCLUDE: inverse => _ ; IN: irc.messages 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: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message channel mode ; -TUPLE: names-reply < irc-message who = channel ; +TUPLE: mode < irc-message name mode parameter ; +TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; : ( command parameters trailing -- irc-message ) @@ -28,41 +29,58 @@ TUPLE: unhandled < irc-message ; > ( 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" ; +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" ; -GENERIC: irc-command-parameters ( irc-message -- seq ) +GENERIC: 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 ) channel>> 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 ) +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 irc-command-parameters ( mode -- seq ) +M: mode command-parameters>> ( mode -- seq ) [ 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> GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ irc-command-string ] - [ irc-command-parameters " " sjoin ] + [ command-string>> ] + [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; @@ -77,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string ) ! ====================================== : split-at-first ( seq separators -- before after ) - dupd '[ _ member? ] find - [ cut 1 tail ] - [ swap ] - if ; + dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ; : 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 ) ":" 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> UNION: sender-in-prefix privmsg join part quit kick mode nick ; @@ -111,20 +135,17 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } [ drop unhandled ] - } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head >quotation ] keep - '[ @ _ boa ] call ; + } case new [ copy-message-in ] keep ;