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

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

db4
Slava Pestov 2009-04-13 19:57:05 -05:00
parent 6aa3b7cd3d d8f144a8e9
commit 5c952a8f14
25 changed files with 683 additions and 687 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/irc/client/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

37
extra/irc/client/base/base.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs concurrency.mailboxes io kernel namespaces
strings words.symbol irc.client.chats irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.client.base
SYMBOL: current-irc-client
: irc> ( -- irc-client ) current-irc-client get ;
: stream> ( -- stream ) irc> stream>> ;
: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chats> ( -- seq ) irc> chats>> values ;
: me? ( string -- ? ) irc> nick>> = ;
: with-irc ( irc-client quot: ( -- ) -- )
\ current-irc-client swap with-variable ; inline
UNION: to-target privmsg notice ;
UNION: to-channel join part topic kick rpl-channel-modes
rpl-notopic rpl-topic rpl-names rpl-names-end ;
UNION: to-one-chat to-target to-channel mode ;
UNION: to-many-chats nick quit ;
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
PREDICATE: to-me < to-target target>> me? ;
GENERIC: chat-name ( irc-message -- name )
M: mode chat-name name>> ;
M: to-target chat-name target>> ;
M: to-me chat-name sender>> ;
M: to-channel chat-name channel>> ;
GENERIC: chat> ( obj -- chat/f )
M: string chat> irc> chats>> at ;
M: symbol chat> irc> chats>> at ;
M: to-one-chat chat> chat-name +server-chat+ or chat> ;

1
extra/irc/client/chats/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

22
extra/irc/client/chats/chats-docs.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel ;
IN: irc.client.chats
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ;
HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;

50
extra/irc/client/chats/chats.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
destructors arrays sequences ;
IN: irc.client.chats
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
: <irc-server-chat> ( -- irc-server-chat )
irc-server-chat new
<mailbox> >>in-messages ;
: <irc-channel-chat> ( name -- irc-channel-chat )
irc-channel-chat new
swap >>name
<mailbox> >>in-messages
f >>password
H{ } clone >>participants
t >>clear-participants ;
: <irc-nick-chat> ( name -- irc-nick-chat )
irc-nick-chat new
swap >>name
<mailbox> >>in-messages ;
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready
exceptions ;
: <irc-client> ( profile -- irc-client )
dup nickname>> irc-client new
swap >>nick
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
15 seconds >>reconnect-time
V{ } clone >>exceptions
[ <inet> latin1 <client> ] >>connect ;
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;

1
extra/irc/client/chats/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client and Chat object definitions

28
extra/irc/client/client-docs.factor
View File

@ -1,16 +1,9 @@
USING: help.markup help.syntax quotations kernel irc.messages ; ! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel
irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
IN: irc.client IN: irc.client
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: connect-irc "Connecting to an irc server" HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } } { $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; { $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
@ -56,30 +49,31 @@ ARTICLE: "irc.client" "IRC Client"
"Some of the RFC defined irc messages as objects:" "Some of the RFC defined irc messages as objects:"
{ $table { $table
{ { $link irc-message } "base of all irc messages" } { { $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 ping } "ping message" }
{ { $link join } "channel join" } { { $link join } "channel join" }
{ { $link part } "channel part" } { { $link part } "channel part" }
{ { $link quit } "quit from irc" } { { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" } { { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" } { { $link kick } "kick from channel" }
{ { $link roomlist } "list of participants in channel" } { { $link rpl-names } "list of participants in channel" }
{ { $link nick-in-use } "chosen nick is in use by another client" } { { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" } { { $link notice } "notice message" }
{ { $link mode } "mode change" } { { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" } { { $link unhandled } "uninmplemented/unhandled message" }
} }
{ $heading "Special messages" } { $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server." "Some special messages that are created by the library and not by the irc server."
{ $table { $table
{ { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " } { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
{ { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } { { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." } { { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" } { $heading "Example:" }
{ $code { $code
"USING: irc.client ;" "USING: irc.client irc.client.chats ;"
"SYMBOL: bot" "SYMBOL: bot"
"SYMBOL: mychannel" "SYMBOL: mychannel"
"! Create the profile and client objects" "! Create the profile and client objects"
@ -91,7 +85,7 @@ ARTICLE: "irc.client" "IRC Client"
"! Register and start chat (this joins the channel)" "! Register and start chat (this joins the channel)"
"mychannel get bot get attach-chat" "mychannel get bot get attach-chat"
"! Send a message to the channel" "! Send a message to the channel"
"\"what's up?\" mychannel get speak" "\"Hello World!\" mychannel get speak"
"! Read a message from the channel" "! Read a message from the channel"
"mychannel get hear" "mychannel get hear"
} }

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

@ -1,383 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov. ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar USING: accessors concurrency.mailboxes destructors
accessors destructors namespaces io assocs arrays fry irc.client.base irc.client.chats irc.client.internals kernel
continuations threads strings classes combinators splitting hashtables namespaces sequences ;
ascii irc.messages ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.client IN: irc.client
! ======================================
! Setup and running objects
! ======================================
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready ;
: <irc-client> ( profile -- irc-client )
irc-client new
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
dup profile>> nickname>> >>nick
[ <inet> latin1 <client> ] >>connect
15 seconds >>reconnect-time ;
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
! participant modes
SYMBOL: +operator+
SYMBOL: +voice+
SYMBOL: +normal+
: participant-mode ( n -- mode )
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
! participant changed actions
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
SYMBOL: +nick+
! chat objects
: <irc-server-chat> ( -- irc-server-chat )
<mailbox> f irc-server-chat boa ;
: <irc-channel-chat> ( name -- irc-channel-chat )
[ <mailbox> f ] dip f 60 seconds H{ } clone t
irc-channel-chat boa ;
: <irc-nick-chat> ( name -- irc-nick-chat )
[ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
! ======================================
TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
SINGLETON: irc-chat-end ! sent to a chat 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
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] when* ;
<PRIVATE
SYMBOL: current-irc-client
! ======================================
! Utils
! ======================================
: irc> ( -- irc-client ) current-irc-client get ;
: irc-write ( s -- ) irc> stream>> stream-write ;
: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chat> ( name -- chat/f ) irc> chats>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
: me? ( string -- ? ) irc> nick>> = ;
GENERIC: to-chat ( message obj -- )
M: string to-chat
chat> [ +server-chat+ chat> ] unless*
[ to-chat ] [ drop ] if* ;
M: irc-chat to-chat in-messages>> mailbox-put ;
: unregister-chat ( name -- )
irc> chats>>
[ at [ irc-chat-end ] dip to-chat ]
[ delete-at ]
2bi ;
: (remove-participant) ( nick chat -- )
[ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- )
chat> [ (remove-participant) ] [ drop ] if* ;
: chats-with-participant ( nick -- seq )
irc> chats>> values
[ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ;
: to-chats-with-participant ( message nickname -- )
chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- )
dup chats-with-participant [ (remove-participant) ] with each ;
: notify-rename ( newnick oldnick chat -- )
[ participant-changed new +nick+ >>action
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
: rename-participant ( newnick oldnick chat -- )
[ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
swap dup chats-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
chat>
[ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
rot chat>
[ participants>> set-at ]
[ [ participant-changed new
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
3bi ; ! FIXME
! ======================================
! IRC client messages
! ======================================
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call drop ; inline
: /JOIN ( channel password -- )
"JOIN " irc-write
[ [ " :" ] dip 3append ] when* irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
! ======================================
! Server message handling
! ======================================
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: forward-name ( irc-message -- name )
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 ;
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 -- )
M: irc-message forward-message
+server-chat+ chat> [ to-chat ] [ drop ] if* ;
M: single-forward forward-message dup forward-name to-chat ;
M: multiple-forward forward-message
dup irc-message-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
values [ initialize-chat ] each ;
M: ping process-message trailing>> /PONG ;
M: nick-in-use process-message name>> "_" append /NICK ;
M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup chat> [ add-participant ] [ 3drop ] if ;
M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: quit process-message
irc-message-sender remove-participant-from-all ;
M: nick process-message
[ 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 ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
: maybe-clean-participants ( channel-chat -- )
dup clean-participants>> [
H{ } clone >>participants f >>clean-participants
] when drop ;
M: names-reply 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
channel>> chat> [
t >>clean-participants
[ f f f <participant-changed> ] dip name>> to-chat
] when* ;
! ======================================
! Client message handling
! ======================================
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 ;
! ======================================
! Reader/Writer
! ======================================
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ nick>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- ? )
drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? )
irc> stream>> [
|dispose stream-readln [
parse-irc-line handle-reader-message t
] [
handle-disconnect
] if*
] with-destructors ;
: reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
: maybe-annotate-with-name ( name obj -- obj )
{ { [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
[ nip ]
} cond ;
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: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
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* ]
bi ;
M: irc-server-chat (attach-chat)
irc> >>client +server-chat+ irc> chats>> set-at ;
GENERIC: (remove-chat) ( irc-chat -- )
M: irc-nick-chat (remove-chat)
name>> unregister-chat ;
M: irc-channel-chat (remove-chat)
[ part new annotate-message irc> out-messages>> mailbox-put ] keep
name>> unregister-chat ;
M: irc-server-chat (remove-chat)
drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- )
{
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
: connect-irc ( irc-client -- ) : connect-irc ( irc-client -- )
dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; [ (connect-irc) (do-login) spawn-irc ] with-irc ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
: detach-chat ( irc-chat -- )
[ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
: speak ( message irc-chat -- )
[ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ;
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;

1
extra/irc/client/internals/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

195
extra/irc/client/client-tests.factor → extra/irc/client/internals/internals-tests.factor
View File

@ -1,10 +1,13 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays sequences USING: kernel tools.test accessors arrays sequences
io io.streams.duplex namespaces threads destructors io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private calendar concurrency.mailboxes classes assocs combinators
concurrency.mailboxes classes assocs combinators ; irc.messages.parser irc.client.base irc.client.chats
irc.client.participants irc.client.internals ;
EXCLUDE: irc.messages => join ; EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_ RENAME: join irc.messages => join_
IN: irc.client.tests IN: irc.client.internals.tests
! Streams for testing ! Streams for testing
TUPLE: mb-writer lines last-line disposed ; TUPLE: mb-writer lines last-line disposed ;
@ -28,18 +31,20 @@ M: mb-writer dispose drop ;
t >>is-ready t >>is-ready
t >>is-running t >>is-running
<test-stream> >>stream <test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ; dup [ spawn-irc yield ] with-irc ;
! to be used inside with-irc-client quotations ! to be used inside with-irc quotations
: %add-named-chat ( chat -- ) irc> attach-chat ; : %add-named-chat ( chat -- ) (attach-chat) ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ; : %push-lines ( lines -- ) [ %push-line ] each ;
: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- ) : spawning-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTS ! TESTS
@ -49,170 +54,160 @@ M: mb-writer dispose drop ;
{ "factorbot" } [ irc> nick>> ] unit-test { "factorbot" } [ irc> nick>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line forward-name ] unit-test string>irc-message chat-name ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line forward-name ] unit-test string>irc-message chat-name ] unit-test
] with-irc ] spawning-irc
{ privmsg "#channel" "hello" } [
"#channel" "hello" strings>privmsg
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
! Test login and nickname set ! Test login and nickname set
[ { "factorbot2" } [ [ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
irc> nick>> irc> nick>>
] unit-test ] unit-test
] with-irc ] spawning-irc
! Test connect ! Test connect
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client> "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
[ 2drop <test-stream> t ] >>connect [ 2drop <test-stream> t ] >>connect
[ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri [
(connect-irc)
(do-login)
irc> stream>> out>> lines>>
(terminate-irc)
] with-irc
] unit-test ] unit-test
! Test join ! Test join
[ { "JOIN #factortest" } [ [ { "JOIN #factortest" } [
"#factortest" %join "#factortest" %join %pop-output-line
irc> stream>> out>> lines>> pop
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { join_ "#factortest" } [ [ { join_ "#factortest"} [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each } %push-lines
in-messages>> 0.1 seconds mailbox-get-timeout [ join? ] read-matching-message
[ class ] [ trailing>> ] bi [ class ] [ channel>> ] bi
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { T{ participant-changed f "somebody" +join+ } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { privmsg "#factortest" "hello" } [ [ { privmsg "#factortest" "hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message [ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ target>> ] [ trailing>> ] tri
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { privmsg "factorbot" "hello" } [ [ { privmsg "factorbot" "hello" } [
"ircuser" <irc-nick-chat> [ %add-named-chat ] keep "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message [ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ target>> ] [ trailing>> ] tri
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { mode } [ [ { mode "#factortest" "+ns" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line ":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class [ mode? ] read-matching-message
[ class ] [ name>> ] [ mode>> ] tri
] unit-test ] unit-test
] with-irc ] spawning-irc
! Participant lists tests ! Participant lists tests
[ { H{ { "ircuser" +normal+ } } } [ [ { { "ircuser" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>> participants>> keys
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { { "ircuser2" } } [
"#factortest" <irc-channel-chat> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } { "ircuser2" "ircuser" } [ over join-participant ] each
{ "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep [ %add-named-chat ] keep
":ircuser!n=user@isp.net PART #factortest" %push-line ":ircuser!n=user@isp.net PART #factortest" %push-line
participants>> participants>> keys
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { { "ircuser2" } } [
"#factortest" <irc-channel-chat> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } { "ircuser2" "ircuser" } [ over join-participant ] each
{ "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep [ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line ":ircuser!n=user@isp.net QUIT" %push-line
participants>> participants>> keys
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { { "ircuser2" } } [
"#factortest" <irc-channel-chat> "#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ } { "ircuser2" "ircuser" } [ over join-participant ] each
{ "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep [ %add-named-chat ] keep
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>> participants>> keys
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [ [ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
"#factortest" <irc-channel-chat> "#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants "ircuser" over join-participant
[ %add-named-chat ] keep [ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [ [ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
{ "ircuser" T{ participant { nick "ircuser" } } }
{ "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
"#factortest" <irc-channel-chat> "#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants "ircuser" over join-participant
[ %add-named-chat ] keep [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line ":ircserver.net 353 factorbot @ #factortest :ircuser2 "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line ":ircserver.net 353 factorbot @ #factortest :ircuser "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
} %push-lines
participants>> participants>>
] unit-test ] unit-test
] with-irc ] spawning-irc
! Namelist change notification [ { mode "#factortest" "+o" "ircuser" } [
[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +part+ f } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
! Mode change
[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line ":ircserver.net MODE #factortest +o ircuser" %push-line
[ participant-changed? ] read-matching-message [ mode? ] read-matching-message
{ [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
] unit-test ] unit-test
] with-irc ] spawning-irc
[ { T{ participant { nick "ircuser" } { operator t } } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
participants>> "ircuser" swap at
] unit-test
] spawning-irc
! Send privmsg
[ { "PRIVMSG #factortest :hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"hello" swap (speak) %pop-output-line
] unit-test
] spawning-irc

162
extra/irc/client/internals/internals.factor Normal file
View File

@ -0,0 +1,162 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
strings words.symbol irc.messages.base irc.client.participants fry threads
combinators irc.messages.parser ;
EXCLUDE: sequences => join ;
IN: irc.client.internals
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " prepend " hostname servername :irc.factor" append irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call( host port -- stream local ) drop ;
: /JOIN ( channel password -- )
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
: (connect-irc) ( -- )
irc> {
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: (do-login) ( -- ) irc> nick>> /LOGIN ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: chat-put ( message obj -- )
M: irc-chat chat-put in-messages>> mailbox-put ;
M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
M: string chat-put chat> +server-chat+ or chat-put ;
M: sequence chat-put [ chat-put ] with each ;
: delete-chat ( name -- ) irc> chats>> delete-at ;
: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
! Server message handling
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message +server-chat+ chat-put ;
M: to-one-chat forward-message dup chat> chat-put ;
M: to-all-chats forward-message chats> chat-put ;
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: ping process-message trailing>> /PONG ;
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
M: quit process-message sender>> quit-participant ;
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
M: rpl-welcome process-message
irc>
swap nickname>> >>nick
t >>is-ready
chats>> values [ initialize-chat ] each ;
M: kick process-message
[ [ user>> ] [ chat> ] bi part-participant ]
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: participant-mode process-message ( participant-mode -- )
[ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
M: rpl-names process-message
[ nicks>> ] [ chat> ] bi dup ?clear-participants
'[ _ join-participant ] each ;
M: rpl-names-end process-message chat> t >>clear-participants drop ;
! Client message handling
GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
! Reader/Writer
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
irc> in-messages>> irc-disconnected swap mailbox-put
irc> reconnect-time>> sleep
(connect-irc)
(do-login) ;
: handle-disconnect ( error -- ? )
[ irc> exceptions>> push ] when*
irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
GENERIC: handle-input ( line/f -- ? )
M: string handle-input string>irc-message handle-reader-message t ;
M: f handle-input handle-disconnect ;
: (reader-loop) ( -- ? )
stream> [ |dispose stream-readln handle-input ] with-destructors ;
: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
! Processing loops
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ;
M: to-channel annotate-message swap name>> >>channel ;
M: to-target annotate-message swap name>> >>target ;
M: mode annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
GENERIC: (attach-chat) ( irc-chat -- )
M: irc-chat (attach-chat)
irc>
[ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
[ is-ready>> [ initialize-chat ] [ drop ] if ]
2bi ;
M: irc-server-chat (attach-chat)
irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
GENERIC: remove-chat ( irc-chat -- )
M: irc-nick-chat remove-chat name>> unregister-chat ;
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
M: irc-channel-chat remove-chat
[ part new annotate-message irc-send ]
[ name>> unregister-chat ] bi ;
: (terminate-irc) ( -- )
irc> dup is-running>> [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] [ drop ] if ;
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;

1
extra/irc/client/internals/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client internals

1
extra/irc/client/participants/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

55
extra/irc/client/participants/participants.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry hashtables
irc.client.base irc.client.chats kernel sequences splitting ;
IN: irc.client.participants
TUPLE: participant nick operator voice ;
: <participant> ( name -- participant )
{
{ [ "@" ?head ] [ t f ] }
{ [ "+" ?head ] [ f t ] }
[ f f ]
} cond participant boa ;
GENERIC: has-participant? ( name irc-chat -- ? )
M: irc-chat has-participant? 2drop f ;
M: irc-channel-chat has-participant? participants>> key? ;
: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
'[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
: part-participant ( nick irc-chat -- ) participants>> delete-at ;
: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
: quit-participant ( nick -- )
dup participant-chats [ part-participant ] with each ;
: rename-participant* ( new old -- )
[ dup participant-chats [ rename-participant ] with with each ]
[ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
2bi ;
: join-participant ( nick irc-channel-chat -- )
participants>> [ <participant> dup nick>> ] dip set-at ;
: apply-mode ( ? participant mode -- )
{
{ CHAR: o [ (>>operator) ] }
{ CHAR: v [ (>>voice) ] }
[ 3drop ]
} case ;
: apply-modes ( mode-line participant -- )
[ unclip CHAR: + = ] dip
'[ [ _ _ ] dip apply-mode ] each ;
: change-participant-mode ( mode channel nick -- )
swap chat> participants>> at apply-modes ;
: ?clear-participants ( channel-chat -- )
dup clear-participants>> [
f >>clear-participants participants>> clear-assoc
] [ drop ] if ;

1
extra/irc/client/participants/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client chat participants handling

2
extra/irc/gitbot/gitbot.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.private kernel namespaces USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ; make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot IN: irc.gitbot

1
extra/irc/messages/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

115
extra/irc/messages/base/base.factor Normal file
View File

@ -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;
SYNTAX: IRC: ( name string parameters -- )
CREATE-CLASS
[ scan-object register-irc-message-type ] keep
";" parse-tokens
[ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;

1
extra/irc/messages/base/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC messages base implementation

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

@ -1,19 +1,12 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays USING: kernel tools.test accessors arrays
irc.messages irc.messages.private ; irc.messages.parser irc.messages ;
EXCLUDE: sequences => join ; EXCLUDE: sequences => join ;
IN: irc.messages.tests IN: irc.messages.tests
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test ! { "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
{ T{ privmsg { T{ privmsg
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
@ -21,18 +14,22 @@ IN: irc.messages.tests
{ command "PRIVMSG" } { command "PRIVMSG" }
{ parameters { "#factortest" } } { parameters { "#factortest" } }
{ trailing "hi" } { trailing "hi" }
{ name "#factortest" } } } { target "#factortest" }
{ text "hi" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :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 { T{ join
{ line ":someuser!n=user@some.where JOIN :#factortest" } { line ":someuser!n=user@some.where JOIN :#factortest" }
{ prefix "someuser!n=user@some.where" } { prefix "someuser!n=user@some.where" }
{ command "JOIN" } { command "JOIN" }
{ parameters { } } { parameters { } }
{ trailing "#factortest" } } } { trailing "#factortest" }
{ sender "someuser" }
{ channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest" [ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test string>irc-message f >>timestamp ] unit-test
{ T{ mode { T{ mode
{ line ":ircserver.net MODE #factortest +ns" } { line ":ircserver.net MODE #factortest +ns" }
@ -42,7 +39,7 @@ IN: irc.messages.tests
{ name "#factortest" } { name "#factortest" }
{ mode "+ns" } } } { mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns" [ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test string>irc-message f >>timestamp ] unit-test
{ T{ mode { T{ mode
{ line ":ircserver.net MODE #factortest +o someuser" } { line ":ircserver.net MODE #factortest +o someuser" }
@ -53,18 +50,19 @@ IN: irc.messages.tests
{ mode "+o" } { mode "+o" }
{ parameter "someuser" } } } { parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser" [ ":ircserver.net MODE #factortest +o someuser"
parse-irc-line f >>timestamp ] unit-test string>irc-message f >>timestamp ] unit-test
{ T{ nick { T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" } { line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" } { prefix "someuser!n=user@some.where" }
{ command "NICK" } { command "NICK" }
{ parameters { } } { parameters { } }
{ trailing "someuser2" } } } { trailing "someuser2" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where NICK :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" } { line ":ircserver.net 433 * nickname :Nickname is already in use" }
{ prefix "ircserver.net" } { prefix "ircserver.net" }
{ command "433" } { command "433" }
@ -72,4 +70,4 @@ IN: irc.messages.tests
{ name "nickname" } { name "nickname" }
{ trailing "Nickname is already in use" } } } { trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :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

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

@ -1,179 +1,68 @@
! Copyright (C) 2008 Bruno Deferrari ! Copyright (C) 2009 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 USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order ; arrays classes.tuple math.order words assocs strings irc.messages.base ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ; EXCLUDE: sequences => join ;
IN: irc.messages IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ; ! connection
TUPLE: logged-in < irc-message name ; IRC: pass "PASS" password ;
TUPLE: ping < irc-message ; IRC: nick "NICK" nickname ;
TUPLE: join < irc-message ; IRC: user "USER" user mode _ : realname ;
TUPLE: part < irc-message channel ; IRC: oper "OPER" name password ;
TUPLE: quit < irc-message ; IRC: mode "MODE" name mode parameter ;
TUPLE: nick < irc-message ; IRC: service "SERVICE" nickname _ distribution type _ : info ;
TUPLE: privmsg < irc-message name ; IRC: quit "QUIT" : comment ;
TUPLE: kick < irc-message channel who ; IRC: squit "SQUIT" server : comment ;
TUPLE: roomlist < irc-message channel names ; ! channel operations
TUPLE: nick-in-use < irc-message name ; IRC: join "JOIN" : channel ;
TUPLE: notice < irc-message type ; IRC: part "PART" channel : comment ;
TUPLE: mode < irc-message name mode parameter ; IRC: topic "TOPIC" channel : topic ;
TUPLE: names-reply < irc-message who channel ; IRC: names "NAMES" channel ;
TUPLE: end-of-names < irc-message who channel ; IRC: list "LIST" channel ;
TUPLE: unhandled < irc-message ; 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 ;
: <irc-client-message> ( command parameters trailing -- irc-message ) M: rpl-names post-process-irc-message ( rpl-names -- )
irc-message new [ [ blank? ] trim " " split ] change-nicks drop ;
now >>timestamp
swap >>trailing
swap >>parameters
swap >>command ;
<PRIVATE PREDICATE: channel-mode < mode name>> first "#&" member? ;
PREDICATE: participant-mode < channel-mode parameter>> ;
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 ;

1
extra/irc/messages/parser/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

35
extra/irc/messages/parser/parser.factor Normal file
View File

@ -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 ;

1
extra/irc/messages/parser/summary.txt Normal file
View File

@ -0,0 +1 @@
Basic parser for irc messages

1
extra/irc/messages/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC message definitions