/extra/managed-server/managed-server.factor

  1! Copyright (C) 2009 Doug Coleman.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors assocs calendar continuations destructors io
  4io.encodings.binary io.servers io.sockets
  5io.streams.duplex fry kernel locals math math.ranges multiline
  6namespaces prettyprint random sequences sets splitting threads
  7tools.continuations ;
  8FROM: namespaces => set ;
  9IN: managed-server
 10
 11TUPLE: managed-server < threaded-server clients ;
 12
 13TUPLE: managed-client
 14input-stream output-stream local-address remote-address
 15username object quit? logged-in? ;
 16
 17HOOK: handle-login threaded-server ( -- username )
 18HOOK: handle-managed-client* managed-server ( -- )
 19HOOK: handle-already-logged-in managed-server ( -- )
 20HOOK: handle-client-join managed-server ( -- )
 21HOOK: handle-client-disconnect managed-server ( -- )
 22
 23ERROR: already-logged-in username ;
 24
 25M: managed-server handle-already-logged-in already-logged-in ;
 26M: managed-server handle-client-join ;
 27M: 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
 38ERROR: no-such-client username ;
 39
 40<PRIVATE
 41
 42: (send-client) ( managed-client seq -- )
 43    [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
 44
 45PRIVATE>
 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
 93PRIVATE>
 94
 95M: 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