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

http://github.com/abeaumont/factor · Factor · 106 lines · 81 code · 23 blank · 2 comment · 11 complexity · 1598ec73d35ea2089f9c016fdd05c3a0 MD5 · raw file

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