-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" ;
"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" }
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
{ "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
"#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
"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
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
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
: 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 -- )
" 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 ;
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 ;
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 -- )
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
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
: (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 ;
[ 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 ] }
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 ( -- )
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* ]
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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
--- /dev/null
+IRC messages base implementation
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" }
{ 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" }
{ 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" }
{ 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" }
{ 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" }
{ 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" }
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
- parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
+ string>irc-message f >>timestamp ] unit-test
\ No newline at end of file
! 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 ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 ;
--- /dev/null
+Basic parser for irc messages
--- /dev/null
+IRC message definitions
projects / factor.git / commitdiff