Merge branch 'irc' of git://www.tiodante.com/git/factor
commit
977a6e0455
|
@ -19,7 +19,7 @@ SYMBOL: current-irc-client
|
|||
|
||||
UNION: to-target privmsg notice ;
|
||||
UNION: to-channel join part topic kick rpl-channel-modes
|
||||
rpl-notopic rpl-topic rpl-names rpl-names-end ;
|
||||
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 ;
|
||||
|
|
|
@ -33,7 +33,8 @@ 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
|
||||
chats is-running nick connect is-ready
|
||||
reconnect-time reconnect-attempts
|
||||
exceptions ;
|
||||
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
|
@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
|
|||
<mailbox> >>in-messages
|
||||
<mailbox> >>out-messages
|
||||
H{ } clone >>chats
|
||||
15 seconds >>reconnect-time
|
||||
30 seconds >>reconnect-time
|
||||
10 >>reconnect-attempts
|
||||
V{ } clone >>exceptions
|
||||
[ <inet> latin1 <client> ] >>connect ;
|
||||
[ <inet> latin1 <client> drop ] >>connect ;
|
||||
|
||||
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
|
||||
|
|
|
@ -76,7 +76,7 @@ M: mb-writer dispose drop ;
|
|||
! Test connect
|
||||
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
|
||||
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
|
||||
[ 2drop <test-stream> t ] >>connect
|
||||
[ 2drop <test-stream> ] >>connect
|
||||
[
|
||||
(connect-irc)
|
||||
(do-login)
|
||||
|
|
|
@ -3,10 +3,17 @@
|
|||
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 ;
|
||||
combinators irc.messages.parser math ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client.internals
|
||||
|
||||
: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
|
||||
dup 0 > [
|
||||
[ drop call( host port -- stream ) ]
|
||||
[ drop 15 sleep 1- do-connect ]
|
||||
recover
|
||||
] [ 2drop 2drop f ] if ;
|
||||
|
||||
: /NICK ( nick -- ) "NICK " prepend irc-print ;
|
||||
: /PONG ( text -- ) "PONG " prepend irc-print ;
|
||||
|
||||
|
@ -15,18 +22,27 @@ IN: irc.client.internals
|
|||
"USER " prepend " hostname servername :irc.factor" append irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call( host port -- stream local ) drop ;
|
||||
irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
|
||||
|
||||
: try-connect ( -- stream/f )
|
||||
irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
|
||||
|
||||
: (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 ;
|
||||
|
||||
: (connect-irc) ( -- )
|
||||
irc> {
|
||||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
|
||||
[ (>>stream) ]
|
||||
[ t swap (>>is-running) ]
|
||||
[ in-messages>> [ irc-connected ] dip mailbox-put ]
|
||||
} cleave ;
|
||||
try-connect [
|
||||
[ irc> ] dip >>stream t >>is-running
|
||||
in-messages>> [ irc-connected ] dip mailbox-put
|
||||
] [ (terminate-irc) ] if* ;
|
||||
|
||||
: (do-login) ( -- ) irc> nick>> /LOGIN ;
|
||||
|
||||
|
@ -52,7 +68,7 @@ M: to-all-chats message-forwards drop chats> ;
|
|||
M: to-many-chats message-forwards sender>> participant-chats ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
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 ;
|
||||
|
@ -92,9 +108,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
|||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc-disconnected irc> in-messages>> mailbox-put
|
||||
irc> reconnect-time>> sleep
|
||||
(connect-irc)
|
||||
(do-login) ;
|
||||
(connect-irc) (do-login) ;
|
||||
|
||||
: handle-disconnect ( error -- ? )
|
||||
[ irc> exceptions>> push ] when*
|
||||
|
@ -155,12 +169,4 @@ 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 ;
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
|
|
|
@ -11,6 +11,12 @@ GENERIC: >log-line ( object -- line )
|
|||
|
||||
M: irc-message >log-line line>> ;
|
||||
|
||||
M: ctcp >log-line
|
||||
[ "CTCP: " % dup sender>> % " " % text>> % ] "" make ;
|
||||
|
||||
M: action >log-line
|
||||
[ "* " % dup sender>> % " " % text>> % ] "" make ;
|
||||
|
||||
M: privmsg >log-line
|
||||
[ "<" % dup sender>> % "> " % text>> % ] "" make ;
|
||||
|
||||
|
@ -35,3 +41,7 @@ M: participant-mode >log-line
|
|||
|
||||
M: nick >log-line
|
||||
[ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
|
||||
|
||||
M: topic >log-line
|
||||
[ "* " % dup sender>> % " has set the topic for " % dup channel>> %
|
||||
": \"" % topic>> % "\"" % ] "" make ;
|
||||
|
|
|
@ -16,7 +16,7 @@ SYMBOL: current-stream
|
|||
"irc.freenode.org" 6667 "flogger" f <irc-profile> ;
|
||||
|
||||
: add-timestamp ( string timestamp -- string )
|
||||
timestamp>hms "[" prepend "] " append prepend ;
|
||||
timestamp>hms [ "[" % % "] " % % ] "" make ;
|
||||
|
||||
: timestamp-path ( timestamp -- path )
|
||||
timestamp>ymd ".log" append log-directory prepend-path ;
|
||||
|
@ -27,7 +27,7 @@ SYMBOL: current-stream
|
|||
] [
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-writer> ] bi
|
||||
[ timestamp-path latin1 <file-appender> ] bi
|
||||
current-stream set
|
||||
] if current-stream get ;
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
USING: accessors arrays assocs calendar classes.parser classes.tuple
|
||||
combinators fry generic.parser kernel lexer
|
||||
mirrors namespaces parser sequences splitting strings words ;
|
||||
IN: irc.messages.base
|
||||
|
@ -51,6 +51,7 @@ M: irc-message post-process-irc-message drop ;
|
|||
|
||||
GENERIC: fill-irc-message-slots ( irc-message -- )
|
||||
M: irc-message fill-irc-message-slots
|
||||
gmt >>timestamp
|
||||
{
|
||||
[ process-irc-trailing ]
|
||||
[ process-irc-prefix ]
|
||||
|
|
|
@ -71,4 +71,7 @@ IN: irc.messages.tests
|
|||
{ name "nickname" }
|
||||
{ trailing "Nickname is already in use" } } }
|
||||
[ ":ircserver.net 433 * nickname :Nickname is already in use"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!"
|
||||
string>irc-message action? ] unit-test
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! 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 strings irc.messages.base ;
|
||||
arrays classes.tuple math.order words assocs strings irc.messages.base
|
||||
combinators.short-circuit math ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages
|
||||
|
||||
|
@ -61,8 +62,17 @@ IRC: rpl-names-end "366" nickname channel : comment ;
|
|||
IRC: rpl-nickname-in-use "433" _ name ;
|
||||
IRC: rpl-nick-collision "436" nickname : comment ;
|
||||
|
||||
PREDICATE: channel-mode < mode name>> first "#&" member? ;
|
||||
PREDICATE: participant-mode < channel-mode parameter>> ;
|
||||
PREDICATE: ctcp < privmsg
|
||||
trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
|
||||
PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
|
||||
|
||||
M: rpl-names post-process-irc-message ( rpl-names -- )
|
||||
[ [ blank? ] trim " " split ] change-nicks drop ;
|
||||
|
||||
PREDICATE: channel-mode < mode name>> first "#&" member? ;
|
||||
PREDICATE: participant-mode < channel-mode parameter>> ;
|
||||
M: ctcp post-process-irc-message ( ctcp -- )
|
||||
[ rest but-last ] change-text drop ;
|
||||
|
||||
M: action post-process-irc-message ( action -- )
|
||||
[ 7 tail ] change-text call-next-method ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
USING: kernel fry splitting ascii accessors combinators
|
||||
arrays classes.tuple math.order words assocs
|
||||
irc.messages.base sequences ;
|
||||
IN: irc.messages.parser
|
||||
|
@ -32,4 +32,4 @@ PRIVATE>
|
|||
[ >>trailing ]
|
||||
tri*
|
||||
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
|
||||
now >>timestamp dup sender >>sender ;
|
||||
dup sender >>sender ;
|
||||
|
|
Loading…
Reference in New Issue