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