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