I/O fixes

extra/http/http-tests.factor

@@ -174,6 +174,8 @@ test-db [
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
+
+        yield
     ] with-scope
 ] unit-test
 

extra/io/server/server-tests.factor

@@ -1,5 +1,7 @@
 IN: io.server.tests
-USING: tools.test io.server io.server.private ;
+USING: tools.test io.server io.server.private kernel ;
 
 { 2 0 } [ [ ] server-loop ] must-infer-as
 { 2 0 } [ [ ] with-connection ] must-infer-as
+{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
+{ 2 0 } [ [ ] with-datagrams ] must-infer-as

extra/io/server/server.factor

@@ -3,7 +3,7 @@
 USING: io io.sockets io.files io.streams.duplex logging
 continuations kernel math math.parser namespaces parser
 sequences strings prettyprint debugger quotations calendar
-threads concurrency.combinators assocs ;
+threads concurrency.combinators assocs fry ;
 IN: io.server
 
 SYMBOL: servers
@@ -14,22 +14,22 @@ LOG: accepted-connection NOTICE
 
 SYMBOL: remote-address
 
-: with-connection ( client addrspec quot -- )
+: with-connection ( client remote quot -- )
-    [
+    '[
-        >r [ remote-address set ] [ accepted-connection ] bi
+        , [ remote-address set ] [ accepted-connection ] bi
-        r> call
+        @
-    ] 2curry with-stream ; inline
+    ] with-stream ; inline
 
 \ with-connection DEBUG add-error-logging
 
 : accept-loop ( server quot -- )
     [
-        >r accept r> [ with-connection ] 3curry "Client" spawn drop
+        >r accept r> '[ , , , with-connection ] "Client" spawn drop
     ] 2keep accept-loop ; inline
 
 : server-loop ( addrspec encoding quot -- )
     >r <server> dup servers get push r>
-    [ accept-loop ] curry with-disposal ; inline
+    '[ , accept-loop ] with-disposal ; inline
 
 \ server-loop NOTICE add-error-logging
 
@@ -43,9 +43,7 @@ PRIVATE>
 
 : with-server ( seq service encoding quot -- )
     V{ } clone servers [
-        [
+        '[ , [ , , server-loop ] with-logging ] parallel-each
-            [ server-loop ] 2curry with-logging
-        ] 3curry parallel-each
     ] with-variable ; inline
 
 : stop-server ( -- )
@@ -58,7 +56,7 @@ LOG: received-datagram NOTICE
 : datagram-loop ( quot datagram -- )
     [
         [ receive dup received-datagram >r swap call r> ] keep
-        pick [ send ] [ 3drop ] keep
+        pick [ send ] [ 3drop ] if
     ] 2keep datagram-loop ; inline
 
 : spawn-datagrams ( quot addrspec -- )
@@ -69,6 +67,4 @@ LOG: received-datagram NOTICE
 PRIVATE>
 
 : with-datagrams ( seq service quot -- )
-    [
+    '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
-        [ swap spawn-datagrams ] curry parallel-each
-    ] curry with-logging ; inline

extra/io/sockets/sockets.factor

@@ -195,9 +195,9 @@ GENERIC: (server) ( addrspec -- handle sockaddr )
         swap >>addr
         r> >>encoding ;
 
-HOOK: (accept) io-backend ( server -- handle sockaddr )
+HOOK: (accept) io-backend ( server -- handle remote )
 
-: accept ( server -- client addrspec )
+: accept ( server -- client remote )
     check-server-port
     [ (accept) ] keep
     tuck

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

@@ -87,6 +87,6 @@ M: ssl ((client)) ( addrspec -- handle )
     2dup SSL_connect check-connect-response dup
     [ nip wait-for-port ] [ 3drop ] if ;
 
-M: ssl-handle wait-to-connect
+M: ssl-handle (wait-to-connect)
-    [ file>> wait-to-connect ]
+    [ file>> (wait-to-connect) ]
     [ handle>> do-ssl-connect ] 2bi ;

extra/io/unix/sockets/sockets.factor

@@ -31,6 +31,9 @@ M: unix addrinfo-error ( n -- )
 : get-socket-name ( fd addrspec -- sockaddr )
     empty-sockaddr/size [ getsockname io-error ] 2keep drop ;
 
+: get-peer-name ( fd addrspec -- sockaddr )
+    empty-sockaddr/size [ getpeername io-error ] 2keep drop ;
+
 M: integer (wait-to-connect)
     >r >r +output+ wait-for-port r> r> get-socket-name ;
 
@@ -59,19 +62,19 @@ M: object (server) ( addrspec -- handle sockaddr )
         get-socket-name
     ] with-destructors ;
 
-: do-accept ( server -- fd sockaddr )
+: do-accept ( server -- fd remote )
     [ handle>> ] [ addr>> empty-sockaddr/size ] bi
     [ accept ] 2keep drop ; inline
 
-M: unix (accept) ( server -- fd sockaddr )
+M: unix (accept) ( server -- fd remote )
     dup do-accept
     {
         { [ over 0 >= ] [ rot drop ] }
-        { [ err_no EINTR = ] [ 2drop do-accept ] }
+        { [ err_no EINTR = ] [ 2drop (accept) ] }
         { [ err_no EAGAIN = ] [
             2drop
             [ +input+ wait-for-port ]
-            [ do-accept ] bi
+            [ (accept) ] bi
         ] }
         [ (io-error) ]
     } cond ;

extra/unix/unix.factor

@@ -100,6 +100,7 @@ FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsiz
 FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
 FUNCTION: int gethostname ( char* name, int len ) ;
 FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
+FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
 FUNCTION: uid_t getuid ;
 FUNCTION: uint htonl ( uint n ) ;
 FUNCTION: ushort htons ( ushort n ) ;