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 FROM: namespaces => set ;
11 IN: io.servers.connection
13 TUPLE: threaded-server < identity-tuple
27 SYMBOL: running-servers
28 running-servers [ HS{ } clone ] initialize
30 ERROR: server-already-running threaded-server ;
32 ERROR: server-not-running threaded-server ;
36 : must-be-running ( threaded-server -- threaded-server )
37 dup running-servers get in? [ server-not-running ] unless ;
39 : must-not-be-running ( threaded-server -- threaded-server )
40 dup running-servers get in? [ server-already-running ] when ;
42 : add-running-server ( threaded-server -- )
44 running-servers get adjoin ;
46 : remove-running-server ( threaded-server -- )
48 running-servers get delete ;
52 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
54 : internet-server ( port -- addrspec ) f swap <inet> ;
56 : new-threaded-server ( encoding class -- threaded-server )
60 <secure-config> >>secure-config
62 [ "No handler quotation" throw ] >>handler
65 : <threaded-server> ( encoding -- threaded-server )
66 threaded-server new-threaded-server ;
68 GENERIC: handle-client* ( threaded-server -- )
72 GENERIC: (>insecure) ( obj -- obj )
75 M: local (>insecure) ;
76 M: integer (>insecure) internet-server ;
77 M: string (>insecure) internet-server ;
78 M: array (>insecure) [ (>insecure) ] map ;
81 : >insecure ( obj -- seq )
82 (>insecure) dup sequence? [ 1array ] unless ;
84 : >secure ( addrspec -- addrspec' )
86 [ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ] map ;
88 : listen-on ( threaded-server -- addrspecs )
89 [ secure>> >secure ] [ insecure>> >insecure ] bi append
90 [ resolve-host ] map concat ;
92 : accepted-connection ( remote local -- )
94 [ "remote: " % present % ", " % ]
95 [ "local: " % present % ]
98 \ accepted-connection NOTICE log-message ;
100 : log-connection ( remote local -- )
101 [ accepted-connection ]
102 [ [ remote-address set ] [ local-address set ] bi* ]
105 M: threaded-server handle-client* handler>> call( -- ) ;
107 : handle-client ( client remote local -- )
111 [ timeout>> timeouts ] [ handle-client* ] bi
114 \ handle-client NOTICE add-error-logging
116 : client-thread-name ( addrspec -- string )
117 [ threaded-server get name>> ] dip
118 unparse-short " connection from " glue ;
120 : (accept-connection) ( server -- )
121 [ accept ] [ addr>> ] bi
122 [ '[ _ _ _ handle-client ] ]
123 [ drop client-thread-name ] 2bi
126 : accept-connection ( server -- )
127 threaded-server get semaphore>>
128 [ [ (accept-connection) ] with-semaphore ]
129 [ (accept-connection) ]
132 : accept-loop ( server -- )
133 [ accept-connection ] [ accept-loop ] bi ;
135 : start-accept-loop ( server -- ) accept-loop ;
137 \ start-accept-loop NOTICE add-error-logging
139 : init-server ( threaded-server -- threaded-server )
140 <flag> >>server-stopped
142 dup max-connections>> [
143 <semaphore> >>semaphore
147 ERROR: no-ports-configured threaded-server ;
149 : (make-servers) ( theaded-server addrspecs -- servers )
151 '[ [ _ <server> |dispose ] map ] with-destructors ;
153 : set-servers ( threaded-server -- threaded-server )
154 dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
157 : server-thread-name ( threaded-server addrspec -- string )
158 [ name>> ] [ addr>> present ] bi* " server on " glue ;
160 : (start-server) ( threaded-server -- )
162 dup threaded-server [
166 dup add-running-server
169 [ nip '[ _ [ start-accept-loop ] with-disposal ] ]
170 [ server-thread-name ] 2bi spawn drop
177 : start-server ( threaded-server -- threaded-server )
178 #! Only create a secure-context if we want to listen on
179 #! a secure port, otherwise start-server won't work at
180 #! all if SSL is not available.
182 dup secure-config>> [
184 ] with-secure-context
189 : server-running? ( threaded-server -- ? )
190 server-stopped>> [ value>> not ] [ f ] if* ;
192 : stop-server ( threaded-server -- )
193 dup server-running? [
194 [ [ f ] change-servers drop dispose-each ]
195 [ remove-running-server ]
196 [ server-stopped>> raise-flag ] tri
201 : stop-this-server ( -- )
202 threaded-server get stop-server ;
204 : wait-for-server ( threaded-server -- )
205 server-stopped>> wait-for-flag ;
207 : with-threaded-server ( threaded-server quot -- )
210 [ _ start-server threaded-server _ with-variable ]
217 : first-port ( quot -- n/f )
218 [ threaded-server get servers>> ] dip
219 filter [ f ] [ first addr>> port>> ] if-empty ; inline
223 : secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
225 : insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
227 : server. ( threaded-server -- )
228 [ [ "=== " write name>> ] [ ] bi write-object nl ]
229 [ servers>> [ addr>> present print ] each ] bi ;
231 : all-servers ( -- sequence )
232 running-servers get-global members ;
235 all-servers [ server. ] each ;
237 : stop-all-servers ( -- )
238 all-servers [ stop-server ] each ;