Sockets fixes

extra/concurrency/distributed/distributed-tests.factor

@@ -13,7 +13,8 @@ concurrency.messaging continuations ;
 
 [ ] [ test-node dup 1array swap (start-node) ] unit-test
 
-[ ] [ 1000 sleep ] unit-test
+[ ] [ yield ] unit-test
+[ ] [ yield ] unit-test
 
 [ ] [
     [

extra/db/postgresql/lib/lib.factor

@@ -127,7 +127,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
     alien>> PQfreemem ;
 
 : &postgresql-free ( alien -- alien )
-    <postgresql-malloc-destructor> &dispose ; inline
+    dup <postgresql-malloc-destructor> &dispose drop ; inline
 
 : pq-get-blob ( handle row column -- obj/f )
     [ PQgetvalue ] 3keep 3dup PQgetlength

extra/io/ports/ports.factor

@@ -28,10 +28,10 @@ M: handle-destructor dispose ( obj -- )
     handle>> close-handle ;
 
 : &close-handle ( handle -- handle )
-    <handle-destructor> <only-once> &dispose ; inline
+    dup <handle-destructor> <only-once> &dispose drop ; inline
 
 : |close-handle ( handle -- handle )
-    <handle-destructor> <only-once> |dispose ; inline
+    dup <handle-destructor> <only-once> |dispose drop ; inline
 
 : <port> ( handle class -- port )
     new

extra/io/sockets/sockets.factor

@@ -151,7 +151,10 @@ M: inet6 parse-sockaddr
 
 M: f parse-sockaddr nip ;
 
-GENERIC# get-local-address 1 ( handle remote -- sockaddr )
+GENERIC: (get-local-address) ( handle remote -- sockaddr )
+
+: get-local-address ( handle remote -- local )
+    [ (get-local-address) ] keep parse-sockaddr ;
 
 GENERIC: establish-connection ( client-out remote -- )
 
@@ -163,8 +166,13 @@ M: array (client) [ (client) 3array ] attempt-all first3 ;
 
 M: object (client) ( remote -- client-in client-out local )
     [
-        [ ((client)) dup <ports> 2dup [ |dispose drop ] bi@ ] keep
+        [ ((client)) ] keep
-        [ establish-connection ] [ drop ] [ get-local-address ] 2tri
+        [
+            >r dup <ports> [ |dispose ] bi@ dup r>
+            establish-connection
+        ]
+        [ get-local-address ]
+        2bi
     ] with-destructors ;
 
 : <client> ( remote encoding -- stream local )
@@ -182,23 +190,23 @@ TUPLE: server-port < port addr encoding ;
     check-closed
     dup server-port? [ "Not a server port" throw ] unless ; inline
 
-GENERIC: (server) ( addrspec -- handle sockaddr )
+GENERIC: (server) ( addrspec -- handle )
 
 : <server> ( addrspec encoding -- server )
-    >r [ (server) ] keep parse-sockaddr
+    >r
-    swap server-port <port>
+    [ (server) ] keep
-        swap >>addr
+    [ drop server-port <port> ] [ get-local-address ] 2bi
-        r> >>encoding ;
+    >>addr r> >>encoding ;
 
-GENERIC: (accept) ( server addrspec -- handle remote )
+GENERIC: (accept) ( server addrspec -- handle )
 
 : accept ( server -- client remote )
-    check-server-port
+    [
-    [ dup addr>> (accept) ] keep
+        dup addr>>
-    tuck
+        [ (accept) ] keep
-    [ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
+        [ drop dup <ports> ] [ get-local-address ] 2bi
-    [ addr>> parse-sockaddr ]
+        -rot
-    2bi* ;
+    ] keep encoding>> <encoder-duplex> swap ;
 
 TUPLE: datagram-port < port addr ;
 

extra/io/unix/sockets/secure/secure.factor

@@ -92,12 +92,12 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
     2dup SSL_connect check-connect-response dup
     [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
 
-M: ssl-handle (wait-to-connect)
+M: ssl establish-connection ( client-out remote -- )
     addrspec>>
-    [ >r file>> r> (wait-to-connect) ]
+    [ establish-connection ]
-    [ drop handle>> do-ssl-connect ]
+    [ drop dup handle>> do-ssl-connect ]
-    [ drop t >>connected 2drop ]
+    [ drop t >>connected drop ]
-    3tri ;
+    2tri ;
 
 M: ssl (server) addrspec>> (server) ;
 
@@ -117,12 +117,8 @@ M: ssl (server) addrspec>> (server) ;
 
 M: ssl (accept)
     [
-        addrspec>>
+        addrspec>> (accept) |close-handle <ssl-socket> |close-handle
-        (accept) >r
-        |close-handle
-        <ssl-socket> |close-handle
         dup do-ssl-accept
-        r>
     ] with-destructors ;
 
 : check-shutdown-response ( handle r -- event )

extra/io/unix/sockets/sockets.factor

@@ -22,7 +22,7 @@ M: unix addrinfo-error ( n -- )
     dup zero? [ drop ] [ gai_strerror throw ] if ;
 
 ! Client sockets - TCP and Unix domain
-M: fd get-local-address ( handle remote -- sockaddr )
+M: object (get-local-address) ( handle remote -- sockaddr )
     >r handle-fd r> empty-sockaddr/size
     [ getsockname io-error ] 2keep drop ;
 
@@ -32,18 +32,18 @@ M: fd get-local-address ( handle remote -- sockaddr )
 : wait-to-connect ( port -- )
     dup handle>> handle-fd f 0 write
     {
-        { [ 0 = ] [ drop f ] }
+        { [ 0 = ] [ drop ] }
         { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
         { [ err_no EINTR = ] [ wait-to-connect ] }
         [ (io-error) ]
     } cond ;
 
 M: object establish-connection ( client-out remote -- )
-    [ drop ] [ [ handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
+    [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
     {
-        { [ 0 = ] [ ] }
+        { [ 0 = ] [ drop ] }
         { [ err_no EINPROGRESS = ] [
-            [ +output+ wait-for-port ] [ check-connection ] [ ] tri
+            [ +output+ wait-for-port ] [ wait-to-connect ] bi
         ] }
         [ (io-error) ]
     } cond ;
@@ -60,27 +60,22 @@ M: object ((client)) ( addrspec -- fd )
     dup init-server-socket
     dup handle-fd rot make-sockaddr/size bind io-error ;
 
-M: object (server) ( addrspec -- handle sockaddr )
+M: object (server) ( addrspec -- handle )
     [
-        [
+        SOCK_STREAM server-socket-fd
-            SOCK_STREAM server-socket-fd
+        dup handle-fd 10 listen io-error
-            dup handle-fd 10 listen io-error
-            dup
-        ] keep
-        get-socket-name
     ] with-destructors ;
 
-: do-accept ( server addrspec -- fd remote )
+: do-accept ( server addrspec -- fd )
-    [ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
+    [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline
-    [ accept ] 2keep drop ; inline
 
-M: object (accept) ( server addrspec -- fd remote )
+M: object (accept) ( server addrspec -- fd )
     2dup do-accept
     {
-        { [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
+        { [ dup 0 >= ] [ 2nip <fd> ] }
-        { [ err_no EINTR = ] [ 2drop (accept) ] }
+        { [ err_no EINTR = ] [ drop (accept) ] }
         { [ err_no EAGAIN = ] [
-            2drop
+            drop
             [ drop +input+ wait-for-port ]
             [ (accept) ]
             2bi

extra/smtp/smtp.factor

@@ -110,16 +110,14 @@ M: email clone
 
 : (send) ( email -- )
     [
-        [
+        helo get-ok
-            helo get-ok
+        dup from>> mail-from get-ok
-            dup from>> mail-from get-ok
+        dup to>> [ rcpt-to get-ok ] each
-            dup to>> [ rcpt-to get-ok ] each
+        data get-ok
-            data get-ok
+        dup headers>> write-headers
-            dup headers>> write-headers
+        crlf
-            crlf
+        body>> send-body get-ok
-            body>> send-body get-ok
+        quit get-ok
-            quit get-ok USING: continuations debugger ;
-        ] [ global [ error. :c ] bind ] recover
     ] with-smtp-connection ;
 
 : extract-email ( recepient -- email )