1 ! Copyright (C) 2003, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: continuations destructors kernel math math.parser
4 namespaces parser sequences strings prettyprint
5 quotations combinators logging calendar assocs present
6 fry accessors arrays io io.sockets io.encodings.ascii
7 io.sockets.secure io.files io.streams.duplex io.timeouts
8 io.encodings threads make concurrency.combinators
9 concurrency.semaphores concurrency.flags
10 combinators.short-circuit ;
11 IN: io.servers.connection
13 TUPLE: threaded-server
26 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
28 : internet-server ( port -- addrspec ) f swap <inet> ;
30 : new-threaded-server ( encoding class -- threaded-server )
37 <secure-config> >>secure-config
38 [ "No handler quotation" throw ] >>handler
39 <flag> >>ready ; inline
41 : <threaded-server> ( encoding -- threaded-server )
42 threaded-server new-threaded-server ;
44 GENERIC: handle-client* ( threaded-server -- )
48 : >insecure ( addrspec -- addrspec' )
49 dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
51 : >secure ( addrspec -- addrspec' )
53 dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
55 : listen-on ( threaded-server -- addrspecs )
56 [ secure>> >secure ] [ insecure>> >insecure ] bi
57 [ resolve-host ] bi@ append ;
59 : accepted-connection ( remote local -- )
61 [ "remote: " % present % ", " % ]
62 [ "local: " % present % ]
65 \ accepted-connection NOTICE log-message ;
67 : log-connection ( remote local -- )
68 [ accepted-connection ]
69 [ [ remote-address set ] [ local-address set ] bi* ]
72 M: threaded-server handle-client* handler>> call( -- ) ;
74 : handle-client ( client remote local -- )
78 [ timeout>> timeouts ] [ handle-client* ] bi
81 \ handle-client ERROR add-error-logging
83 : thread-name ( server-name addrspec -- string )
84 unparse-short " connection from " glue ;
86 : accept-connection ( threaded-server -- )
87 [ accept ] [ addr>> ] bi
88 [ '[ _ _ _ handle-client ] ]
89 [ drop threaded-server get name>> swap thread-name ] 2bi
92 : accept-loop ( threaded-server -- )
94 threaded-server get semaphore>>
95 [ [ accept-connection ] with-semaphore ]
98 ] [ accept-loop ] bi ; inline recursive
100 : started-accept-loop ( threaded-server -- )
102 [ sockets>> push ] [ ready>> raise-flag ] bi ;
104 : start-accept-loop ( addrspec -- )
105 threaded-server get encoding>> <server>
106 [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
108 \ start-accept-loop NOTICE add-error-logging
110 : init-server ( threaded-server -- threaded-server )
112 dup max-connections>> [
113 <semaphore> >>semaphore
117 : (start-server) ( threaded-server -- )
119 dup threaded-server [
121 [ listen-on [ start-accept-loop ] parallel-each ]
122 [ ready>> raise-flag ]
129 : start-server ( threaded-server -- )
130 #! Only create a secure-context if we want to listen on
131 #! a secure port, otherwise start-server won't work at
132 #! all if SSL is not available.
134 dup secure-config>> [
136 ] with-secure-context
141 : wait-for-server ( threaded-server -- )
142 ready>> wait-for-flag ;
144 : start-server* ( threaded-server -- )
145 [ [ start-server ] curry "Threaded server" spawn drop ]
149 : stop-server ( threaded-server -- )
150 [ f ] change-sockets drop dispose-each ;
152 : stop-this-server ( -- )
153 threaded-server get stop-server ;
155 GENERIC: port ( addrspec -- n )
159 M: object port port>> ;
161 : secure-port ( -- n )
162 threaded-server get dup [ secure>> port ] when ;
164 : insecure-port ( -- n )
165 threaded-server get dup [ insecure>> port ] when ;