factor: trim using lists

[factor.git] / basis / io / servers / servers.factor

diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor
index 6f598b3110a39b40ca81a55ef1365d5d1a05d8db..8aa2f7f5cd6e2355d342bc8afaea9cc66ecfe324 100644 (file)
--- a/basis/io/servers/servers.factor
+++ b/basis/io/servers/servers.factor
@@ -1,13 +1,10 @@
 ! 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
@@ -28,25 +25,17 @@ secure-context ;
 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>
 
@@ -78,16 +67,19 @@ M: inet6 >insecure 1array ;
 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 -- )
     [
@@ -99,7 +91,7 @@ M: f >insecure ;
 
 : 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( -- ) ;
@@ -141,7 +133,7 @@ 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 ;
 
@@ -179,7 +171,7 @@ PRIVATE>
             [ ] [ name>> ] bi
             [
                 set-servers
-                dup add-running-server
+                dup running-servers get add-running-server
                 dup servers>>
                 [
                     [ '[ _ _ [ start-accept-loop ] with-disposal ] ]
@@ -194,7 +186,7 @@ PRIVATE>
 
 : stop-server ( threaded-server -- )
     dup server-running? [
-        [ remove-running-server ]
+        [ running-servers get remove-running-server ]
         [
             [
                 [ secure-context>> [ &dispose drop ] when* ]
@@ -217,7 +209,7 @@ PRIVATE>
     '[
         [ _ threaded-server _ with-variable ]
         [ _ stop-server ]
-        [ ] cleanup
+        finally
     ] call ; inline
 
 <PRIVATE
@@ -228,7 +220,9 @@ 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 <secure> ;
+M: secure connect-addr addrspec>> connect-addr f <secure> ;
+
+M: local connect-addr ;
 
 PRIVATE>
 
@@ -239,8 +233,8 @@ PRIVATE>
     server-addrs [ secure? ] filter random ;
 
 : insecure-addr ( -- addrspec )
-    server-addrs [ secure? not ] filter random ;
-    
+    server-addrs [ secure? ] reject random ;
+
 : server. ( threaded-server -- )
     [ [ "=== " write name>> ] [ ] bi write-object nl ]
     [ servers>> [ addr>> present print ] each ] bi ;
@@ -250,7 +244,7 @@ PRIVATE>
 
 : get-servers-named ( string -- sequence )
     [ all-servers ] dip '[ name>> _ = ] filter ;
-    
+
 : servers. ( -- )
     all-servers [ server. ] each ;