irc: IRC messages reimplemented
Bruno Deferrari
parent
b5352033cb
commit
1c70bf833f
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax quotations kernel irc.messages ;
|
||||
USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ;
|
||||
IN: irc.client
|
||||
|
||||
HELP: irc-client "IRC Client object" ;
|
||||
|
|
@ -56,15 +56,15 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
"Some of the RFC defined irc messages as objects:"
|
||||
{ $table
|
||||
{ { $link irc-message } "base of all irc messages" }
|
||||
{ { $link logged-in } "logged in to server" }
|
||||
{ { $link rpl-welcome } "logged in to server" }
|
||||
{ { $link ping } "ping message" }
|
||||
{ { $link join } "channel join" }
|
||||
{ { $link part } "channel part" }
|
||||
{ { $link quit } "quit from irc" }
|
||||
{ { $link privmsg } "private message (to client or channel)" }
|
||||
{ { $link kick } "kick from channel" }
|
||||
{ { $link roomlist } "list of participants in channel" }
|
||||
{ { $link nick-in-use } "chosen nick is in use by another client" }
|
||||
{ { $link rpl-names } "list of participants in channel" }
|
||||
{ { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
|
||||
{ { $link notice } "notice message" }
|
||||
{ { $link mode } "mode change" }
|
||||
{ { $link unhandled } "uninmplemented/unhandled message" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel tools.test accessors arrays sequences
|
||||
io io.streams.duplex namespaces threads destructors
|
||||
calendar irc.client.private irc.client irc.messages.private
|
||||
concurrency.mailboxes classes assocs combinators ;
|
||||
calendar irc.client.private irc.client irc.messages
|
||||
concurrency.mailboxes classes assocs combinators irc.messages.parser ;
|
||||
EXCLUDE: irc.messages => join ;
|
||||
RENAME: join irc.messages => join_
|
||||
IN: irc.client.tests
|
||||
|
|
@ -49,13 +49,13 @@ M: mb-writer dispose drop ;
|
|||
|
||||
{ "factorbot" } [ irc> nick>> ] unit-test
|
||||
|
||||
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
parse-irc-line forward-name ] unit-test
|
||||
string>irc-message forward-name ] unit-test
|
||||
|
||||
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
|
||||
parse-irc-line forward-name ] unit-test
|
||||
string>irc-message forward-name ] unit-test
|
||||
] with-irc
|
||||
|
||||
! Test login and nickname set
|
||||
|
|
@ -102,7 +102,7 @@ M: mb-writer dispose drop ;
|
|||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
|
||||
[ privmsg? ] read-matching-message
|
||||
[ class ] [ name>> ] [ trailing>> ] tri
|
||||
[ class ] [ target>> ] [ trailing>> ] tri
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
|
|
@ -110,7 +110,7 @@ M: mb-writer dispose drop ;
|
|||
"ircuser" <irc-nick-chat> [ %add-named-chat ] keep
|
||||
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
|
||||
[ privmsg? ] read-matching-message
|
||||
[ class ] [ name>> ] [ trailing>> ] tri
|
||||
[ class ] [ target>> ] [ trailing>> ] tri
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
||||
accessors destructors namespaces io assocs arrays fry
|
||||
continuations threads strings classes combinators splitting hashtables
|
||||
ascii irc.messages ;
|
||||
ascii irc.messages irc.messages.base irc.messages.parser call ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client
|
||||
|
|
@ -74,12 +74,12 @@ SINGLETON: irc-disconnected ! sent when connection is lost
|
|||
SINGLETON: irc-connected ! sent when connection is established
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
[ is-running>> ] keep and [
|
||||
dup is-running>> [
|
||||
f >>is-running
|
||||
[ stream>> dispose ] keep
|
||||
[ in-messages>> ] [ out-messages>> ] bi 2array
|
||||
[ irc-end swap mailbox-put ] each
|
||||
] when* ;
|
||||
] [ drop ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -120,7 +120,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
|
|||
|
||||
: chats-with-participant ( nick -- seq )
|
||||
irc> chats>> values
|
||||
[ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
|
||||
[ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ]
|
||||
with filter ;
|
||||
|
||||
: to-chats-with-participant ( message nickname -- )
|
||||
|
|
@ -165,11 +165,10 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
|
|||
" hostname servername :irc.factor" irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call drop ; inline
|
||||
irc> connect>> call( host port -- stream local ) drop ;
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
"JOIN " irc-write
|
||||
[ [ " :" ] dip 3append ] when* irc-print ;
|
||||
"JOIN " irc-write [ " :" swap 3append ] when* irc-print ;
|
||||
|
||||
: /PONG ( text -- )
|
||||
"PONG " irc-write irc-print ;
|
||||
|
|
@ -187,7 +186,7 @@ M: join forward-name trailing>> ;
|
|||
M: part forward-name channel>> ;
|
||||
M: kick forward-name channel>> ;
|
||||
M: mode forward-name name>> ;
|
||||
M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
|
||||
M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ;
|
||||
|
||||
UNION: single-forward join part kick mode privmsg ;
|
||||
UNION: multiple-forward nick quit ;
|
||||
|
|
@ -200,48 +199,48 @@ M: irc-message forward-message
|
|||
M: single-forward forward-message dup forward-name to-chat ;
|
||||
|
||||
M: multiple-forward forward-message
|
||||
dup irc-message-sender to-chats-with-participant ;
|
||||
dup sender>> to-chats-with-participant ;
|
||||
|
||||
M: broadcast-forward forward-message
|
||||
irc> chats>> values [ to-chat ] with each ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
M: logged-in process-message
|
||||
name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
|
||||
M: rpl-welcome process-message
|
||||
nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
|
||||
values [ initialize-chat ] each ;
|
||||
M: ping process-message trailing>> /PONG ;
|
||||
M: nick-in-use process-message name>> "_" append /NICK ;
|
||||
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
|
||||
|
||||
M: join process-message
|
||||
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
|
||||
[ drop +normal+ ] [ sender>> ] [ trailing>> ] tri
|
||||
dup chat> [ add-participant ] [ 3drop ] if ;
|
||||
|
||||
M: part process-message
|
||||
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
|
||||
[ sender>> ] [ channel>> ] bi remove-participant ;
|
||||
|
||||
M: kick process-message
|
||||
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
||||
[ dup who>> me? [ unregister-chat ] [ drop ] if ]
|
||||
[ [ user>> ] [ channel>> ] bi remove-participant ]
|
||||
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
|
||||
bi ;
|
||||
|
||||
M: quit process-message
|
||||
irc-message-sender remove-participant-from-all ;
|
||||
sender>> remove-participant-from-all ;
|
||||
|
||||
M: nick process-message
|
||||
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
|
||||
[ sender>> ] [ trailing>> ] bi rename-participant-in-all ;
|
||||
|
||||
M: mode process-message ( mode -- )
|
||||
[ channel-mode? ] keep and [
|
||||
dup channel-mode? [
|
||||
[ name>> ] [ mode>> ] [ parameter>> ] tri
|
||||
[ change-participant-mode ] [ 2drop ] if*
|
||||
] when* ;
|
||||
] [ drop ] if ;
|
||||
|
||||
: >nick/mode ( string -- nick mode )
|
||||
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||
|
||||
: names-reply>participants ( names-reply -- participants )
|
||||
trailing>> [ blank? ] trim " " split
|
||||
nicks>> [ blank? ] trim " " split
|
||||
[ >nick/mode 2array ] map >hashtable ;
|
||||
|
||||
: maybe-clean-participants ( channel-chat -- )
|
||||
|
|
@ -249,14 +248,14 @@ M: mode process-message ( mode -- )
|
|||
H{ } clone >>participants f >>clean-participants
|
||||
] when drop ;
|
||||
|
||||
M: names-reply process-message
|
||||
M: rpl-names process-message
|
||||
[ names-reply>participants ] [ channel>> chat> ] bi [
|
||||
[ maybe-clean-participants ]
|
||||
[ participants>> 2array assoc-combine ]
|
||||
[ (>>participants) ] tri
|
||||
] [ drop ] if* ;
|
||||
|
||||
M: end-of-names process-message
|
||||
M: rpl-names-end process-message
|
||||
channel>> chat> [
|
||||
t >>clean-participants
|
||||
[ f f f <participant-changed> ] dip name>> to-chat
|
||||
|
|
@ -268,7 +267,7 @@ M: end-of-names process-message
|
|||
|
||||
GENERIC: handle-outgoing-irc ( irc-message -- ? )
|
||||
M: irc-end handle-outgoing-irc drop f ;
|
||||
M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
|
||||
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
||||
|
||||
! ======================================
|
||||
! Reader/Writer
|
||||
|
|
@ -293,9 +292,9 @@ DEFER: (connect-irc)
|
|||
: (reader-loop) ( -- ? )
|
||||
irc> stream>> [
|
||||
|dispose stream-readln [
|
||||
parse-irc-line handle-reader-message t
|
||||
string>irc-message handle-reader-message t
|
||||
] [
|
||||
handle-disconnect
|
||||
f handle-disconnect
|
||||
] if*
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -314,7 +313,7 @@ DEFER: (connect-irc)
|
|||
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
||||
privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ;
|
||||
|
||||
: maybe-annotate-with-name ( name obj -- obj )
|
||||
{ { [ dup string? ] [ strings>privmsg ] }
|
||||
|
|
@ -325,7 +324,7 @@ DEFER: (connect-irc)
|
|||
GENERIC: annotate-message ( chat object -- object )
|
||||
M: object annotate-message nip ;
|
||||
M: part annotate-message swap name>> >>channel ;
|
||||
M: privmsg annotate-message swap name>> >>name ;
|
||||
M: privmsg annotate-message swap name>> >>target ;
|
||||
M: string annotate-message [ name>> ] dip strings>privmsg ;
|
||||
|
||||
: spawn-irc ( -- )
|
||||
|
|
@ -335,7 +334,7 @@ M: string annotate-message [ name>> ] dip strings>privmsg ;
|
|||
3drop ;
|
||||
|
||||
GENERIC: (attach-chat) ( irc-chat -- )
|
||||
USE: prettyprint
|
||||
|
||||
M: irc-chat (attach-chat)
|
||||
[ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
|
||||
[ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators fry generic.parser kernel lexer
|
||||
mirrors namespaces parser sequences splitting strings words ;
|
||||
IN: irc.messages.base
|
||||
|
||||
TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
SYMBOL: string-irc-type-mapping
|
||||
string-irc-type-mapping [ H{ } clone ] initialize
|
||||
|
||||
: register-irc-message-type ( type string -- )
|
||||
string-irc-type-mapping get set-at ;
|
||||
|
||||
: irc>type ( string -- irc-message-class )
|
||||
string-irc-type-mapping get at unhandled or ;
|
||||
|
||||
GENERIC: irc-trailing-slot ( irc-message -- string/f )
|
||||
M: irc-message irc-trailing-slot
|
||||
drop f ;
|
||||
|
||||
GENERIC: irc-parameter-slots ( irc-message -- seq )
|
||||
M: irc-message irc-parameter-slots
|
||||
drop f ;
|
||||
|
||||
GENERIC: process-irc-trailing ( irc-message -- )
|
||||
M: irc-message process-irc-trailing
|
||||
dup irc-trailing-slot [
|
||||
swap [ trailing>> swap ] [ <mirror> ] bi set-at
|
||||
] [ drop ] if* ;
|
||||
|
||||
GENERIC: process-irc-prefix ( irc-message -- )
|
||||
M: irc-message process-irc-prefix
|
||||
drop ;
|
||||
|
||||
<PRIVATE
|
||||
: [slot-setter] ( mirror -- quot )
|
||||
'[ [ _ set-at ] [ drop ] if* ] ; inline
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: process-irc-parameters ( irc-message -- )
|
||||
M: irc-message process-irc-parameters
|
||||
dup irc-parameter-slots [
|
||||
swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
|
||||
] [ drop ] if* ;
|
||||
|
||||
GENERIC: post-process-irc-message ( irc-message -- )
|
||||
M: irc-message post-process-irc-message drop ;
|
||||
|
||||
GENERIC: fill-irc-message-slots ( irc-message -- )
|
||||
M: irc-message fill-irc-message-slots
|
||||
{
|
||||
[ process-irc-trailing ]
|
||||
[ process-irc-prefix ]
|
||||
[ process-irc-parameters ]
|
||||
[ post-process-irc-message ]
|
||||
} cleave ;
|
||||
|
||||
GENERIC: irc-command-string ( irc-message -- string )
|
||||
M: irc-message irc-command-string drop f ;
|
||||
|
||||
! FIXME: inverse of post-process is missing
|
||||
GENERIC: set-irc-parameters ( irc-message -- )
|
||||
M: irc-message set-irc-parameters
|
||||
dup irc-parameter-slots
|
||||
[ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
|
||||
|
||||
GENERIC: set-irc-trailing ( irc-message -- )
|
||||
M: irc-message set-irc-trailing
|
||||
dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
|
||||
|
||||
GENERIC: set-irc-command ( irc-message -- )
|
||||
M: irc-message set-irc-command
|
||||
[ irc-command-string ] [ (>>command) ] bi ;
|
||||
|
||||
: irc-message>string ( irc-message -- string )
|
||||
{
|
||||
[ prefix>> ]
|
||||
[ command>> ]
|
||||
[ parameters>> " " join ]
|
||||
[ trailing>> dup [ CHAR: : prefix ] when ]
|
||||
} cleave 4array sift " " join ;
|
||||
|
||||
<PRIVATE
|
||||
: ?define-irc-parameters ( class slot-names -- )
|
||||
dup empty? not [
|
||||
[ \ irc-parameter-slots create-method-in ] dip
|
||||
[ [ "_" = not ] keep and ] map '[ drop _ ] define
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: ?define-irc-trailing ( class slot-name -- )
|
||||
[
|
||||
[ \ irc-trailing-slot create-method-in ] dip
|
||||
first '[ drop _ ] define
|
||||
] [ drop ] if* ;
|
||||
|
||||
: define-irc-class ( class params -- )
|
||||
[ { ":" "_" } member? not ] filter
|
||||
[ irc-message ] dip define-tuple-class ;
|
||||
|
||||
: define-irc-parameter-slots ( class params -- )
|
||||
{ ":" } split1 [ over ] dip
|
||||
[ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
|
||||
PRIVATE>
|
||||
|
||||
#! SYNTAX:
|
||||
#! IRC: type "COMMAND" slot1 ...;
|
||||
#! IRC: type "COMMAND" slot1 ... : trailing-slot;
|
||||
: IRC: ( name string parameters -- )
|
||||
CREATE-CLASS
|
||||
[ scan-object register-irc-message-type ] keep
|
||||
";" parse-tokens
|
||||
[ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
IRC messages base implementation
|
||||
|
|
@ -1,19 +1,10 @@
|
|||
USING: kernel tools.test accessors arrays
|
||||
irc.messages irc.messages.private ;
|
||||
irc.messages.parser irc.messages ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages.tests
|
||||
|
||||
|
||||
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
{ 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
|
||||
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
{ T{ privmsg
|
||||
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
|
||||
|
|
@ -21,9 +12,10 @@ IN: irc.messages.tests
|
|||
{ command "PRIVMSG" }
|
||||
{ parameters { "#factortest" } }
|
||||
{ trailing "hi" }
|
||||
{ name "#factortest" } } }
|
||||
{ target "#factortest" }
|
||||
{ text "hi" } } }
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ T{ join
|
||||
{ line ":someuser!n=user@some.where JOIN :#factortest" }
|
||||
|
|
@ -32,7 +24,7 @@ IN: irc.messages.tests
|
|||
{ parameters { } }
|
||||
{ trailing "#factortest" } } }
|
||||
[ ":someuser!n=user@some.where JOIN :#factortest"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ T{ mode
|
||||
{ line ":ircserver.net MODE #factortest +ns" }
|
||||
|
|
@ -42,7 +34,7 @@ IN: irc.messages.tests
|
|||
{ name "#factortest" }
|
||||
{ mode "+ns" } } }
|
||||
[ ":ircserver.net MODE #factortest +ns"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ T{ mode
|
||||
{ line ":ircserver.net MODE #factortest +o someuser" }
|
||||
|
|
@ -53,7 +45,7 @@ IN: irc.messages.tests
|
|||
{ mode "+o" }
|
||||
{ parameter "someuser" } } }
|
||||
[ ":ircserver.net MODE #factortest +o someuser"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ T{ nick
|
||||
{ line ":someuser!n=user@some.where NICK :someuser2" }
|
||||
|
|
@ -62,9 +54,9 @@ IN: irc.messages.tests
|
|||
{ parameters { } }
|
||||
{ trailing "someuser2" } } }
|
||||
[ ":someuser!n=user@some.where NICK :someuser2"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ T{ nick-in-use
|
||||
{ T{ rpl-nickname-in-use
|
||||
{ line ":ircserver.net 433 * nickname :Nickname is already in use" }
|
||||
{ prefix "ircserver.net" }
|
||||
{ command "433" }
|
||||
|
|
@ -72,4 +64,4 @@ IN: irc.messages.tests
|
|||
{ name "nickname" }
|
||||
{ trailing "Nickname is already in use" } } }
|
||||
[ ":ircserver.net 433 * nickname :Nickname is already in use"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
|
@ -1,179 +1,63 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
arrays classes.tuple math.order ;
|
||||
RENAME: join sequences => sjoin
|
||||
arrays classes.tuple math.order words assocs strings
|
||||
irc.messages.base ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages
|
||||
|
||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
|
||||
TUPLE: logged-in < irc-message name ;
|
||||
TUPLE: ping < irc-message ;
|
||||
TUPLE: join < irc-message ;
|
||||
TUPLE: part < irc-message channel ;
|
||||
TUPLE: quit < irc-message ;
|
||||
TUPLE: nick < irc-message ;
|
||||
TUPLE: privmsg < irc-message name ;
|
||||
TUPLE: kick < irc-message channel who ;
|
||||
TUPLE: roomlist < irc-message channel names ;
|
||||
TUPLE: nick-in-use < irc-message name ;
|
||||
TUPLE: notice < irc-message type ;
|
||||
TUPLE: mode < irc-message name mode parameter ;
|
||||
TUPLE: names-reply < irc-message who channel ;
|
||||
TUPLE: end-of-names < irc-message who channel ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
: <irc-client-message> ( command parameters trailing -- irc-message )
|
||||
irc-message new
|
||||
now >>timestamp
|
||||
swap >>trailing
|
||||
swap >>parameters
|
||||
swap >>command ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: command-string>> ( irc-message -- string )
|
||||
|
||||
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: command-parameters>> ( irc-message -- 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 command-parameters>> ( mode -- seq )
|
||||
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
|
||||
|
||||
GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
|
||||
|
||||
M: irc-message >>command-parameters ( irc-message params -- irc-message )
|
||||
drop ;
|
||||
|
||||
M: logged-in >>command-parameters ( part params -- part )
|
||||
first >>name ;
|
||||
|
||||
M: privmsg >>command-parameters ( privmsg params -- privmsg )
|
||||
first >>name ;
|
||||
|
||||
M: notice >>command-parameters ( notice params -- notice )
|
||||
first >>type ;
|
||||
|
||||
M: part >>command-parameters ( part params -- part )
|
||||
first >>channel ;
|
||||
|
||||
M: kick >>command-parameters ( kick params -- kick )
|
||||
first2 [ >>channel ] [ >>who ] bi* ;
|
||||
|
||||
M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
|
||||
second >>name ;
|
||||
|
||||
M: names-reply >>command-parameters ( names-reply params -- names-reply )
|
||||
first3 nip [ >>who ] [ >>channel ] bi* ;
|
||||
|
||||
M: end-of-names >>command-parameters ( names-reply params -- names-reply )
|
||||
first2 [ >>who ] [ >>channel ] bi* ;
|
||||
|
||||
M: mode >>command-parameters ( mode params -- mode )
|
||||
dup length {
|
||||
{ 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
|
||||
{ 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
|
||||
[ drop first >>name dup trailing>> >>mode ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: irc-message>client-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>client-line ( irc-message -- string )
|
||||
[ command-string>> ]
|
||||
[ command-parameters>> " " sjoin ]
|
||||
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
|
||||
tri 3array " " sjoin ;
|
||||
|
||||
GENERIC: irc-message>server-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>server-line ( irc-message -- string )
|
||||
drop "not implemented yet" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! ======================================
|
||||
! Message parsing
|
||||
! ======================================
|
||||
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
|
||||
|
||||
: remove-heading-: ( seq -- seq )
|
||||
":" ?head drop ;
|
||||
|
||||
: parse-name ( string -- string )
|
||||
remove-heading-: "!" split-at-first drop ;
|
||||
|
||||
: split-prefix ( string -- string/f string )
|
||||
dup ":" head?
|
||||
[ remove-heading-: " " split1 ] [ f swap ] if ;
|
||||
|
||||
: split-trailing ( string -- string string/f )
|
||||
":" split1 ;
|
||||
|
||||
: copy-message-in ( command irc-message -- command )
|
||||
{
|
||||
[ line>> >>line ]
|
||||
[ prefix>> >>prefix ]
|
||||
[ command>> >>command ]
|
||||
[ trailing>> >>trailing ]
|
||||
[ timestamp>> >>timestamp ]
|
||||
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
|
||||
} cleave ;
|
||||
|
||||
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
|
||||
now irc-message boa ;
|
||||
|
||||
: irc-message>command ( irc-message -- command )
|
||||
[
|
||||
command>> {
|
||||
{ "PING" [ ping ] }
|
||||
{ "NOTICE" [ notice ] }
|
||||
{ "001" [ logged-in ] }
|
||||
{ "433" [ nick-in-use ] }
|
||||
{ "353" [ names-reply ] }
|
||||
{ "366" [ end-of-names ] }
|
||||
{ "JOIN" [ join ] }
|
||||
{ "PART" [ part ] }
|
||||
{ "NICK" [ nick ] }
|
||||
{ "PRIVMSG" [ privmsg ] }
|
||||
{ "QUIT" [ quit ] }
|
||||
{ "MODE" [ mode ] }
|
||||
{ "KICK" [ kick ] }
|
||||
[ drop unhandled ]
|
||||
} case new
|
||||
] keep copy-message-in ;
|
||||
|
||||
: parse-irc-line ( string -- message )
|
||||
string>irc-message irc-message>command ;
|
||||
! connection
|
||||
IRC: pass "PASS" password ;
|
||||
IRC: nick "NICK" nickname ;
|
||||
IRC: user "USER" user mode _ : realname ;
|
||||
IRC: oper "OPER" name password ;
|
||||
IRC: mode "MODE" name mode parameter ;
|
||||
IRC: service "SERVICE" nickname _ distribution type _ : info ;
|
||||
IRC: quit "QUIT" : comment ;
|
||||
IRC: squit "SQUIT" server : comment ;
|
||||
! channel operations
|
||||
IRC: join "JOIN" channel ;
|
||||
IRC: part "PART" channel : comment ;
|
||||
IRC: topic "TOPIC" channel : topic ;
|
||||
IRC: names "NAMES" channel ;
|
||||
IRC: list "LIST" channel ;
|
||||
IRC: invite "INVITE" nickname channel ;
|
||||
IRC: kick "KICK" channel user : comment ;
|
||||
! chating
|
||||
IRC: privmsg "PRIVMSG" target : text ;
|
||||
IRC: notice "NOTICE" target : text ;
|
||||
! server queries
|
||||
IRC: motd "MOTD" target ;
|
||||
IRC: lusers "LUSERS" mask target ;
|
||||
IRC: version "VERSION" target ;
|
||||
IRC: stats "STATS" query target ;
|
||||
IRC: links "LINKS" server mask ;
|
||||
IRC: time "TIME" target ;
|
||||
IRC: connect "CONNECT" server port remote-server ;
|
||||
IRC: trace "TRACE" target ;
|
||||
IRC: admin "ADMIN" target ;
|
||||
IRC: info "INFO" target ;
|
||||
! service queries
|
||||
IRC: servlist "SERVLIST" mask type ;
|
||||
IRC: squery "SQUERY" service-name : text ;
|
||||
! user queries
|
||||
IRC: who "WHO" mask operator ;
|
||||
IRC: whois "WHOIS" target mask ;
|
||||
IRC: whowas "WHOWAS" nickname count target ;
|
||||
! misc
|
||||
IRC: kill "KILL" nickname : comment ;
|
||||
IRC: ping "PING" server1 server2 ;
|
||||
IRC: pong "PONG" server1 server2 ;
|
||||
IRC: error "ERROR" : message ;
|
||||
! numeric replies
|
||||
IRC: rpl-welcome "001" nickname : comment ;
|
||||
IRC: rpl-whois-user "311" nicnamek user host _ : real-name ;
|
||||
IRC: rpl-channel-modes "324" channel mode params ;
|
||||
IRC: rpl-notopic "331" channel : topic ;
|
||||
IRC: rpl-topic "332" channel : topic ;
|
||||
IRC: rpl-inviting "341" channel nickname ;
|
||||
IRC: rpl-names "353" nickname _ channel : nicks ;
|
||||
IRC: rpl-names-end "366" nickname channel : comment ;
|
||||
! error replies
|
||||
IRC: rpl-nickname-in-use "433" _ name ;
|
||||
IRC: rpl-nick-collision "436" nickname : comment ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
arrays classes.tuple math.order words assocs
|
||||
irc.messages.base sequences ;
|
||||
IN: irc.messages.parser
|
||||
|
||||
<PRIVATE
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
|
||||
|
||||
: split-trailing ( string -- string string/f ) ":" split1 ;
|
||||
: remove-heading-: ( seq -- seq ) ":" ?head drop ;
|
||||
|
||||
: split-prefix ( string -- string/f string )
|
||||
dup ":" head? [
|
||||
remove-heading-: " " split1
|
||||
] [ f swap ] if ;
|
||||
|
||||
: split-message ( string -- prefix command parameters trailing )
|
||||
split-prefix split-trailing
|
||||
[ [ blank? ] trim " " split unclip swap ] dip ;
|
||||
|
||||
: sender ( irc-message -- sender )
|
||||
prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
|
||||
PRIVATE>
|
||||
|
||||
: string>irc-message ( string -- irc-message )
|
||||
dup split-message
|
||||
[ [ irc>type new ] [ >>command ] bi ]
|
||||
[ >>parameters ]
|
||||
[ >>trailing ]
|
||||
tri*
|
||||
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
|
||||
now >>timestamp dup sender >>sender ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Basic parser for irc messages
|
||||
|
|
@ -0,0 +1 @@
|
|||
IRC message definitions
|
||||
Loading…
Reference in New Issue