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 ;
12 TUPLE: threaded-server < identity-tuple
27 SYMBOL: running-servers
28 running-servers [ HS{ } clone ] initialize
30 ERROR: server-not-running threaded-server ;
32 ERROR: server-already-running threaded-server ;
36 : add-running-server ( threaded-server running-servers -- )
37 dupd ?adjoin [ drop ] [ server-already-running ] if ;
39 : remove-running-server ( threaded-server running-servers -- )
40 dupd ?delete [ drop ] [ server-not-running ] if ;
44 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
46 : internet-server ( port -- addrspec ) f swap <inet> ;
48 : new-threaded-server ( encoding class -- threaded-server )
52 <secure-config> >>secure-config
54 [ "No handler quotation" throw ] >>handler
57 : <threaded-server> ( encoding -- threaded-server )
58 threaded-server new-threaded-server ;
60 GENERIC: handle-client* ( threaded-server -- )
64 GENERIC: >insecure ( obj -- obj )
66 M: inet >insecure 1array ;
67 M: inet4 >insecure 1array ;
68 M: inet6 >insecure 1array ;
69 M: local >insecure 1array ;
70 M: integer >insecure internet-server 1array ;
71 M: string >insecure internet-server 1array ;
72 M: array >insecure [ >insecure ] map concat ;
75 : >secure ( addrspec -- addrspec' )
76 >insecure [ dup secure? [ f <secure> ] unless ] map ;
78 : configurable-addrspecs ( addrspecs -- addrspecs' )
79 [ inet6? not ipv6-supported? or ] filter ;
81 : listen-on ( threaded-server -- addrspecs )
82 [ secure>> ssl-supported? [ >secure ] [ drop { } ] if ]
83 [ insecure>> >insecure ] bi append
84 [ resolve-host ] map concat configurable-addrspecs ;
86 : accepted-connection ( remote local -- )
88 [ "remote: " % present % ", " % ]
89 [ "local: " % present % ]
92 \ accepted-connection NOTICE log-message ;
94 : log-connection ( remote local -- )
95 [ accepted-connection ]
96 [ [ remote-address namespaces:set ] [ local-address namespaces:set ] bi* ]
99 M: threaded-server handle-client* handler>> call( -- ) ;
101 : handle-client ( client remote local -- )
105 [ timeout>> timeouts ] [ handle-client* ] bi
108 \ handle-client NOTICE add-error-logging
110 : client-thread-name ( addrspec -- string )
111 [ threaded-server get name>> ] dip
112 unparse-short " connection from " glue ;
114 : (accept-connection) ( server -- )
115 [ accept ] [ addr>> ] bi
116 [ '[ _ _ _ handle-client ] ]
117 [ drop client-thread-name ] 2bi
120 : accept-connection ( server -- )
121 threaded-server get semaphore>>
122 [ [ (accept-connection) ] with-semaphore ]
123 [ (accept-connection) ]
126 : with-existing-secure-context ( threaded-server quot -- )
127 [ secure-context>> secure-context ] dip with-variable ; inline
129 : accept-loop ( server -- )
130 [ accept-connection ] [ accept-loop ] bi ;
132 : start-accept-loop ( threaded-server server -- )
133 '[ _ accept-loop ] with-existing-secure-context ;
135 \ start-accept-loop NOTICE add-error-logging
137 : create-secure-context ( threaded-server -- threaded-server )
138 dup secure>> ssl-supported? and [
139 dup secure-config>> <secure-context> >>secure-context
142 : init-server ( threaded-server -- threaded-server )
143 create-secure-context
144 <flag> >>server-stopped
146 dup max-connections>> [
147 <semaphore> >>semaphore
151 ERROR: no-ports-configured threaded-server ;
153 : (make-servers) ( theaded-server addrspecs -- servers )
155 '[ [ _ <server> |dispose ] map ] with-destructors ;
157 : set-servers ( threaded-server -- threaded-server )
160 [ no-ports-configured ] [ (make-servers) ] if-empty
162 ] with-existing-secure-context ;
164 : server-thread-name ( threaded-server addrspec -- string )
165 [ name>> ] [ addr>> present ] bi* " server on " glue ;
169 : start-server ( threaded-server -- threaded-server )
172 dup threaded-server [
176 dup running-servers get add-running-server
179 [ '[ _ _ [ start-accept-loop ] with-disposal ] ]
180 [ server-thread-name ] 2bi spawn drop
186 : server-running? ( threaded-server -- ? )
187 server-stopped>> [ value>> not ] [ f ] if* ;
189 : stop-server ( threaded-server -- )
190 dup server-running? [
191 [ running-servers get remove-running-server ]
194 [ secure-context>> [ &dispose drop ] when* ]
195 [ [ f ] change-servers drop dispose-each ] bi
198 [ server-stopped>> raise-flag ] tri
203 : stop-this-server ( -- )
204 threaded-server get stop-server ;
206 : wait-for-server ( threaded-server -- )
207 server-stopped>> wait-for-flag ;
209 : with-threaded-server ( threaded-server quot -- )
210 [ start-server ] dip over
212 [ _ threaded-server _ with-variable ]
219 GENERIC: connect-addr ( addrspec -- addrspec )
221 M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
223 M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
225 M: secure connect-addr addrspec>> connect-addr f <secure> ;
227 M: local connect-addr ;
231 : server-addrs ( -- addrspecs )
232 threaded-server get servers>> [ addr>> connect-addr ] map ;
234 : secure-addr ( -- addrspec )
235 server-addrs [ secure? ] filter random ;
237 : insecure-addr ( -- addrspec )
238 server-addrs [ secure? ] reject random ;
240 : server. ( threaded-server -- )
241 [ [ "=== " write name>> ] [ ] bi write-object nl ]
242 [ servers>> [ addr>> present print ] each ] bi ;
244 : all-servers ( -- sequence )
245 running-servers get-global members ;
247 : get-servers-named ( string -- sequence )
248 [ all-servers ] dip '[ name>> _ = ] filter ;
251 all-servers [ server. ] each ;
253 : stop-all-servers ( -- )
254 all-servers [ stop-server ] each ;