From 2151df5b1f93cf1e94bf55c080065abd446c5c17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 May 2009 13:39:24 -0500 Subject: [PATCH] refactor managed-server and chat, add hooks for when stuff happens, add /me, /who, /quit --- extra/managed-server/chat/chat.factor | 64 ++++++++++++++++----- extra/managed-server/managed-server.factor | 66 +++++++++++++++------- 2 files changed, 96 insertions(+), 34 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 7cd4db58f7..1ec22516bd 100644 --- a/extra/managed-server/chat/chat.factor +++ b/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 -namespaces sequences ; +USING: accessors assocs combinators combinators.smart +destructors fry io kernel managed-server namespaces +sequences splitting unicode.case ; IN: managed-server.chat +CONSTANT: line-beginning "-!- " + TUPLE: chat-server < managed-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 dup empty? [ - 2drop - ] [ - '[ - nip output-stream>> - [ - client get username>> ": " _ 3append print flush - ] with-output-stream* - ] assoc-each - ] if ; + readln [ + "/" ?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 2a9df2ae8a..ad09035251 100644 --- a/extra/managed-server/managed-server.factor +++ b/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 -remote-address username ; +TUPLE: managed-client +input-stream output-stream local-address remote-address +username object ; -GENERIC: login ( managed-server -- username ) -GENERIC: handle-managed-client* ( threaded-server -- ) +HOOK: login threaded-server ( -- username ) +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 ; >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 -- ) - dup username>> - threaded-server get clients>> set-at ; +: add-managed-client ( -- ) + client username check-logged-in clients set-at ; : delete-managed-client ( -- ) - client get username>> - threaded-server get clients>> delete-at ; + username server clients>> delete-at ; : handle-managed-client ( -- ) - [ [ threaded-server get handle-managed-client* t ] loop ] - [ delete-managed-client ] + [ [ handle-managed-client* t ] loop ] + [ 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 - [ client set ] [ add-managed-client ] bi - handle-managed-client ; + managed-server set + login managed-client set + add-managed-client + handle-client-join handle-managed-client ; : new-managed-server ( port name class -- server ) new-threaded-server