Merge branch 'master' of git://factorforge.org/git/william42
Slava Pestov
commit
5aefbe5f85
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
||||
accessors destructors namespaces io assocs arrays qualified fry
|
||||
continuations threads strings classes combinators
|
||||
irc.messages irc.messages.private ;
|
||||
continuations threads strings classes combinators splitting hashtables
|
||||
ascii irc.messages irc.messages.private ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client
|
||||
|
|
@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages
|
|||
|
||||
TUPLE: irc-listener in-messages out-messages ;
|
||||
TUPLE: irc-server-listener < irc-listener ;
|
||||
TUPLE: irc-channel-listener < irc-listener name password timeout ;
|
||||
TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
|
||||
TUPLE: irc-nick-listener < irc-listener name ;
|
||||
SYMBOL: +server-listener+
|
||||
|
||||
|
|
@ -37,10 +37,10 @@ SYMBOL: +server-listener+
|
|||
<mailbox> <mailbox> irc-server-listener boa ;
|
||||
|
||||
: <irc-channel-listener> ( name -- irc-channel-listener )
|
||||
<mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
|
||||
[ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
|
||||
|
||||
: <irc-nick-listener> ( name -- irc-nick-listener )
|
||||
<mailbox> <mailbox> rot irc-nick-listener boa ;
|
||||
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
|
||||
|
||||
! ======================================
|
||||
! Message objects
|
||||
|
|
@ -52,8 +52,8 @@ SINGLETON: irc-connected ! sent when connection is established
|
|||
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
[ in-messages>> irc-end swap mailbox-put ]
|
||||
[ f >>is-running drop ]
|
||||
[ [ irc-end ] dip in-messages>> mailbox-put ]
|
||||
[ [ f ] dip (>>is-running) ]
|
||||
[ stream>> dispose ]
|
||||
tri ;
|
||||
|
||||
|
|
@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
|||
listener> [ +server-listener+ listener> ] unless*
|
||||
[ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
|
||||
: remove-participant ( nick channel -- )
|
||||
listener> [ participants>> delete-at ] [ drop ] if* ;
|
||||
|
||||
: remove-participant-from-all ( nick -- )
|
||||
irc> listeners>>
|
||||
[ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
|
||||
assoc-each ;
|
||||
|
||||
: add-participant ( nick mode channel -- )
|
||||
listener> [ participants>> set-at ] [ 2drop ] if* ;
|
||||
|
||||
DEFER: me?
|
||||
|
||||
: maybe-forward-join ( join -- )
|
||||
[ prefix>> parse-name me? ] keep and
|
||||
[ irc> join-messages>> mailbox-put ] when* ;
|
||||
|
||||
! ======================================
|
||||
! IRC client messages
|
||||
! ======================================
|
||||
|
||||
GENERIC: irc-message>string ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>string ( irc-message -- string )
|
||||
[ command>> ]
|
||||
[ parameters>> " " sjoin ]
|
||||
[ trailing>> dup [ CHAR: : prefix ] when ]
|
||||
tri 3array " " sjoin ;
|
||||
|
||||
: /NICK ( nick -- )
|
||||
"NICK " irc-write irc-print ;
|
||||
|
||||
|
|
@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string )
|
|||
|
||||
: /JOIN ( channel password -- )
|
||||
"JOIN " irc-write
|
||||
[ " :" swap 3append ] when* irc-print ;
|
||||
[ [ " :" ] dip 3append ] when* irc-print ;
|
||||
|
||||
: /PART ( channel text -- )
|
||||
[ "PART " irc-write irc-write ] dip
|
||||
|
|
@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- )
|
|||
dup irc-message-origin to-listener ;
|
||||
|
||||
M: join handle-incoming-irc ( join -- )
|
||||
[ [ prefix>> parse-name me? ] keep and
|
||||
[ irc> join-messages>> mailbox-put ] when* ]
|
||||
[ maybe-forward-join ]
|
||||
[ dup trailing>> to-listener ]
|
||||
bi ;
|
||||
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
|
||||
tri ;
|
||||
|
||||
M: part handle-incoming-irc ( part -- )
|
||||
dup channel>> to-listener ;
|
||||
[ dup channel>> to-listener ] keep
|
||||
[ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
|
||||
|
||||
M: kick handle-incoming-irc ( kick -- )
|
||||
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
|
||||
to-listener ;
|
||||
[ dup channel>> to-listener ]
|
||||
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
||||
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
|
||||
tri ;
|
||||
|
||||
M: quit handle-incoming-irc ( quit -- )
|
||||
[ prefix>> parse-name remove-participant-from-all ] keep
|
||||
call-next-method ;
|
||||
|
||||
: >nick/mode ( string -- nick mode )
|
||||
dup first "+@" member? [ unclip ] [ f ] if ;
|
||||
|
||||
: names-reply>participants ( names-reply -- participants )
|
||||
trailing>> [ blank? ] trim " " split
|
||||
[ >nick/mode 2array ] map >hashtable ;
|
||||
|
||||
M: names-reply handle-incoming-irc ( names-reply -- )
|
||||
[ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;
|
||||
|
||||
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
||||
broadcast-message-to-listeners ;
|
||||
|
|
@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- )
|
|||
M: privmsg handle-outgoing-irc ( privmsg -- )
|
||||
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
||||
|
||||
M: part handle-outgoing-irc ( privmsg -- )
|
||||
M: part handle-outgoing-irc ( part -- )
|
||||
[ channel>> ] [ trailing>> "" or ] bi /PART ;
|
||||
|
||||
! ======================================
|
||||
|
|
@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- )
|
|||
! ======================================
|
||||
|
||||
: irc-mailbox-get ( mailbox quot -- )
|
||||
swap 5 seconds
|
||||
'[ , , , mailbox-get-timeout swap call ]
|
||||
[ 5 seconds ] dip
|
||||
'[ , , , [ mailbox-get-timeout ] dip call ]
|
||||
[ drop ] recover ; inline
|
||||
|
||||
: handle-reader-message ( irc-message -- )
|
||||
|
|
@ -199,11 +225,12 @@ DEFER: (connect-irc)
|
|||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc>
|
||||
[ in-messages>> irc-disconnected swap mailbox-put ]
|
||||
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
|
||||
[ dup reconnect-time>> sleep (connect-irc) ]
|
||||
[ profile>> nickname>> /LOGIN ]
|
||||
tri ;
|
||||
|
||||
! FIXME: do something with the exception, store somewhere to help debugging
|
||||
: handle-disconnect ( error -- )
|
||||
drop irc> is-running>> [ (handle-disconnect) ] when ;
|
||||
|
||||
|
|
@ -236,6 +263,7 @@ DEFER: (connect-irc)
|
|||
{
|
||||
{ [ dup string? ] [ strings>privmsg ] }
|
||||
{ [ dup privmsg instance? ] [ swap >>name ] }
|
||||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
: listener-loop ( name listener -- )
|
||||
|
|
@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
|
|||
[ name>> ] keep set+run-listener ;
|
||||
|
||||
M: irc-server-listener (add-listener) ( irc-server-listener -- )
|
||||
+server-listener+ swap set+run-listener ;
|
||||
[ +server-listener+ ] dip set+run-listener ;
|
||||
|
||||
GENERIC: (remove-listener) ( irc-listener -- )
|
||||
|
||||
|
|
@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
|
|||
name>> unregister-listener ;
|
||||
|
||||
M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
|
||||
[ [ out-messages>> ] [ name>> ] bi
|
||||
\ part new swap >>channel mailbox-put ] keep
|
||||
[ [ name>> ] [ out-messages>> ] bi
|
||||
[ [ part new ] dip >>channel ] dip mailbox-put ] keep
|
||||
name>> unregister-listener ;
|
||||
|
||||
M: irc-server-listener (remove-listener) ( irc-server-listener -- )
|
||||
|
|
@ -294,10 +322,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
|
|||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
|
||||
swap >>stream
|
||||
t >>is-running
|
||||
in-messages>> irc-connected swap mailbox-put ;
|
||||
in-messages>> [ irc-connected ] dip mailbox-put ;
|
||||
|
||||
: with-irc-client ( irc-client quot -- )
|
||||
>r current-irc-client r> with-variable ; inline
|
||||
[ current-irc-client ] dip with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry sequences splitting ascii calendar accessors combinators
|
||||
classes.tuple math.order ;
|
||||
USING: kernel fry splitting ascii calendar accessors combinators qualified
|
||||
arrays classes.tuple math.order ;
|
||||
RENAME: join sequences => sjoin
|
||||
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 channel ;
|
||||
TUPLE: join < irc-message ;
|
||||
TUPLE: part < irc-message channel ;
|
||||
TUPLE: quit < irc-message ;
|
||||
TUPLE: privmsg < irc-message name ;
|
||||
|
|
@ -16,8 +18,21 @@ TUPLE: roomlist < irc-message channel names ;
|
|||
TUPLE: nick-in-use < irc-message asterisk name ;
|
||||
TUPLE: notice < irc-message type ;
|
||||
TUPLE: mode < irc-message name channel mode ;
|
||||
TUPLE: names-reply < irc-message who = channel ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
GENERIC: irc-message>client-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>client-line ( irc-message -- string )
|
||||
[ command>> ]
|
||||
[ parameters>> " " sjoin ]
|
||||
[ trailing>> dup [ CHAR: : prefix ] when ]
|
||||
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
|
||||
|
|
@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
|
|||
{ "NOTICE" [ \ notice ] }
|
||||
{ "001" [ \ logged-in ] }
|
||||
{ "433" [ \ nick-in-use ] }
|
||||
{ "353" [ \ names-reply ] }
|
||||
{ "JOIN" [ \ join ] }
|
||||
{ "PART" [ \ part ] }
|
||||
{ "PRIVMSG" [ \ privmsg ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
|
||||
|
||||
IN: irc.ui.commandparser
|
||||
|
||||
"irc.ui.commands" require
|
||||
|
||||
: command ( string string -- string command )
|
||||
dup empty? [ drop "say" ] when
|
||||
dup "irc.ui.commands" lookup
|
||||
[ nip ]
|
||||
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
|
||||
|
||||
: parse-message ( string -- )
|
||||
"/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
|
||||
|
||||
IN: irc.ui.commands
|
||||
|
||||
: say ( string -- )
|
||||
[ client get profile>> nickname>> <own-message> print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: quote ( string -- )
|
||||
drop ; ! THIS WILL CHANGE
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Default system ircui-rc file
|
||||
! Copy into .ircui-rc in your home directory and then change username and such
|
||||
! To find your home directory, type "home ." into a Factor listener
|
||||
|
||||
USING: irc.client irc.ui ;
|
||||
|
||||
"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
|
||||
{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
|
||||
server-open
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel io.files parser editors sequences ;
|
||||
|
||||
IN: irc.ui.load
|
||||
|
||||
: file-or ( path path -- path ) over exists? ? ;
|
||||
|
||||
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
|
||||
|
||||
: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
|
||||
|
||||
: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
|
||||
|
||||
: run-ircui ( -- ) ircui-rc run-file ;
|
||||
|
|
@ -3,12 +3,17 @@
|
|||
|
||||
USING: accessors kernel threads combinators concurrency.mailboxes
|
||||
sequences strings hashtables splitting fry assocs hashtables
|
||||
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
|
||||
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
|
||||
io io.styles namespaces irc.client irc.messages ;
|
||||
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
|
||||
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
|
||||
ui.gadgets.tabs ui.gadgets.grids
|
||||
io io.styles namespaces calendar calendar.format
|
||||
irc.client irc.client.private irc.messages irc.messages.private
|
||||
irc.ui.commandparser irc.ui.load ;
|
||||
|
||||
IN: irc.ui
|
||||
|
||||
SYMBOL: listener
|
||||
|
||||
SYMBOL: client
|
||||
|
||||
TUPLE: ui-window client tabs ;
|
||||
|
|
@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ;
|
|||
: green { 0 0.5 0 1 } ;
|
||||
: blue { 0 0 1 1 } ;
|
||||
|
||||
: prefix>nick ( prefix -- nick )
|
||||
"!" split first ;
|
||||
: dot-or-parens ( string -- string )
|
||||
dup empty? [ drop "." ]
|
||||
[ "(" prepend ")" append ] if ;
|
||||
|
||||
GENERIC: write-irc ( irc-message -- )
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
">" blue write-color
|
||||
" " write
|
||||
[ prefix>> parse-name write ] keep
|
||||
"> " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
TUPLE: own-message message nick timestamp ;
|
||||
|
||||
: <own-message> ( message nick -- own-message )
|
||||
now own-message boa ;
|
||||
|
||||
M: own-message write-irc
|
||||
"<" blue write-color
|
||||
[ nick>> bold font-style associate format ] keep
|
||||
"> " blue write-color
|
||||
message>> write ;
|
||||
|
||||
M: join write-irc
|
||||
"* " green write-color
|
||||
prefix>> prefix>nick write
|
||||
prefix>> parse-name write
|
||||
" has entered the channel." green write-color ;
|
||||
|
||||
M: part write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left the channel(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left the channel" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: quit write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left IRC(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left IRC" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: irc-end write-irc
|
||||
drop "* You have left IRC" red write-color ;
|
||||
|
|
@ -63,15 +77,12 @@ M: irc-message write-irc
|
|||
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
|
||||
|
||||
: print-irc ( irc-message -- )
|
||||
write-irc nl ;
|
||||
[ timestamp>> timestamp>hms write " " write ]
|
||||
[ write-irc nl ] bi ;
|
||||
|
||||
: send-message ( message listener client -- )
|
||||
"<" blue write-color
|
||||
profile>> nickname>> bold font-style associate format
|
||||
">" blue write-color
|
||||
" " write
|
||||
over write nl
|
||||
out-messages>> mailbox-put ;
|
||||
: send-message ( message -- )
|
||||
[ print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: display ( stream listener -- )
|
||||
'[ , [ [ t ]
|
||||
|
|
@ -84,35 +95,44 @@ M: irc-message write-irc
|
|||
|
||||
TUPLE: irc-editor < editor outstream listener client ;
|
||||
|
||||
: <irc-editor> ( pane listener client -- editor )
|
||||
[ irc-editor new-editor
|
||||
: <irc-editor> ( page pane listener -- client editor )
|
||||
irc-editor new-editor
|
||||
swap >>listener swap <pane-stream> >>outstream
|
||||
] dip client>> >>client ;
|
||||
over client>> >>client ;
|
||||
|
||||
: editor-send ( irc-editor -- )
|
||||
{ [ outstream>> ]
|
||||
[ editor-string ]
|
||||
[ listener>> ]
|
||||
[ client>> ]
|
||||
[ editor-string ]
|
||||
[ "" swap set-editor-string ] } cleave
|
||||
'[ , , , send-message ] with-output-stream ;
|
||||
'[ , listener set , client set , parse-message ] with-output-stream ;
|
||||
|
||||
irc-editor "general" f {
|
||||
{ T{ key-down f f "RET" } editor-send }
|
||||
{ T{ key-down f f "ENTER" } editor-send }
|
||||
} define-command-map
|
||||
|
||||
: irc-page ( name pane editor tabbed -- )
|
||||
[ [ <scroller> @bottom frame, ! editor
|
||||
<scroller> @center frame, ! pane
|
||||
] make-frame swap ] dip add-page ;
|
||||
TUPLE: irc-page < frame listener client ;
|
||||
|
||||
: <irc-page> ( listener client -- irc-page )
|
||||
irc-page new-frame
|
||||
swap client>> >>client swap [ >>listener ] keep
|
||||
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
|
||||
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
|
||||
|
||||
M: irc-page graft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
add-listener ;
|
||||
|
||||
M: irc-page ungraft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
remove-listener ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ client>> add-listener ]
|
||||
[ drop <irc-pane> dup ]
|
||||
[ [ <irc-editor> ] keep ] 2tri
|
||||
tabs>> irc-page ;
|
||||
[ <irc-page> swap ] keep
|
||||
tabs>> add-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
[ tabs>> ]
|
||||
|
|
@ -125,6 +145,10 @@ irc-editor "general" f {
|
|||
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
|
||||
: freenode-connect ( -- ui-window )
|
||||
"irc.freenode.org" 8001 "factor-irc" f
|
||||
<irc-profile> ui-connect [ irc-window ] keep ;
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
[ over join-channel ] each ;
|
||||
|
||||
: main-run ( -- ) run-ircui ;
|
||||
|
||||
MAIN: main-run
|
||||
|
|
|
|||
Loading…
Reference in New Issue