diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2b4b501952..932bdda472 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -49,10 +49,10 @@ M: mb-writer stream-nl ( mb-writer -- ) { "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 + parse-irc-line forward-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line irc-message-origin ] unit-test + parse-irc-line forward-name ] unit-test ] with-irc ! Test login and nickname set diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index e91767b22d..575c26972f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.private ; + ascii irc.messages ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -67,7 +67,6 @@ 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-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established -UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ @@ -122,6 +121,9 @@ M: irc-listener to-listener ( message irc-listener -- ) [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] with filter ; +: to-listeners-with-participant ( message nickname -- ) + listeners-with-participant [ to-listener ] with each ; + : remove-participant-from-all ( nick -- ) dup listeners-with-participant [ (remove-participant) ] with each ; @@ -145,7 +147,7 @@ M: irc-listener to-listener ( message irc-listener -- ) DEFER: me? : maybe-forward-join ( join -- ) - [ prefix>> parse-name me? ] keep and + [ irc-message-sender me? ] keep and [ irc> join-messages>> mailbox-put ] when* ; ! ====================================== @@ -177,60 +179,64 @@ DEFER: me? : me? ( string -- ? ) irc> profile>> nickname>> = ; -: irc-message-origin ( irc-message -- name ) - dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; +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: privmsg forward-name ( privmsg -- name ) + dup name>> me? [ irc-message-sender ] [ name>> ] if ; -: broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ to-listener ] with each ; +UNION: single-forward join part kick mode privmsg ; +UNION: multiple-forward nick quit ; +UNION: broadcast-forward irc-end irc-disconnected irc-connected ; +GENERIC: forward-message ( irc-message -- ) -GENERIC: handle-incoming-irc ( irc-message -- ) - -M: irc-message handle-incoming-irc ( irc-message -- ) +M: irc-message forward-message ( irc-message -- ) +server-listener+ listener> [ to-listener ] [ drop ] if* ; -M: logged-in handle-incoming-irc ( logged-in -- ) +M: single-forward forward-message ( forward-single -- ) + dup forward-name to-listener ; + +M: multiple-forward forward-message ( multiple-forward -- ) + dup irc-message-sender to-listeners-with-participant ; + +M: join forward-message ( join -- ) + [ maybe-forward-join ] [ call-next-method ] bi ; + +M: broadcast-forward forward-message ( irc-broadcasted-message -- ) + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: process-message ( irc-message -- ) + +M: object process-message ( object -- ) + drop ; + +M: logged-in process-message ( logged-in -- ) name>> irc> profile>> (>>nickname) ; -M: ping handle-incoming-irc ( ping -- ) +M: ping process-message ( ping -- ) trailing>> /PONG ; -M: nick-in-use handle-incoming-irc ( nick-in-use -- ) +M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; -M: privmsg handle-incoming-irc ( privmsg -- ) - dup irc-message-origin to-listener ; +M: join process-message ( join -- ) + [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; -M: join handle-incoming-irc ( join -- ) - [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - tri ; +M: part process-message ( part -- ) + [ irc-message-sender ] [ channel>> ] bi remove-participant ; -M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] - [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] - bi ; - -M: kick handle-incoming-irc ( kick -- ) - [ dup channel>> to-listener ] +M: kick process-message ( kick -- ) [ [ who>> ] [ channel>> ] bi remove-participant ] [ dup who>> me? [ unregister-listener ] [ drop ] if ] - tri ; - -M: quit handle-incoming-irc ( quit -- ) - [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ prefix>> parse-name remove-participant-from-all ] bi ; -M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list - dup channel>> to-listener ; +M: quit process-message ( quit -- ) + irc-message-sender remove-participant-from-all ; -M: nick handle-incoming-irc ( nick -- ) - [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ] - bi ; +M: nick process-message ( nick -- ) + [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -239,22 +245,20 @@ M: nick handle-incoming-irc ( nick -- ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; -M: names-reply handle-incoming-irc ( names-reply -- ) +M: names-reply process-message ( names-reply -- ) [ names-reply>participants ] [ channel>> listener> ] bi [ [ (>>participants) ] [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) - broadcast-message-to-listeners ; +: handle-incoming-irc ( irc-message -- ) + [ forward-message ] [ process-message ] bi ; ! ====================================== ! Client message handling ! ====================================== -GENERIC: handle-outgoing-irc ( obj -- ) - -M: irc-message handle-outgoing-irc ( irc-message -- ) +: handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; ! ====================================== diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 7ee0f41ab0..20f4f1b277 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified EXCLUDE: sequences => join ; IN: irc.messages.tests -! Parsing 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 diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index fb56dd3a45..201e8de9e7 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string ) PRIVATE> +UNION: sender-in-prefix privmsg join part quit kick mode nick ; +GENERIC: irc-message-sender ( irc-message -- sender ) +M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) + prefix>> parse-name ; + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 4757e36660..956644dc52 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels 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.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -21,7 +21,7 @@ SYMBOL: client TUPLE: ui-window < tabbed client ; -TUPLE: irc-tab < frame listener client window userlist ; +TUPLE: irc-tab < frame listener client window ; : write-color ( str color -- ) foreground associate format ; @@ -39,7 +39,7 @@ M: ping write-irc M: privmsg write-irc "<" blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep "> " blue write-color trailing>> write ; @@ -61,24 +61,24 @@ M: own-message write-irc M: join write-irc "* " dark-green write-color - prefix>> parse-name write + irc-message-sender write " has entered the channel." dark-green write-color ; M: part write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left the channel" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: quit write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left IRC" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: kick write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has kicked " dark-red write-color [ who>> write ] keep " from the channel" dark-red write-color @@ -89,7 +89,7 @@ M: kick write-irc M: mode write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has applied mode " blue write-color [ full-mode write ] keep " to " blue write-color @@ -97,7 +97,7 @@ M: mode write-irc M: nick write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " is now known as " blue write-color trailing>> write ;