diff --git a/extra/irc/authors.txt b/extra/irc/client/authors.txt similarity index 100% rename from extra/irc/authors.txt rename to extra/irc/client/authors.txt diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor new file mode 100644 index 0000000000..19dca48e1d --- /dev/null +++ b/extra/irc/client/client.factor @@ -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 + +TUPLE: irc-channel-profile name password ; +: ( -- irc-channel-profile ) irc-channel-profile new ; + +! "live" objects +TUPLE: nick name channels log ; +C: nick + +TUPLE: irc-client profile nick stream in-messages out-messages join-messages + listeners is-running ; +: ( profile -- irc-client ) + f V{ } clone V{ } clone + f H{ } clone f irc-client boa ; + +TUPLE: irc-listener in-messages out-messages ; +: ( -- irc-listener ) + 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 ; + + ( -- 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 ) + latin1 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 ) + 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 ; diff --git a/extra/irc/summary.txt b/extra/irc/client/summary.txt similarity index 100% rename from extra/irc/summary.txt rename to extra/irc/client/summary.txt diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor deleted file mode 100755 index 9a278fb67f..0000000000 --- a/extra/irc/irc.factor +++ /dev/null @@ -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 - -TUPLE: irc-channel-profile name password auto-rejoin ; -C: irc-channel-profile - -! "live" objects -TUPLE: nick name channels log ; -C: nick - -TUPLE: irc-client profile nick stream stream-channel controller-channel - listeners is-running ; -: ( profile -- irc-client ) - f V{ } clone V{ } clone - f 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?? -: ( quot -- irc-listener ) - 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 - -! the delegate of all irc messages -TUPLE: irc-message line prefix command parameters trailing timestamp ; -C: irc-message - -! "irc message" objects -TUPLE: logged-in < irc-message name ; -C: logged-in - -TUPLE: ping < irc-message ; -C: ping - -TUPLE: join_ < irc-message ; -C: join_ - -TUPLE: part < irc-message name channel ; -C: part - -TUPLE: quit ; -C: quit - -TUPLE: privmsg < irc-message name ; -C: privmsg - -TUPLE: kick < irc-message channel who ; -C: kick - -TUPLE: roomlist < irc-message channel names ; -C: roomlist - -TUPLE: nick-in-use < irc-message name ; -C: nick-in-use - -TUPLE: notice < irc-message type ; -C: notice - -TUPLE: mode < irc-message name channel mode ; -C: mode - -TUPLE: unhandled < irc-message ; -C: 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 ; - -: 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 ) - latin1 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 -M: send-message handle-command ( obj -- ) - dup to>> swap text>> SAY ; - -TUPLE: send-action to text ; -C: send-action -M: send-action handle-command ( obj -- ) - dup to>> swap text>> ACTION ; - -TUPLE: send-quit text ; -C: send-quit -M: send-quit handle-command ( obj -- ) - text>> QUIT ; - -: irc-listen ( irc-client quot -- ) - [ listeners>> ] [ ] 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 ; \ No newline at end of file