basis/io/servers/servers.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar combinators
   4 combinators.short-circuit concurrency.combinators
   5 concurrency.count-downs concurrency.flags
   6 concurrency.semaphores continuations debugger destructors fry
   7 io io.sockets io.sockets.secure io.streams.duplex io.styles
   8 io.timeouts kernel logging make math math.parser namespaces
   9 present prettyprint random sequences sets strings threads ;
  10 IN: io.servers
  11
  12 TUPLE: threaded-server < identity-tuple
  13 name
  14 log-level
  15 secure
  16 insecure
  17 secure-config
  18 servers
  19 max-connections
  20 semaphore
  21 timeout
  22 encoding
  23 handler
  24 server-stopped
  25 secure-context ;
  26
  27 SYMBOL: running-servers
  28 running-servers [ HS{ } clone ] initialize
  29
  30 ERROR: server-already-running threaded-server ;
  31
  32 ERROR: server-not-running threaded-server ;
  33
  34 <PRIVATE
  35
  36 : must-be-running ( threaded-server -- threaded-server )
  37     dup running-servers get in? [ server-not-running ] unless ;
  38
  39 : must-not-be-running ( threaded-server -- threaded-server )
  40     dup running-servers get in? [ server-already-running ] when ;
  41
  42 : add-running-server ( threaded-server -- )
  43     must-not-be-running
  44     running-servers get adjoin ;
  45
  46 : remove-running-server ( threaded-server -- )
  47     must-be-running
  48     running-servers get delete ;
  49
  50 PRIVATE>
  51
  52 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
  53
  54 : internet-server ( port -- addrspec ) f swap <inet> ;
  55
  56 : new-threaded-server ( encoding class -- threaded-server )
  57     new
  58         "server" >>name
  59         DEBUG >>log-level
  60         <secure-config> >>secure-config
  61         1 minutes >>timeout
  62         [ "No handler quotation" throw ] >>handler
  63         swap >>encoding ;
  64
  65 : <threaded-server> ( encoding -- threaded-server )
  66     threaded-server new-threaded-server ;
  67
  68 GENERIC: handle-client* ( threaded-server -- )
  69
  70 <PRIVATE
  71
  72 GENERIC: >insecure ( obj -- obj )
  73
  74 M: inet >insecure 1array ;
  75 M: inet4 >insecure 1array ;
  76 M: inet6 >insecure 1array ;
  77 M: local >insecure 1array ;
  78 M: integer >insecure internet-server 1array ;
  79 M: string >insecure internet-server 1array ;
  80 M: array >insecure [ >insecure ] map ;
  81 M: f >insecure ;
  82
  83 : >secure ( addrspec -- addrspec' )
  84     >insecure
  85     [ dup secure? [ <secure> ] unless ] map ;
  86
  87 : listen-on ( threaded-server -- addrspecs )
  88     [ secure>> ssl-supported? [ >secure ] [ drop { } ] if ]
  89     [ insecure>> >insecure ]
  90     bi append
  91     [ resolve-host ] map concat ;
  92
  93 : accepted-connection ( remote local -- )
  94     [
  95         [ "remote: " % present % ", " % ]
  96         [ "local: " % present % ]
  97         bi*
  98     ] "" make
  99     \ accepted-connection NOTICE log-message ;
 100
 101 : log-connection ( remote local -- )
 102     [ accepted-connection ]
 103     [ [ remote-address set ] [ local-address set ] bi* ]
 104     2bi ;
 105
 106 M: threaded-server handle-client* handler>> call( -- ) ;
 107
 108 : handle-client ( client remote local -- )
 109     '[
 110         _ _ log-connection
 111         threaded-server get
 112         [ timeout>> timeouts ] [ handle-client* ] bi
 113     ] with-stream ;
 114
 115 \ handle-client NOTICE add-error-logging
 116
 117 : client-thread-name ( addrspec -- string )
 118     [ threaded-server get name>> ] dip
 119     unparse-short " connection from " glue ;
 120
 121 : (accept-connection) ( server -- )
 122     [ accept ] [ addr>> ] bi
 123     [ '[ _ _ _ handle-client ] ]
 124     [ drop client-thread-name ] 2bi
 125     spawn drop ;
 126
 127 : accept-connection ( server -- )
 128     threaded-server get semaphore>>
 129     [ [ (accept-connection) ] with-semaphore ]
 130     [ (accept-connection) ]
 131     if* ;
 132
 133 : with-existing-secure-context ( threaded-server quot -- )
 134     [ secure-context>> secure-context ] dip with-variable ; inline
 135
 136 : accept-loop ( server -- )
 137     [ accept-connection ] [ accept-loop ] bi ;
 138
 139 : start-accept-loop ( threaded-server server -- )
 140     '[ _ accept-loop ] with-existing-secure-context ;
 141
 142 \ start-accept-loop NOTICE add-error-logging
 143
 144 : create-secure-context ( threaded-server -- threaded-server )
 145     dup secure>> ssl-supported? and [
 146         dup secure-config>> <secure-context> >>secure-context
 147     ] when ;
 148
 149 : init-server ( threaded-server -- threaded-server )
 150     create-secure-context
 151     <flag> >>server-stopped
 152     dup semaphore>> [
 153         dup max-connections>> [
 154             <semaphore> >>semaphore
 155         ] when*
 156     ] unless ;
 157
 158 ERROR: no-ports-configured threaded-server ;
 159
 160 : (make-servers) ( theaded-server addrspecs -- servers )
 161     swap encoding>>
 162     '[ [ _ <server> |dispose ] map ] with-destructors ;
 163
 164 : set-servers ( threaded-server -- threaded-server )
 165     dup [
 166         dup dup listen-on
 167         [ no-ports-configured ] [ (make-servers) ] if-empty
 168         >>servers
 169     ] with-existing-secure-context ;
 170
 171 : server-thread-name ( threaded-server addrspec -- string )
 172     [ name>> ] [ addr>> present ] bi* " server on " glue ;
 173
 174 PRIVATE>
 175
 176 : start-server ( threaded-server -- threaded-server )
 177     init-server
 178     [
 179         dup threaded-server [
 180             [ ] [ name>> ] bi
 181             [
 182                 set-servers
 183                 dup add-running-server
 184                 dup servers>>
 185                 [
 186                     [ '[ _ _ [ start-accept-loop ] with-disposal ] ]
 187                     [ server-thread-name ] 2bi spawn drop
 188                 ] with each
 189             ] with-logging
 190         ] with-variable
 191     ] keep ;
 192
 193 : server-running? ( threaded-server -- ? )
 194     server-stopped>> [ value>> not ] [ f ] if* ;
 195
 196 : stop-server ( threaded-server -- )
 197     dup server-running? [
 198         [ remove-running-server ]
 199         [
 200             [
 201                 [ secure-context>> [ &dispose drop ] when* ]
 202                 [ [ f ] change-servers drop dispose-each ] bi
 203             ] with-destructors
 204         ]
 205         [ server-stopped>> raise-flag ] tri
 206     ] [
 207         drop
 208     ] if ;
 209
 210 : stop-this-server ( -- )
 211     threaded-server get stop-server ;
 212
 213 : wait-for-server ( threaded-server -- )
 214     server-stopped>> wait-for-flag ;
 215
 216 : with-threaded-server ( threaded-server quot -- )
 217     [ start-server ] dip over
 218     '[
 219         [ _ threaded-server _ with-variable ]
 220         [ _ stop-server ]
 221         [ ] cleanup
 222     ] call ; inline
 223
 224 <PRIVATE
 225
 226 GENERIC: connect-addr ( addrspec -- addrspec )
 227
 228 M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
 229
 230 M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
 231
 232 M: secure connect-addr addrspec>> connect-addr <secure> ;
 233
 234 M: local connect-addr ;
 235
 236 PRIVATE>
 237
 238 : server-addrs ( -- addrspecs )
 239     threaded-server get servers>> [ addr>> connect-addr ] map ;
 240
 241 : secure-addr ( -- addrspec )
 242     server-addrs [ secure? ] filter random ;
 243
 244 : insecure-addr ( -- addrspec )
 245     server-addrs [ secure? ] reject random ;
 246
 247 : server. ( threaded-server -- )
 248     [ [ "=== " write name>> ] [ ] bi write-object nl ]
 249     [ servers>> [ addr>> present print ] each ] bi ;
 250
 251 : all-servers ( -- sequence )
 252     running-servers get-global members ;
 253
 254 : get-servers-named ( string -- sequence )
 255     [ all-servers ] dip '[ name>> _ = ] filter ;
 256
 257 : servers. ( -- )
 258     all-servers [ server. ] each ;
 259
 260 : stop-all-servers ( -- )
 261     all-servers [ stop-server ] each ;