! 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
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+
<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
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 ;
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 ;
: /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
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 ;
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 ;
! ======================================
! ======================================
: 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 -- )
: (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 ;
{
{ [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
+ [ nip ]
} cond ;
: listener-loop ( name 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 -- )
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 -- )
[ 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>
! 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 ;
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
{ "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] }
+ { "353" [ \ names-reply ] }
{ "JOIN" [ \ join ] }
{ "PART" [ \ part ] }
{ "PRIVMSG" [ \ privmsg ] }
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
+\r
+IN: irc.ui.commandparser\r
+\r
+"irc.ui.commands" require\r
+\r
+: command ( string string -- string command )\r
+ dup empty? [ drop "say" ] when\r
+ dup "irc.ui.commands" lookup\r
+ [ nip ]\r
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
+\r
+: parse-message ( string -- )\r
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel irc.client irc.messages irc.ui namespaces ;\r
+\r
+IN: irc.ui.commands\r
+\r
+: say ( string -- )\r
+ [ client get profile>> nickname>> <own-message> print-irc ]\r
+ [ listener get write-message ] bi ;\r
+\r
+: quote ( string -- )\r
+ drop ; ! THIS WILL CHANGE\r
--- /dev/null
+! Default system ircui-rc file\r
+! Copy into .ircui-rc in your home directory and then change username and such\r
+! To find your home directory, type "home ." into a Factor listener\r
+\r
+USING: irc.client irc.ui ;\r
+\r
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
+server-open\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel io.files parser editors sequences ;\r
+\r
+IN: irc.ui.load\r
+\r
+: file-or ( path path -- path ) over exists? ? ;\r
+\r
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
+\r
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
+\r
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
+\r
+: run-ircui ( -- ) ircui-rc run-file ;\r
\r
USING: accessors kernel threads combinators concurrency.mailboxes\r
sequences strings hashtables splitting fry assocs hashtables\r
- ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
- ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
- io io.styles namespaces irc.client irc.messages ;\r
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
+ ui.gadgets.tabs ui.gadgets.grids\r
+ io io.styles namespaces calendar calendar.format\r
+ irc.client irc.client.private irc.messages irc.messages.private\r
+ irc.ui.commandparser irc.ui.load ;\r
\r
IN: irc.ui\r
\r
+SYMBOL: listener\r
+\r
SYMBOL: client\r
\r
TUPLE: ui-window client tabs ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
\r
-: prefix>nick ( prefix -- nick )\r
- "!" split first ;\r
+: dot-or-parens ( string -- string )\r
+ dup empty? [ drop "." ]\r
+ [ "(" prepend ")" append ] if ;\r
\r
GENERIC: write-irc ( irc-message -- )\r
\r
M: privmsg write-irc\r
"<" blue write-color\r
- [ prefix>> prefix>nick write ] keep\r
- ">" blue write-color\r
- " " write\r
+ [ prefix>> parse-name write ] keep\r
+ "> " blue write-color\r
trailing>> write ;\r
\r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+ now own-message boa ;\r
+\r
+M: own-message write-irc\r
+ "<" blue write-color\r
+ [ nick>> bold font-style associate format ] keep\r
+ "> " blue write-color\r
+ message>> write ;\r
+\r
M: join write-irc\r
"* " green write-color\r
- prefix>> prefix>nick write\r
+ prefix>> parse-name write\r
" has entered the channel." green write-color ;\r
\r
M: part write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left the channel(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left the channel" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: quit write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left IRC(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left IRC" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
\r
: print-irc ( irc-message -- )\r
- write-irc nl ;\r
+ [ timestamp>> timestamp>hms write " " write ]\r
+ [ write-irc nl ] bi ;\r
\r
-: send-message ( message listener client -- )\r
- "<" blue write-color\r
- profile>> nickname>> bold font-style associate format\r
- ">" blue write-color\r
- " " write\r
- over write nl\r
- out-messages>> mailbox-put ;\r
+: send-message ( message -- )\r
+ [ print-irc ]\r
+ [ listener get write-message ] bi ;\r
\r
: display ( stream listener -- )\r
'[ , [ [ t ]\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( pane listener client -- editor )\r
- [ irc-editor new-editor\r
+: <irc-editor> ( page pane listener -- client editor )\r
+ irc-editor new-editor\r
swap >>listener swap <pane-stream> >>outstream\r
- ] dip client>> >>client ;\r
+ over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ [ outstream>> ]\r
- [ editor-string ]\r
[ listener>> ]\r
[ client>> ]\r
+ [ editor-string ]\r
[ "" swap set-editor-string ] } cleave\r
- '[ , , , send-message ] with-output-stream ;\r
+ '[ , listener set , client set , parse-message ] with-output-stream ;\r
\r
irc-editor "general" f {\r
{ T{ key-down f f "RET" } editor-send }\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-: irc-page ( name pane editor tabbed -- )\r
- [ [ <scroller> @bottom frame, ! editor\r
- <scroller> @center frame, ! pane\r
- ] make-frame swap ] dip add-page ;\r
+TUPLE: irc-page < frame listener client ;\r
+\r
+: <irc-page> ( listener client -- irc-page )\r
+ irc-page new-frame\r
+ swap client>> >>client swap [ >>listener ] keep\r
+ [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
+ [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+\r
+M: irc-page graft*\r
+ [ listener>> ] [ client>> ] bi\r
+ add-listener ;\r
+\r
+M: irc-page ungraft*\r
+ [ listener>> ] [ client>> ] bi\r
+ remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ client>> add-listener ]\r
- [ drop <irc-pane> dup ]\r
- [ [ <irc-editor> ] keep ] 2tri\r
- tabs>> irc-page ;\r
+ [ <irc-page> swap ] keep\r
+ tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
[ tabs>> ]\r
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
-: freenode-connect ( -- ui-window )\r
- "irc.freenode.org" 8001 "factor-irc" f\r
- <irc-profile> ui-connect [ irc-window ] keep ;\r
+: server-open ( server port nick password channels -- )\r
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
+ [ over join-channel ] each ;\r
+\r
+: main-run ( -- ) run-ircui ;\r
+\r
+MAIN: main-run\r
projects / factor.git / commitdiff