! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators
-combinators.short-circuit concurrency.combinators
-concurrency.count-downs concurrency.flags
-concurrency.semaphores continuations debugger destructors fry
-io io.sockets io.sockets.secure io.streams.duplex io.styles
-io.timeouts kernel logging make math math.parser namespaces
-present prettyprint random sequences sets strings threads ;
-FROM: namespaces => set ;
+USING: accessors arrays calendar concurrency.flags
+concurrency.semaphores continuations destructors io io.sockets
+io.sockets.secure io.streams.duplex io.styles io.timeouts kernel
+logging make math namespaces present prettyprint random
+sequences sets strings threads ;
IN: io.servers
TUPLE: threaded-server < identity-tuple
SYMBOL: running-servers
running-servers [ HS{ } clone ] initialize
-ERROR: server-already-running threaded-server ;
-
ERROR: server-not-running threaded-server ;
-<PRIVATE
-
-: must-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-not-running ] unless ;
+ERROR: server-already-running threaded-server ;
-: must-not-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-already-running ] when ;
+<PRIVATE
-: add-running-server ( threaded-server -- )
- must-not-be-running
- running-servers get adjoin ;
+: add-running-server ( threaded-server running-servers -- )
+ dupd ?adjoin [ drop ] [ server-already-running ] if ;
-: remove-running-server ( threaded-server -- )
- must-be-running
- running-servers get delete ;
+: remove-running-server ( threaded-server running-servers -- )
+ dupd ?delete [ drop ] [ server-not-running ] if ;
PRIVATE>
M: local >insecure 1array ;
M: integer >insecure internet-server 1array ;
M: string >insecure internet-server 1array ;
-M: array >insecure [ >insecure ] map ;
+M: array >insecure [ >insecure ] map concat ;
M: f >insecure ;
: >secure ( addrspec -- addrspec' )
- >insecure
- [ dup secure? [ <secure> ] unless ] map ;
+ >insecure [ dup secure? [ f <secure> ] unless ] map ;
+
+: configurable-addrspecs ( addrspecs -- addrspecs' )
+ [ inet6? not ipv6-supported? or ] filter ;
: listen-on ( threaded-server -- addrspecs )
- [ secure>> >secure ] [ insecure>> >insecure ] bi append
- [ resolve-host ] map concat ;
+ [ secure>> ssl-supported? [ >secure ] [ drop { } ] if ]
+ [ insecure>> >insecure ] bi append
+ [ resolve-host ] map concat configurable-addrspecs ;
: accepted-connection ( remote local -- )
[
: log-connection ( remote local -- )
[ accepted-connection ]
- [ [ remote-address set ] [ local-address set ] bi* ]
+ [ [ remote-address namespaces:set ] [ local-address namespaces:set ] bi* ]
2bi ;
M: threaded-server handle-client* handler>> call( -- ) ;
\ start-accept-loop NOTICE add-error-logging
: create-secure-context ( threaded-server -- threaded-server )
- dup secure>> [
+ dup secure>> ssl-supported? and [
dup secure-config>> <secure-context> >>secure-context
] when ;
: set-servers ( threaded-server -- threaded-server )
dup [
- dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
+ dup dup listen-on
+ [ no-ports-configured ] [ (make-servers) ] if-empty
>>servers
] with-existing-secure-context ;
[ ] [ name>> ] bi
[
set-servers
- dup add-running-server
+ dup running-servers get add-running-server
dup servers>>
[
[ '[ _ _ [ start-accept-loop ] with-disposal ] ]
: stop-server ( threaded-server -- )
dup server-running? [
- [ remove-running-server ]
+ [ running-servers get remove-running-server ]
[
[
[ secure-context>> [ &dispose drop ] when* ]
'[
[ _ threaded-server _ with-variable ]
[ _ stop-server ]
- [ ] cleanup
+ finally
] call ; inline
<PRIVATE
-: first-port ( quot -- n/f )
- [ threaded-server get servers>> ] dip
- filter [ f ] [ first addr>> port>> ] if-empty ; inline
+GENERIC: connect-addr ( addrspec -- addrspec )
+
+M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
+
+M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
+
+M: secure connect-addr addrspec>> connect-addr f <secure> ;
+
+M: local connect-addr ;
PRIVATE>
-: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
+: server-addrs ( -- addrspecs )
+ threaded-server get servers>> [ addr>> connect-addr ] map ;
-: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
+: secure-addr ( -- addrspec )
+ server-addrs [ secure? ] filter random ;
-: secure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? ] filter random ;
+: insecure-addr ( -- addrspec )
+ server-addrs [ secure? ] reject random ;
-: insecure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
-
: server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ]
[ servers>> [ addr>> present print ] each ] bi ;
: get-servers-named ( string -- sequence )
[ all-servers ] dip '[ name>> _ = ] filter ;
-
+
: servers. ( -- )
all-servers [ server. ] each ;