Sockets fixes

db4
Slava Pestov 2008-05-14 19:41:39 -05:00
parent 8abb2dca15
commit a2617cb1d6
7 changed files with 56 additions and 58 deletions

View File

@ -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
[ ] [
[

View File

@ -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

View File

@ -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

View File

@ -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
[ establish-connection ] [ drop ] [ get-local-address ] 2tri
[ ((client)) ] keep
[
>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
swap server-port <port>
swap >>addr
r> >>encoding ;
>r
[ (server) ] keep
[ drop server-port <port> ] [ get-local-address ] 2bi
>>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
tuck
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
[ addr>> parse-sockaddr ]
2bi* ;
[
dup addr>>
[ (accept) ] keep
[ drop dup <ports> ] [ get-local-address ] 2bi
-rot
] keep encoding>> <encoder-duplex> swap ;
TUPLE: datagram-port < port addr ;

View File

@ -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) ]
[ drop handle>> do-ssl-connect ]
[ drop t >>connected 2drop ]
3tri ;
[ establish-connection ]
[ drop dup handle>> do-ssl-connect ]
[ drop t >>connected drop ]
2tri ;
M: ssl (server) addrspec>> (server) ;
@ -117,12 +117,8 @@ M: ssl (server) addrspec>> (server) ;
M: ssl (accept)
[
addrspec>>
(accept) >r
|close-handle
<ssl-socket> |close-handle
addrspec>> (accept) |close-handle <ssl-socket> |close-handle
dup do-ssl-accept
r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )

View File

@ -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
dup handle-fd 10 listen io-error
dup
] keep
get-socket-name
SOCK_STREAM server-socket-fd
dup handle-fd 10 listen io-error
] with-destructors ;
: do-accept ( server addrspec -- fd remote )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
[ accept ] 2keep drop ; inline
: do-accept ( server addrspec -- fd )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline
M: object (accept) ( server addrspec -- fd remote )
M: object (accept) ( server addrspec -- fd )
2dup do-accept
{
{ [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ dup 0 >= ] [ 2nip <fd> ] }
{ [ err_no EINTR = ] [ drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
drop
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi

View File

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