refactor managed-server and chat, add hooks for when stuff happens, add /me, /who, /quit

extra/managed-server/chat/chat.factor

@@ -1,23 +1,61 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry io kernel managed-server
+USING: accessors assocs combinators combinators.smart
-namespaces sequences ;
+destructors fry io kernel managed-server namespaces
+sequences splitting unicode.case ;
 IN: managed-server.chat
 
+CONSTANT: line-beginning "-!- "
+
 TUPLE: chat-server < managed-server ;
 
 : <chat-server> ( port -- managed-server )
     "chat-server" chat-server new-managed-server ;
 
+: unknown-command ( string -- )
+    "Unknown command: " prepend print-client ;
+
+: handle-who ( string -- )
+    drop
+    clients keys ", " join print flush ;
+
+: handle-me ( string -- )
+    [
+        [ "* " username " " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+    client [ (>>object) ] [ output-stream>> dispose ] bi ;
+
+: handle-command ( string -- )
+    " " split1 swap >lower {
+        { "who" [ handle-who ] }
+        { "me" [ handle-me ] }
+        { "quit" [ handle-quit ] }
+        [ " " glue unknown-command ]
+    } case ;
+
+: handle-chat ( string -- )
+    [
+        [ username ": " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-join
+    [
+        line-beginning username " has joined"
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-disconnect
+    [
+        line-beginning username " has quit  "
+        client object>> dup [ "\"" dup surround ] when
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-already-logged-in
+    "The username ``" username "'' is already in use; try again."
+    3append print flush ;
+
 M: chat-server handle-managed-client*
-    clients>>
+    readln [
-    readln dup empty? [
+        "/" ?head [ handle-command ] [ handle-chat ] if
-        2drop
+    ] unless-empty ;
-    ] [
-        '[
-            nip output-stream>>
-            [
-                client get username>> ": " _ 3append print flush
-            ] with-output-stream*
-        ] assoc-each
-    ] if ;

extra/managed-server/managed-server.factor

@@ -1,24 +1,46 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar continuations io
+USING: accessors assocs calendar continuations destructors io
 io.encodings.binary io.servers.connection io.sockets
-io.streams.duplex kernel locals math math.ranges multiline
+io.streams.duplex fry kernel locals math math.ranges multiline
 namespaces prettyprint random sequences sets splitting threads
 tools.continuations ;
 IN: managed-server
 
-SYMBOL: client
-
 TUPLE: managed-server < threaded-server clients ;
 
-TUPLE: managed-client input-stream output-stream local-address
+TUPLE: managed-client
-remote-address username ;
+input-stream output-stream local-address remote-address
+username object ;
 
-GENERIC: login ( managed-server -- username )
+HOOK: login threaded-server ( -- username )
-GENERIC: handle-managed-client* ( threaded-server -- )
+HOOK: handle-already-logged-in managed-server ( -- )
+HOOK: handle-client-join managed-server ( -- )
+HOOK: handle-client-disconnect managed-server ( -- )
+HOOK: handle-managed-client* managed-server ( -- )
+
+M: managed-server handle-already-logged-in ;
+M: managed-server handle-client-join ;
+M: managed-server handle-client-disconnect ;
+M: managed-server handle-managed-client* ;
+
+: server ( -- managed-client ) managed-server get ;
+: client ( -- managed-client ) managed-client get ;
+: clients ( -- assoc ) server clients>> ;
+: client-streams ( -- assoc ) clients values ;
+: username ( -- string ) client username>> ;
+
+: send-everyone ( seq -- )
+    client-streams swap '[
+        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: bad-login username ;
+ERROR: normal-quit ;
 
 <PRIVATE
 
@@ -31,29 +53,31 @@ ERROR: bad-login username ;
         remote-address get >>remote-address ;
 
 : check-logged-in ( username -- username )
-    dup threaded-server get clients>> key? [ already-logged-in ] when ;
+    dup server clients>> key? [
+        [ server ] dip
+        [ handle-already-logged-in ] [ already-logged-in ] bi
+    ] when ;
 
-: add-managed-client ( managed-client -- )
+: add-managed-client ( -- )
-    dup username>>
+    client username check-logged-in clients set-at ;
-    threaded-server get clients>> set-at ;
 
 : delete-managed-client ( -- )
-    client get username>>
+    username server clients>> delete-at ;
-    threaded-server get clients>> delete-at ;
 
 : handle-managed-client ( -- )
-    [ [ threaded-server get handle-managed-client* t ] loop ]
+    [ [ handle-managed-client* t ] loop ]
-    [ delete-managed-client ]
+    [ delete-managed-client handle-client-disconnect ]
     [ ] cleanup ;
 
 PRIVATE>
 
-M: managed-server login drop readln ;
+M: managed-server login readln ;
 
 M: managed-server handle-client*
-    login <managed-client>
+    managed-server set
-    [ client set ] [ add-managed-client ] bi
+    login <managed-client> managed-client set
-    handle-managed-client ;
+    add-managed-client
+    handle-client-join handle-managed-client ;
 
 : new-managed-server ( port name class -- server )
     new-threaded-server