add a logged-in flag to managed-server for logging in connections so we don't have to throw exceptions to kill clients

Doug Coleman 2009-06-03 23:00:56 -05:00
parent 37ceeca882
commit ed8181e5c3
1 changed files with 22 additions and 9 deletions

View File

@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
TUPLE: managed-client
input-stream output-stream local-address remote-address
username object quit? ;
username object quit? logged-in? ;
HOOK: handle-login threaded-server ( -- username )
HOOK: handle-managed-client* managed-server ( -- )
@ -62,26 +62,39 @@ PRIVATE>
local-address get >>local-address
remote-address get >>remote-address ;
: check-logged-in ( username -- username )
dup clients key? [ handle-already-logged-in ] when ;
: maybe-login-client ( -- )
username clients key? [
handle-already-logged-in
] [
t client (>>logged-in?)
client username clients set-at
] if ;
: add-managed-client ( -- )
client username check-logged-in clients set-at ;
: when-logged-in ( quot -- )
client logged-in?>> [ call ] [ drop ] if ; inline
: delete-managed-client ( -- )
username server clients>> delete-at ;
[ username server clients>> delete-at ] when-logged-in ;
: handle-managed-client ( -- )
handle-login <managed-client> managed-client set
add-managed-client handle-client-join
[ handle-managed-client* client quit?>> not ] loop ;
maybe-login-client [
handle-client-join
[ handle-managed-client* client quit?>> not ] loop
] when-logged-in ;
: cleanup-client ( -- )
[
delete-managed-client
handle-client-disconnect
] when-logged-in ;
PRIVATE>
M: managed-server handle-client*
managed-server set
[ handle-managed-client ]
[ delete-managed-client handle-client-disconnect ]
[ cleanup-client ]
[ ] cleanup ;
: new-managed-server ( port name encoding class -- server )