diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 1ec22516bd..723814bb13 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -1,23 +1,21 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.smart -destructors fry io kernel managed-server namespaces -sequences splitting unicode.case ; +destructors fry io io.encodings.utf8 kernel managed-server +namespaces parser sequences sorting splitting strings.parser +unicode.case unicode.categories calendar calendar.format +locals multiline ; IN: managed-server.chat -CONSTANT: line-beginning "-!- " - TUPLE: chat-server < managed-server ; -: ( port -- managed-server ) - "chat-server" chat-server new-managed-server ; +SYMBOL: commands +commands [ H{ } clone ] initialize -: unknown-command ( string -- ) - "Unknown command: " prepend print-client ; +SYMBOL: chat-docs +chat-docs [ H{ } clone ] initialize -: handle-who ( string -- ) - drop - clients keys ", " join print flush ; +CONSTANT: line-beginning "-!- " : handle-me ( string -- ) [ @@ -25,21 +23,64 @@ TUPLE: chat-server < managed-server ; ] "" append-outputs-as send-everyone ; : handle-quit ( string -- ) - client [ (>>object) ] [ output-stream>> dispose ] bi ; + client [ (>>object) ] [ t >>quit? drop ] bi ; + +: handle-help ( string -- ) + [ + "Commands: " + commands get keys natural-sort ", " join append print flush + ] [ + chat-docs get ?at + [ print flush ] + [ "Unknown command: " prepend print flush ] if + ] if-empty ; + +:: add-command ( quot docs key -- ) + quot key commands get set-at + docs key chat-docs get set-at ; + +[ handle-help ] +<" Syntax: /help [command] +Displays the documentation for a command."> +"help" add-command + +[ drop clients keys ", " join print flush ] +<" Syntax: /who +Shows the list of connected users."> +"who" add-command + +[ drop gmt timestamp>rfc822 print flush ] +<" Syntax: /time +Returns the current GMT time."> "time" add-command + +[ handle-me ] +<" Syntax: /me action"> +"me" add-command + +[ handle-quit ] +<" Syntax: /quit [message] +Disconnects a user from the chat server."> "quit" add-command : handle-command ( string -- ) - " " split1 swap >lower { - { "who" [ handle-who ] } - { "me" [ handle-me ] } - { "quit" [ handle-quit ] } - [ " " glue unknown-command ] - } case ; + dup " " split1 swap >lower commands get at* [ + call( string -- ) drop + ] [ + 2drop "Unknown command: " prepend print flush + ] if ; + +: ( port -- managed-server ) + "chat-server" chat-server new-managed-server + utf8 >>encoding ; : handle-chat ( string -- ) [ [ username ": " ] dip ] "" append-outputs-as send-everyone ; +M: chat-server handle-login + "Username: " write flush + readln ; + M: chat-server handle-client-join [ line-beginning username " has joined" @@ -56,6 +97,7 @@ M: chat-server handle-already-logged-in 3append print flush ; M: chat-server handle-managed-client* - readln [ + readln dup f = [ t client (>>quit?) ] when + [ "/" ?head [ handle-command ] [ handle-chat ] if ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index ad09035251..4d7ede84dc 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -11,9 +11,9 @@ TUPLE: managed-server < threaded-server clients ; TUPLE: managed-client input-stream output-stream local-address remote-address -username object ; +username object quit? ; -HOOK: login threaded-server ( -- username ) +HOOK: handle-login threaded-server ( -- username ) HOOK: handle-already-logged-in managed-server ( -- ) HOOK: handle-client-join managed-server ( -- ) HOOK: handle-client-disconnect managed-server ( -- ) @@ -31,16 +31,11 @@ M: managed-server handle-managed-client* ; : username ( -- string ) client username>> ; : send-everyone ( seq -- ) - client-streams swap '[ + [ client-streams ] dip '[ output-stream>> [ _ print flush ] with-output-stream* ] each ; -: print-client ( string -- ) - client output-stream>> - [ stream-print ] [ stream-flush ] bi ; - ERROR: already-logged-in username ; -ERROR: normal-quit ; > delete-at ; : handle-managed-client ( -- ) - [ [ handle-managed-client* t ] loop ] + [ [ handle-managed-client* client quit?>> not ] loop ] [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; PRIVATE> -M: managed-server login readln ; - M: managed-server handle-client* managed-server set - login managed-client set + handle-login managed-client set add-managed-client handle-client-join handle-managed-client ;