1 ! Copyright (C) 2003, 2008 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 debugger
5 quotations combinators logging calendar assocs
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 concurrency.combinators
9 concurrency.semaphores concurrency.flags
10 combinators.short-circuit ;
11 IN: io.servers.connection
13 TUPLE: threaded-server
25 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
27 : internet-server ( port -- addrspec ) f swap <inet> ;
29 : new-threaded-server ( class -- threaded-server )
35 <secure-config> >>secure-config
36 [ "No handler quotation" throw ] >>handler
37 <flag> >>ready ; inline
39 : <threaded-server> ( -- threaded-server )
40 threaded-server new-threaded-server ;
42 SYMBOL: remote-address
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 LOG: accepted-connection NOTICE
61 : log-connection ( remote local -- )
62 [ [ remote-address set ] [ local-address set ] bi* ]
63 [ 2array accepted-connection ]
66 M: threaded-server handle-client* handler>> call ;
68 : handle-client ( client remote local -- )
72 [ timeout>> timeouts ] [ handle-client* ] bi
75 : thread-name ( server-name addrspec -- string )
76 unparse-short " connection from " swap 3append ;
78 : accept-connection ( threaded-server -- )
79 [ accept ] [ addr>> ] bi
80 [ '[ _ _ _ handle-client ] ]
81 [ drop threaded-server get name>> swap thread-name ] 2bi
84 : accept-loop ( threaded-server -- )
86 threaded-server get semaphore>>
87 [ [ accept-connection ] with-semaphore ]
90 ] [ accept-loop ] bi ; inline recursive
92 : started-accept-loop ( threaded-server -- )
94 [ sockets>> push ] [ ready>> raise-flag ] bi ;
96 : start-accept-loop ( addrspec -- )
97 threaded-server get encoding>> <server>
98 [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
100 \ start-accept-loop ERROR add-error-logging
102 : init-server ( threaded-server -- threaded-server )
104 dup max-connections>> [
105 <semaphore> >>semaphore
111 : start-server ( threaded-server -- )
113 dup secure-config>> [
114 dup threaded-server [
121 ] with-secure-context ;
123 : wait-for-server ( threaded-server -- )
124 ready>> wait-for-flag ;
126 : start-server* ( threaded-server -- )
127 [ [ start-server ] curry "Threaded server" spawn drop ]
132 threaded-server get [ f ] change-sockets drop dispose-each ;
134 GENERIC: port ( addrspec -- n )
138 M: object port port>> ;
140 : secure-port ( -- n )
141 threaded-server get dup [ secure>> port ] when ;
143 : insecure-port ( -- n )
144 threaded-server get dup [ insecure>> port ] when ;