diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 21eb241b84..a3b9676aac 100755 --- a/extra/http/http-tests.factor +++ b/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 diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index f3ee309380..86cfe35bc1 100755 --- a/extra/io/server/server-tests.factor +++ b/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 diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 2bddb78206..23066114e4 100755 --- a/extra/io/server/server.factor +++ b/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 -- ) - [ - >r [ remote-address set ] [ accepted-connection ] bi - r> call - ] 2curry with-stream ; inline +: with-connection ( client remote quot -- ) + '[ + , [ remote-address set ] [ accepted-connection ] bi + @ + ] 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 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 ] 2curry with-logging - ] 3curry parallel-each + '[ , [ , , server-loop ] with-logging ] 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 -- ) - [ - [ swap spawn-datagrams ] curry parallel-each - ] curry with-logging ; inline + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 971ad95e5e..0975f83c46 100755 --- a/extra/io/sockets/sockets.factor +++ b/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 diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index bb8364d58e..675cd9a396 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/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 - [ file>> wait-to-connect ] +M: ssl-handle (wait-to-connect) + [ file>> (wait-to-connect) ] [ handle>> do-ssl-connect ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 01c0736663..a04d008a21 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/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 ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 71e8dba8e6..745cac0cd1 100755 --- a/extra/unix/unix.factor +++ b/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 ) ;