Merge branch 'master' of git://tiodante.com/git/factor
						commit
						fb96fe25c1
					
				| 
						 | 
				
			
			@ -0,0 +1,275 @@
 | 
			
		|||
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: arrays combinators concurrency.mailboxes concurrency.futures io
 | 
			
		||||
       io.encodings.8-bit io.sockets kernel namespaces sequences
 | 
			
		||||
       sequences.lib splitting threads calendar classes.tuple
 | 
			
		||||
       ascii assocs accessors destructors ;
 | 
			
		||||
IN: irc.client
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Setup and running objects
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
SYMBOL: current-irc-client
 | 
			
		||||
 | 
			
		||||
: irc-port 6667 ; ! Default irc port
 | 
			
		||||
 | 
			
		||||
! "setup" objects
 | 
			
		||||
TUPLE: irc-profile server port nickname password ;
 | 
			
		||||
C: <irc-profile> irc-profile
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-channel-profile name password ;
 | 
			
		||||
: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
 | 
			
		||||
 | 
			
		||||
! "live" objects
 | 
			
		||||
TUPLE: nick name channels log ;
 | 
			
		||||
C: <nick> nick
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-client profile nick stream in-messages out-messages join-messages
 | 
			
		||||
       listeners is-running ;
 | 
			
		||||
: <irc-client> ( profile -- irc-client )
 | 
			
		||||
    f V{ } clone V{ } clone <nick>
 | 
			
		||||
    f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-listener in-messages out-messages ;
 | 
			
		||||
: <irc-listener> ( -- irc-listener )
 | 
			
		||||
    <mailbox> <mailbox> irc-listener boa ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Message objects
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
SINGLETON: irc-end ! Message used when the client isn't running anymore
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
 | 
			
		||||
TUPLE: logged-in < irc-message name ;
 | 
			
		||||
TUPLE: ping < irc-message ;
 | 
			
		||||
TUPLE: join < irc-message ;
 | 
			
		||||
TUPLE: part < irc-message name channel ;
 | 
			
		||||
TUPLE: quit < irc-message ;
 | 
			
		||||
TUPLE: privmsg < irc-message name ;
 | 
			
		||||
TUPLE: kick < irc-message channel who ;
 | 
			
		||||
TUPLE: roomlist < irc-message channel names ;
 | 
			
		||||
TUPLE: nick-in-use < irc-message asterisk name ;
 | 
			
		||||
TUPLE: notice < irc-message type ;
 | 
			
		||||
TUPLE: mode < irc-message name channel mode ;
 | 
			
		||||
TUPLE: unhandled < irc-message ;
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Shortcuts
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
: irc-client> ( -- irc-client ) current-irc-client get ;
 | 
			
		||||
: irc-stream> ( -- stream ) irc-client> stream>> ;
 | 
			
		||||
: irc-write ( s -- ) irc-stream> stream-write ;
 | 
			
		||||
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! 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 )
 | 
			
		||||
    <inet> latin1 <client> drop ;
 | 
			
		||||
 | 
			
		||||
: /JOIN ( channel password -- )
 | 
			
		||||
    "JOIN " irc-write
 | 
			
		||||
    [ " :" swap 3append ] when* irc-print ;
 | 
			
		||||
 | 
			
		||||
: /PART ( channel text -- )
 | 
			
		||||
    [ "PART " irc-write irc-write ] dip
 | 
			
		||||
    " :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: /KICK ( channel who -- )
 | 
			
		||||
    [ "KICK " irc-write irc-write ] dip
 | 
			
		||||
    " " irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: /PRIVMSG ( nick line -- )
 | 
			
		||||
    [ "PRIVMSG " irc-write irc-write ] dip
 | 
			
		||||
    " :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: /ACTION ( nick line -- )
 | 
			
		||||
    [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
 | 
			
		||||
 | 
			
		||||
: /QUIT ( text -- )
 | 
			
		||||
    "QUIT :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: /PONG ( text -- )
 | 
			
		||||
    "PONG " irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Server message handling
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
USE: prettyprint
 | 
			
		||||
 | 
			
		||||
GENERIC: handle-incoming-irc ( irc-message -- )
 | 
			
		||||
 | 
			
		||||
M: irc-message handle-incoming-irc ( irc-message -- )
 | 
			
		||||
    . ;
 | 
			
		||||
 | 
			
		||||
M: logged-in handle-incoming-irc ( logged-in -- )
 | 
			
		||||
    name>> irc-client> nick>> (>>name) ;
 | 
			
		||||
 | 
			
		||||
M: ping handle-incoming-irc ( ping -- )
 | 
			
		||||
    trailing>> /PONG ;
 | 
			
		||||
 | 
			
		||||
M: nick-in-use handle-incoming-irc ( nick-in-use -- )
 | 
			
		||||
    name>> "_" append /NICK ;
 | 
			
		||||
 | 
			
		||||
M: privmsg handle-incoming-irc ( privmsg -- )
 | 
			
		||||
    dup name>> irc-client> listeners>> at
 | 
			
		||||
    [ in-messages>> mailbox-put ] [ drop ] if* ;
 | 
			
		||||
 | 
			
		||||
M: join handle-incoming-irc ( join -- )
 | 
			
		||||
    irc-client> join-messages>> mailbox-put ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Client message handling
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
GENERIC: handle-outgoing-irc ( obj -- )
 | 
			
		||||
 | 
			
		||||
M: privmsg handle-outgoing-irc ( privmsg -- )
 | 
			
		||||
   [ name>> ] [ trailing>> ] bi /PRIVMSG ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Message parsing
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
: split-at-first ( seq separators -- before after )
 | 
			
		||||
    dupd [ member? ] curry find
 | 
			
		||||
        [ cut 1 tail ]
 | 
			
		||||
        [ swap ]
 | 
			
		||||
    if ;
 | 
			
		||||
 | 
			
		||||
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
 | 
			
		||||
 | 
			
		||||
: 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 ;
 | 
			
		||||
 | 
			
		||||
: string>irc-message ( string -- object )
 | 
			
		||||
    dup split-prefix split-trailing
 | 
			
		||||
    [ [ blank? ] trim " " split unclip swap ] dip
 | 
			
		||||
    now irc-message boa ;
 | 
			
		||||
 | 
			
		||||
: parse-irc-line ( string -- message )
 | 
			
		||||
    string>irc-message
 | 
			
		||||
    dup command>> {
 | 
			
		||||
        { "PING" [ \ ping ] }
 | 
			
		||||
        { "NOTICE" [ \ notice ] }
 | 
			
		||||
        { "001" [ \ logged-in ] }
 | 
			
		||||
        { "433" [ \ nick-in-use ] }
 | 
			
		||||
        { "JOIN" [ \ join ] }
 | 
			
		||||
        { "PART" [ \ part ] }
 | 
			
		||||
        { "PRIVMSG" [ \ privmsg ] }
 | 
			
		||||
        { "QUIT" [ \ quit ] }
 | 
			
		||||
        { "MODE" [ \ mode ] }
 | 
			
		||||
        { "KICK" [ \ kick ] }
 | 
			
		||||
        [ drop \ unhandled ]
 | 
			
		||||
    } case
 | 
			
		||||
    [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Reader/Writer
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
: stream-readln-or-close ( stream -- str/f )
 | 
			
		||||
    dup stream-readln [ nip ] [ dispose f ] if* ;
 | 
			
		||||
 | 
			
		||||
: handle-reader-message ( irc-message -- )
 | 
			
		||||
    irc-client> in-messages>> mailbox-put ;
 | 
			
		||||
 | 
			
		||||
: handle-stream-close ( -- )
 | 
			
		||||
    irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
 | 
			
		||||
 | 
			
		||||
: reader-loop ( -- )
 | 
			
		||||
    irc-client> stream>> stream-readln-or-close [
 | 
			
		||||
        parse-irc-line handle-reader-message
 | 
			
		||||
    ] [
 | 
			
		||||
        handle-stream-close
 | 
			
		||||
    ] if* ;
 | 
			
		||||
 | 
			
		||||
: writer-loop ( -- )
 | 
			
		||||
    irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Processing loops
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
: in-multiplexer-loop ( -- )
 | 
			
		||||
    irc-client> in-messages>> mailbox-get handle-incoming-irc ;
 | 
			
		||||
 | 
			
		||||
! FIXME: Hack, this should be handled better
 | 
			
		||||
GENERIC: add-name ( name obj -- obj )
 | 
			
		||||
M: object add-name nip ;
 | 
			
		||||
M: privmsg add-name swap >>name ;
 | 
			
		||||
    
 | 
			
		||||
: listener-loop ( name -- ) ! FIXME: take different values from the stack?
 | 
			
		||||
    dup irc-client> listeners>> at [
 | 
			
		||||
        out-messages>> mailbox-get add-name
 | 
			
		||||
        irc-client> out-messages>>
 | 
			
		||||
        mailbox-put
 | 
			
		||||
    ] [ drop ] if* ;
 | 
			
		||||
 | 
			
		||||
: spawn-irc-loop ( quot name -- )
 | 
			
		||||
    [ [ irc-client> is-running>> ] compose ] dip
 | 
			
		||||
    spawn-server drop ;
 | 
			
		||||
 | 
			
		||||
: spawn-irc ( -- )
 | 
			
		||||
    [ reader-loop ] "irc-reader-loop" spawn-irc-loop
 | 
			
		||||
    [ writer-loop ] "irc-writer-loop" spawn-irc-loop
 | 
			
		||||
    [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
 | 
			
		||||
 | 
			
		||||
! ======================================
 | 
			
		||||
! Listener join request handling
 | 
			
		||||
! ======================================
 | 
			
		||||
 | 
			
		||||
: make-registered-listener ( join -- listener )
 | 
			
		||||
    <irc-listener> swap trailing>>
 | 
			
		||||
    dup [ listener-loop ] curry "listener" spawn-irc-loop
 | 
			
		||||
    [ irc-client> listeners>> set-at ] curry keep ;
 | 
			
		||||
 | 
			
		||||
: make-join-future ( name -- future )
 | 
			
		||||
    [ [ swap trailing>> = ] curry ! compare name with channel name
 | 
			
		||||
      irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
 | 
			
		||||
      make-registered-listener ]
 | 
			
		||||
    curry future ;
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
: (connect-irc) ( irc-client -- )
 | 
			
		||||
    [ profile>> [ server>> ] keep port>> /CONNECT ] keep
 | 
			
		||||
    swap >>stream
 | 
			
		||||
    t >>is-running drop ;
 | 
			
		||||
 | 
			
		||||
: connect-irc ( irc-client -- )
 | 
			
		||||
    dup current-irc-client [
 | 
			
		||||
        [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
 | 
			
		||||
        spawn-irc
 | 
			
		||||
    ] with-variable ;
 | 
			
		||||
 | 
			
		||||
: listen-to ( irc-client name -- future )
 | 
			
		||||
    swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
 | 
			
		||||
 | 
			
		||||
! shorcut for privmsgs, etc
 | 
			
		||||
: sender>> ( obj -- string )
 | 
			
		||||
    prefix>> parse-name ;
 | 
			
		||||
| 
						 | 
				
			
			@ -1,286 +0,0 @@
 | 
			
		|||
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: arrays calendar combinators channels concurrency.messaging fry io
 | 
			
		||||
       io.encodings.8-bit io.sockets kernel math namespaces sequences
 | 
			
		||||
       sequences.lib splitting strings threads
 | 
			
		||||
       continuations destructors classes.tuple ascii accessors ;
 | 
			
		||||
IN: irc
 | 
			
		||||
 | 
			
		||||
! utils
 | 
			
		||||
: split-at-first ( seq separators -- before after )
 | 
			
		||||
    dupd '[ , member? ] find
 | 
			
		||||
        [ cut rest ]
 | 
			
		||||
        [ swap ]
 | 
			
		||||
    if ;
 | 
			
		||||
 | 
			
		||||
: spawn-server-linked ( quot name -- thread )
 | 
			
		||||
    >r '[ , [ ] [ ] while ] r>
 | 
			
		||||
    spawn-linked ;
 | 
			
		||||
! ---
 | 
			
		||||
 | 
			
		||||
! Default irc port
 | 
			
		||||
: irc-port 6667 ;
 | 
			
		||||
 | 
			
		||||
! Message used when the client isn't running anymore
 | 
			
		||||
SINGLETON: irc-end
 | 
			
		||||
 | 
			
		||||
! "setup" objects
 | 
			
		||||
TUPLE: irc-profile server port nickname password default-channels  ;
 | 
			
		||||
C: <irc-profile> irc-profile
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-channel-profile name password auto-rejoin ;
 | 
			
		||||
C: <irc-channel-profile> irc-channel-profile
 | 
			
		||||
 | 
			
		||||
! "live" objects
 | 
			
		||||
TUPLE: nick name channels log ;
 | 
			
		||||
C: <nick> nick
 | 
			
		||||
 | 
			
		||||
TUPLE: irc-client profile nick stream stream-channel controller-channel
 | 
			
		||||
       listeners is-running ;
 | 
			
		||||
: <irc-client> ( profile -- irc-client )
 | 
			
		||||
    f V{ } clone V{ } clone <nick>
 | 
			
		||||
    f <channel> <channel> V{ } clone f irc-client boa ;
 | 
			
		||||
 | 
			
		||||
USE: prettyprint
 | 
			
		||||
TUPLE: irc-listener channel ;
 | 
			
		||||
! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
 | 
			
		||||
! tener la opción de dejar de correr un client??
 | 
			
		||||
: <irc-listener> ( quot -- irc-listener )
 | 
			
		||||
    <channel> irc-listener boa swap
 | 
			
		||||
    [
 | 
			
		||||
        [ channel>> '[ , from ] ]
 | 
			
		||||
        [ '[ , curry f spawn drop ] ]
 | 
			
		||||
        bi* compose "irc-listener" spawn-server-linked drop
 | 
			
		||||
    ] [ drop ] 2bi ;
 | 
			
		||||
 | 
			
		||||
! TUPLE: irc-channel name topic members log attributes ;
 | 
			
		||||
! C: <irc-channel> irc-channel
 | 
			
		||||
 | 
			
		||||
! the delegate of all irc messages
 | 
			
		||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
 | 
			
		||||
C: <irc-message> irc-message
 | 
			
		||||
 | 
			
		||||
! "irc message" objects
 | 
			
		||||
TUPLE: logged-in < irc-message name ;
 | 
			
		||||
C: <logged-in> logged-in
 | 
			
		||||
 | 
			
		||||
TUPLE: ping < irc-message ;
 | 
			
		||||
C: <ping> ping
 | 
			
		||||
 | 
			
		||||
TUPLE: join_ < irc-message ;
 | 
			
		||||
C: <join> join_
 | 
			
		||||
 | 
			
		||||
TUPLE: part < irc-message name channel ;
 | 
			
		||||
C: <part> part
 | 
			
		||||
 | 
			
		||||
TUPLE: quit ;
 | 
			
		||||
C: <quit> quit
 | 
			
		||||
 | 
			
		||||
TUPLE: privmsg < irc-message name ;
 | 
			
		||||
C: <privmsg> privmsg
 | 
			
		||||
 | 
			
		||||
TUPLE: kick < irc-message channel who ;
 | 
			
		||||
C: <kick> kick
 | 
			
		||||
 | 
			
		||||
TUPLE: roomlist < irc-message channel names ;
 | 
			
		||||
C: <roomlist> roomlist
 | 
			
		||||
 | 
			
		||||
TUPLE: nick-in-use < irc-message name ;
 | 
			
		||||
C: <nick-in-use> nick-in-use
 | 
			
		||||
 | 
			
		||||
TUPLE: notice < irc-message type ;
 | 
			
		||||
C: <notice> notice
 | 
			
		||||
 | 
			
		||||
TUPLE: mode < irc-message name channel mode ;
 | 
			
		||||
C: <mode> mode
 | 
			
		||||
 | 
			
		||||
TUPLE: unhandled < irc-message ;
 | 
			
		||||
C: <unhandled> unhandled
 | 
			
		||||
 | 
			
		||||
SYMBOL: irc-client
 | 
			
		||||
: irc-client> ( -- irc-client ) irc-client get ;
 | 
			
		||||
: irc-stream> ( -- stream ) irc-client> stream>> ;
 | 
			
		||||
 | 
			
		||||
: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ;
 | 
			
		||||
 | 
			
		||||
: parse-name ( string -- string )
 | 
			
		||||
    remove-heading-: "!" split-at-first drop ;
 | 
			
		||||
 | 
			
		||||
: sender>> ( obj -- string )
 | 
			
		||||
    prefix>> parse-name ;
 | 
			
		||||
 | 
			
		||||
: split-prefix ( string -- string/f string )
 | 
			
		||||
    dup ":" head?
 | 
			
		||||
        [ remove-heading-: " " split1 ]
 | 
			
		||||
        [ f swap ]
 | 
			
		||||
    if ;
 | 
			
		||||
 | 
			
		||||
: split-trailing ( string -- string string/f )
 | 
			
		||||
    ":" split1 ;
 | 
			
		||||
 | 
			
		||||
: string>irc-message ( string -- object )
 | 
			
		||||
    dup split-prefix split-trailing
 | 
			
		||||
    [ [ blank? ] trim " " split unclip swap ] dip
 | 
			
		||||
    now <irc-message> ;
 | 
			
		||||
 | 
			
		||||
: me? ( name -- ? )
 | 
			
		||||
    irc-client> nick>> name>> = ;
 | 
			
		||||
 | 
			
		||||
: irc-write ( s -- )
 | 
			
		||||
    irc-stream> stream-write ;
 | 
			
		||||
 | 
			
		||||
: irc-print ( s -- )
 | 
			
		||||
    irc-stream> [ stream-print ] keep stream-flush ;
 | 
			
		||||
 | 
			
		||||
! Irc commands    
 | 
			
		||||
 | 
			
		||||
: 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 )
 | 
			
		||||
    <inet> latin1 <client> drop ;
 | 
			
		||||
 | 
			
		||||
: JOIN ( channel password -- )
 | 
			
		||||
    "JOIN " irc-write
 | 
			
		||||
    [ " :" swap 3append ] when* irc-print ;
 | 
			
		||||
 | 
			
		||||
: PART ( channel text -- )
 | 
			
		||||
    [ "PART " irc-write irc-write ] dip
 | 
			
		||||
    " :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: KICK ( channel who -- )
 | 
			
		||||
    [ "KICK " irc-write irc-write ] dip
 | 
			
		||||
    " " irc-write irc-print ;
 | 
			
		||||
    
 | 
			
		||||
: PRIVMSG ( nick line -- )
 | 
			
		||||
    [ "PRIVMSG " irc-write irc-write ] dip
 | 
			
		||||
    " :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: SAY ( nick line -- )
 | 
			
		||||
    PRIVMSG ;
 | 
			
		||||
 | 
			
		||||
: ACTION ( nick line -- )
 | 
			
		||||
    [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
 | 
			
		||||
 | 
			
		||||
: QUIT ( text -- )
 | 
			
		||||
    "QUIT :" irc-write irc-print ;
 | 
			
		||||
 | 
			
		||||
: join-channel ( channel-profile -- )
 | 
			
		||||
    [ name>> ] keep password>> JOIN ;
 | 
			
		||||
 | 
			
		||||
: irc-connect ( irc-client -- )
 | 
			
		||||
    [ profile>> [ server>> ] keep port>> CONNECT ] keep
 | 
			
		||||
    swap >>stream t >>is-running drop ;
 | 
			
		||||
    
 | 
			
		||||
GENERIC: handle-irc ( obj -- )
 | 
			
		||||
 | 
			
		||||
M: object handle-irc ( obj -- )
 | 
			
		||||
    drop ;
 | 
			
		||||
 | 
			
		||||
M: logged-in handle-irc ( obj -- )
 | 
			
		||||
    name>>
 | 
			
		||||
    irc-client> [ nick>> swap >>name drop ] keep 
 | 
			
		||||
    profile>> default-channels>> [ join-channel ] each ;
 | 
			
		||||
 | 
			
		||||
M: ping handle-irc ( obj -- )
 | 
			
		||||
    "PONG " irc-write
 | 
			
		||||
    trailing>> irc-print ;
 | 
			
		||||
 | 
			
		||||
M: nick-in-use handle-irc ( obj -- )
 | 
			
		||||
    name>> "_" append NICK ;
 | 
			
		||||
 | 
			
		||||
: parse-irc-line ( string -- message )
 | 
			
		||||
    string>irc-message
 | 
			
		||||
    dup command>> {
 | 
			
		||||
        { "PING" [ \ ping ] }
 | 
			
		||||
        { "NOTICE" [ \ notice ] }
 | 
			
		||||
        { "001" [ \ logged-in ] }
 | 
			
		||||
        { "433" [ \ nick-in-use ] }
 | 
			
		||||
        { "JOIN" [ \ join_ ] }
 | 
			
		||||
        { "PART" [ \ part ] }
 | 
			
		||||
        { "PRIVMSG" [ \ privmsg ] }
 | 
			
		||||
        { "QUIT" [ \ quit ] }
 | 
			
		||||
        { "MODE" [ \ mode ] }
 | 
			
		||||
        { "KICK" [ \ kick ] }
 | 
			
		||||
        [ drop \ unhandled ]
 | 
			
		||||
    } case
 | 
			
		||||
    [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
 | 
			
		||||
 | 
			
		||||
! Reader
 | 
			
		||||
: handle-reader-message ( irc-client irc-message -- )
 | 
			
		||||
    dup handle-irc swap stream-channel>> to ;
 | 
			
		||||
 | 
			
		||||
: reader-loop ( irc-client -- )
 | 
			
		||||
    dup stream>> stream-readln [
 | 
			
		||||
        dup print parse-irc-line handle-reader-message
 | 
			
		||||
    ] [
 | 
			
		||||
        f >>is-running
 | 
			
		||||
        dup stream>> dispose
 | 
			
		||||
        irc-end over controller-channel>> to
 | 
			
		||||
        stream-channel>> irc-end swap to
 | 
			
		||||
    ] if* ;
 | 
			
		||||
 | 
			
		||||
! Controller commands
 | 
			
		||||
GENERIC: handle-command ( obj -- )
 | 
			
		||||
 | 
			
		||||
M: object handle-command ( obj -- )
 | 
			
		||||
    . ;
 | 
			
		||||
 | 
			
		||||
TUPLE: send-message to text ;
 | 
			
		||||
C: <send-message> send-message
 | 
			
		||||
M: send-message handle-command ( obj -- )
 | 
			
		||||
    dup to>> swap text>> SAY ;
 | 
			
		||||
 | 
			
		||||
TUPLE: send-action to text ;
 | 
			
		||||
C: <send-action> send-action
 | 
			
		||||
M: send-action handle-command ( obj -- )
 | 
			
		||||
    dup to>> swap text>> ACTION ;
 | 
			
		||||
 | 
			
		||||
TUPLE: send-quit text ;
 | 
			
		||||
C: <send-quit> send-quit
 | 
			
		||||
M: send-quit handle-command ( obj -- )
 | 
			
		||||
    text>> QUIT ;
 | 
			
		||||
 | 
			
		||||
: irc-listen ( irc-client quot -- )
 | 
			
		||||
    [ listeners>> ] [ <irc-listener> ] bi* swap push ;
 | 
			
		||||
 | 
			
		||||
! Controller loop
 | 
			
		||||
: controller-loop ( irc-client -- )
 | 
			
		||||
    controller-channel>> from handle-command ;
 | 
			
		||||
 | 
			
		||||
! Multiplexer
 | 
			
		||||
: multiplex-message ( irc-client message -- )
 | 
			
		||||
    swap listeners>> [ channel>> ] map
 | 
			
		||||
    [ '[ , , to ] "message" spawn drop ] each-with ;
 | 
			
		||||
 | 
			
		||||
: multiplexer-loop ( irc-client -- )
 | 
			
		||||
    dup stream-channel>> from multiplex-message ;
 | 
			
		||||
 | 
			
		||||
! process looping and starting
 | 
			
		||||
: (spawn-irc-loop) ( irc-client quot name -- )
 | 
			
		||||
    [ over >r curry r> '[ @ , is-running>> ] ] dip
 | 
			
		||||
    spawn-server-linked drop ;
 | 
			
		||||
 | 
			
		||||
: spawn-irc-loop ( irc-client quot name -- )
 | 
			
		||||
    '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
 | 
			
		||||
    f spawn drop ;
 | 
			
		||||
 | 
			
		||||
: spawn-irc ( irc-client -- )
 | 
			
		||||
    [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
 | 
			
		||||
    [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
 | 
			
		||||
    [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
 | 
			
		||||
    tri ;
 | 
			
		||||
    
 | 
			
		||||
: do-irc ( irc-client -- )
 | 
			
		||||
    irc-client [
 | 
			
		||||
        irc-client>
 | 
			
		||||
        [ irc-connect ]
 | 
			
		||||
        [ profile>> nickname>> LOGIN ]
 | 
			
		||||
        [ spawn-irc ]
 | 
			
		||||
        tri
 | 
			
		||||
    ] with-variable ;
 | 
			
		||||
| 
						 | 
				
			
			@ -8,26 +8,26 @@ HELP: QUALIFIED:
 | 
			
		|||
    "QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
 | 
			
		||||
 | 
			
		||||
HELP: QUALIFIED-WITH:
 | 
			
		||||
{ $syntax "QUALIFIED-WITH: vocab prefix" }
 | 
			
		||||
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
 | 
			
		||||
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
 | 
			
		||||
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
 | 
			
		||||
{ $examples { $code
 | 
			
		||||
    "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
 | 
			
		||||
 | 
			
		||||
HELP: FROM:
 | 
			
		||||
{ $syntax "FROM: vocab => words ... ;" }
 | 
			
		||||
{ $description "Imports the specified words from vocab." }
 | 
			
		||||
{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
 | 
			
		||||
{ $examples { $code
 | 
			
		||||
    "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
 | 
			
		||||
 | 
			
		||||
HELP: EXCLUDE:
 | 
			
		||||
{ $syntax "EXCLUDE: vocab => words ... ;" }
 | 
			
		||||
{ $description "Imports everything from vocab excluding the specified words" }
 | 
			
		||||
{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
 | 
			
		||||
{ $examples { $code
 | 
			
		||||
    "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
 | 
			
		||||
    "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
 | 
			
		||||
 | 
			
		||||
HELP: RENAME:
 | 
			
		||||
{ $syntax "RENAME: word vocab => newname " }
 | 
			
		||||
{ $description "Imports word from vocab, but renamed to newname." }
 | 
			
		||||
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
 | 
			
		||||
{ $examples { $code
 | 
			
		||||
    "RENAME: + math => -"
 | 
			
		||||
    "2 3 - ! => 5" } } ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue