extra/managed-server/managed-server.factor

   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 ranges multiline
   6 namespaces prettyprint random sequences sets splitting threads
   7 tools.continuations ;
   8 IN: managed-server
   9
  10 TUPLE: managed-server < threaded-server clients ;
  11
  12 TUPLE: managed-client
  13 input-stream output-stream local-address remote-address
  14 username object quit? logged-in? ;
  15
  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 ( -- )
  21
  22 ERROR: already-logged-in username ;
  23
  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 ;
  27
  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 ;
  36
  37 ERROR: no-such-client username ;
  38
  39 <PRIVATE
  40
  41 : (send-client) ( managed-client seq -- )
  42     [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
  43
  44 PRIVATE>
  45
  46 : send-client ( seq username -- )
  47     clients ?at [ no-such-client ] [ (send-client) ] if ;
  48
  49 : send-everyone ( seq -- )
  50     [ client-streams ] dip '[ _ (send-client) ] each ;
  51
  52 : send-everyone-else ( seq -- )
  53     [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
  54
  55 <PRIVATE
  56
  57 : <managed-client> ( username -- managed-client )
  58     managed-client new
  59         swap >>username
  60         input-stream get >>input-stream
  61         output-stream get >>output-stream
  62         local-address get >>local-address
  63         remote-address get >>remote-address ;
  64
  65 : maybe-login-client ( -- )
  66     username clients key? [
  67         handle-already-logged-in
  68     ] [
  69         t client logged-in?<<
  70         client username clients set-at
  71     ] if ;
  72
  73 : when-logged-in ( quot -- )
  74     client logged-in?>> [ call ] [ drop ] if ; inline
  75
  76 : delete-managed-client ( -- )
  77     [ username server clients>> delete-at ] when-logged-in ;
  78
  79 : handle-managed-client ( -- )
  80     handle-login <managed-client> managed-client namespaces:set
  81     maybe-login-client [
  82         handle-client-join
  83         [ handle-managed-client* client quit?>> not ] loop
  84     ] when-logged-in ;
  85
  86 : cleanup-client ( -- )
  87     [
  88         delete-managed-client
  89         handle-client-disconnect
  90     ] when-logged-in ;
  91
  92 PRIVATE>
  93
  94 M: managed-server handle-client*
  95     managed-server namespaces:set
  96     [ handle-managed-client ]
  97     [ cleanup-client ]
  98     finally ;
  99
 100 : new-managed-server ( port name encoding class -- server )
 101     new-threaded-server
 102         swap >>name
 103         swap >>insecure
 104         f >>timeout
 105         H{ } clone >>clients ; inline
 106
 107 : new-managed-server* ( encoding class -- server )
 108     new-threaded-server
 109         f >>timeout
 110         H{ } clone >>clients ; inline