1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs calendar continuations destructors io
4 io.encodings.binary io.servers io.sockets
5 io.streams.duplex fry kernel locals math math.ranges multiline
6 namespaces prettyprint random sequences sets splitting threads
10 TUPLE: managed-server < threaded-server clients ;
13 input-stream output-stream local-address remote-address
14 username object quit? logged-in? ;
16 HOOK: handle-login threaded-server ( -- username )
17 HOOK: handle-managed-client* managed-server ( -- )
18 HOOK: handle-already-logged-in managed-server ( -- )
19 HOOK: handle-client-join managed-server ( -- )
20 HOOK: handle-client-disconnect managed-server ( -- )
22 ERROR: already-logged-in username ;
24 M: managed-server handle-already-logged-in already-logged-in ;
25 M: managed-server handle-client-join ;
26 M: managed-server handle-client-disconnect ;
28 : server ( -- managed-client ) managed-server get ;
29 : client ( -- managed-client ) managed-client get ;
30 : clients ( -- assoc ) server clients>> ;
31 : client-streams ( -- assoc ) clients values ;
32 : username ( -- string ) client username>> ;
33 : everyone-else ( -- assoc )
34 clients [ drop username = ] assoc-reject ;
35 : everyone-else-streams ( -- assoc ) everyone-else values ;
37 ERROR: no-such-client username ;
41 : (send-client) ( managed-client seq -- )
42 [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
46 : send-client ( seq username -- )
47 clients ?at [ no-such-client ] [ (send-client) ] if ;
49 : send-everyone ( seq -- )
50 [ client-streams ] dip '[ _ (send-client) ] each ;
52 : send-everyone-else ( seq -- )
53 [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
57 : <managed-client> ( username -- managed-client )
60 input-stream get >>input-stream
61 output-stream get >>output-stream
62 local-address get >>local-address
63 remote-address get >>remote-address ;
65 : maybe-login-client ( -- )
66 username clients key? [
67 handle-already-logged-in
70 client username clients set-at
73 : when-logged-in ( quot -- )
74 client logged-in?>> [ call ] [ drop ] if ; inline
76 : delete-managed-client ( -- )
77 [ username server clients>> delete-at ] when-logged-in ;
79 : handle-managed-client ( -- )
80 handle-login <managed-client> managed-client namespaces:set
83 [ handle-managed-client* client quit?>> not ] loop
86 : cleanup-client ( -- )
89 handle-client-disconnect
94 M: managed-server handle-client*
95 managed-server namespaces:set
96 [ handle-managed-client ]
100 : new-managed-server ( port name encoding class -- server )
105 H{ } clone >>clients ; inline