extra/managed-server/managed-server.factor

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