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
old mode 100755 (executable)
new mode 100644 (file)
index 8f7ce10..8aa2f7f
--- 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,18 +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>> ssl-supported? [ >secure ] [ drop { } ] if ]
-    [ insecure>> >insecure ]
-    bi append
-    [ resolve-host ] map concat ;
+    [ insecure>> >insecure ] bi append
+    [ resolve-host ] map concat configurable-addrspecs ;
 
 : accepted-connection ( remote local -- )
     [
@@ -101,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( -- ) ;
@@ -181,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 ] ]
@@ -196,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* ]
@@ -219,7 +209,7 @@ PRIVATE>
     '[
         [ _ threaded-server _ with-variable ]
         [ _ stop-server ]
-        [ ] cleanup
+        finally
     ] call ; inline
 
 <PRIVATE
@@ -230,7 +220,7 @@ 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 ;
 
@@ -244,7 +234,7 @@ PRIVATE>
 
 : insecure-addr ( -- addrspec )
     server-addrs [ secure? ] reject random ;
-    
+
 : server. ( threaded-server -- )
     [ [ "=== " write name>> ] [ ] bi write-object nl ]
     [ servers>> [ addr>> present print ] each ] bi ;
@@ -254,7 +244,7 @@ PRIVATE>
 
 : get-servers-named ( string -- sequence )
     [ all-servers ] dip '[ name>> _ = ] filter ;
-    
+
 : servers. ( -- )
     all-servers [ server. ] each ;