Fix a problem with disconnects, add a lot of features to chat server, lots of refactoring of managed-server

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
+destructors fry io io.encodings.utf8 kernel managed-server
-sequences splitting unicode.case ;
+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 ;
 
-: <chat-server> ( port -- managed-server )
+SYMBOL: commands
-    "chat-server" chat-server new-managed-server ;
+commands [ H{ } clone ] initialize
 
-: unknown-command ( string -- )
+SYMBOL: chat-docs
-    "Unknown command: " prepend print-client ;
+chat-docs [ H{ } clone ] initialize
 
-: handle-who ( string -- )
+CONSTANT: line-beginning "-!- "
-    drop
-    clients keys ", " join print flush ;
 
 : 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 {
+    dup " " split1 swap >lower commands get at* [
-        { "who" [ handle-who ] }
+        call( string -- ) drop
-        { "me" [ handle-me ] }
+    ] [
-        { "quit" [ handle-quit ] }
+        2drop "Unknown command: " prepend print flush
-        [ " " glue unknown-command ]
+    ] if ;
-    } case ;
+
+: <chat-server> ( 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 ;

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 ;
 
 <PRIVATE
 
@@ -65,17 +60,15 @@ ERROR: normal-quit ;
     username server clients>> 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> managed-client set
+    handle-login <managed-client> managed-client set
     add-managed-client
     handle-client-join handle-managed-client ;