Sockets fixes
parent
8abb2dca15
commit
a2617cb1d6
|
@ -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
|
||||
|
||||
[ ] [
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
Loading…
Reference in New Issue