factor/basis/io/windows/nt/sockets/sockets.factor

217 lines
6.3 KiB
Factor
Raw Normal View History

2008-02-01 00:00:08 -05:00
USING: alien alien.accessors alien.c-types byte-arrays
2008-05-13 19:24:46 -04:00
continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows
io.windows.sockets io.windows.nt.backend windows.winsock kernel
libc math sequences threads system combinators accessors ;
2007-09-20 18:09:08 -04:00
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
2008-04-02 21:09:56 -04:00
M: winnt WSASocket-flags ( -- DWORD )
2007-09-20 18:09:08 -04:00
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
"GUID" heap-size
"void*" <c-object>
[
"void*" heap-size
"DWORD" <c-object>
f
f
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
] keep *void* ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
lpdwBytesSent lpOverlapped ptr ;
2007-09-20 18:09:08 -04:00
: wait-for-socket ( args -- n )
[ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
2008-05-15 01:13:08 -04:00
ConnectEx-args new
swap >>namelen
swap >>name
f >>lpSendBuffer
0 >>dwSendDataLength
f >>lpdwBytesSent
(make-overlapped) >>lpOverlapped ; inline
2008-05-15 01:13:08 -04:00
: call-ConnectEx ( ConnectEx -- )
{
[ s>> ]
[ name>> ]
[ namelen>> ]
[ lpSendBuffer>> ]
[ dwSendDataLength>> ]
[ lpdwBytesSent>> ]
[ lpOverlapped>> ]
[ ptr>> ]
} cleave
2007-09-20 18:09:08 -04:00
"int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ; inline
2007-09-20 18:09:08 -04:00
2008-05-15 02:45:32 -04:00
M: object establish-connection ( client-out remote -- )
make-sockaddr/size <ConnectEx-args>
swap >>port
dup port>> handle>> handle>> >>s
dup s>> get-ConnectEx-ptr >>ptr
2008-05-15 02:45:32 -04:00
dup call-ConnectEx
wait-for-socket drop ;
2007-09-20 18:09:08 -04:00
TUPLE: AcceptEx-args port
sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
2007-09-20 18:09:08 -04:00
: init-accept-buffer ( addr AcceptEx -- )
2008-10-02 04:38:36 -04:00
swap sockaddr-size 16 +
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; inline
2008-05-15 01:13:08 -04:00
: <AcceptEx-args> ( server addr -- AcceptEx )
2008-05-15 01:13:08 -04:00
AcceptEx-args new
2dup init-accept-buffer
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
over handle>> handle>> >>sListenSocket
2008-05-15 02:45:32 -04:00
swap >>port
0 >>dwReceiveDataLength
f >>lpdwBytesReceived
(make-overlapped) >>lpOverlapped ; inline
2008-05-15 01:13:08 -04:00
: call-AcceptEx ( AcceptEx -- )
{
[ sListenSocket>> ]
[ sAcceptSocket>> ]
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
[ lpdwBytesReceived>> ]
[ lpOverlapped>> ]
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
2007-09-20 18:09:08 -04:00
: extract-remote-address ( AcceptEx -- sockaddr )
{
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
} cleave
f <void*>
0 <int>
f <void*>
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
M: object (accept) ( server addr -- handle sockaddr )
2007-09-20 18:09:08 -04:00
[
<AcceptEx-args>
{
2008-05-15 06:50:50 -04:00
[ call-AcceptEx ]
[ wait-for-socket drop ]
[ sAcceptSocket>> <win32-socket> ]
[ extract-remote-address ]
} cleave
2007-09-20 18:09:08 -04:00
] with-destructors ;
TUPLE: WSARecvFrom-args port
s lpBuffers dwBufferCount lpNumberOfBytesRecvd
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
2007-09-20 18:09:08 -04:00
2008-01-28 02:06:27 -05:00
: make-receive-buffer ( -- WSABUF )
2008-05-15 01:13:08 -04:00
"WSABUF" malloc-object &free
2008-01-28 02:06:27 -05:00
default-buffer-size get over set-WSABUF-len
default-buffer-size get malloc &free over set-WSABUF-buf ; inline
2008-05-15 01:13:08 -04:00
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
2008-05-15 02:45:32 -04:00
swap >>port
dup port>> handle>> handle>> >>s
2008-10-02 04:38:36 -04:00
dup port>> addr>> sockaddr-size
[ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers
1 >>dwBufferCount
0 malloc-int &free >>lpFlags
0 malloc-int &free >>lpNumberOfBytesRecvd
(make-overlapped) >>lpOverlapped ; inline
2008-05-15 01:13:08 -04:00
2007-09-20 18:09:08 -04:00
: call-WSARecvFrom ( WSARecvFrom -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesRecvd>> ]
[ lpFlags>> ]
[ lpFrom>> ]
[ lpFromLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSARecvFrom socket-error* ; inline
2007-09-20 18:09:08 -04:00
2008-05-15 01:13:08 -04:00
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> WSABUF-buf swap memory>byte-array ]
[ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
2007-09-20 18:09:08 -04:00
M: winnt (receive) ( datagram -- packet addrspec )
2007-09-20 18:09:08 -04:00
[
2008-05-15 01:13:08 -04:00
<WSARecvFrom-args>
2008-05-15 06:50:50 -04:00
[ call-WSARecvFrom ]
[ wait-for-socket ]
[ parse-WSARecvFrom ]
tri
2007-09-20 18:09:08 -04:00
] with-destructors ;
TUPLE: WSASendTo-args port
s lpBuffers dwBufferCount lpNumberOfBytesSent
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
2007-09-20 18:09:08 -04:00
2008-01-28 02:06:27 -05:00
: make-send-buffer ( packet -- WSABUF )
2008-05-15 01:13:08 -04:00
"WSABUF" malloc-object &free
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
[ >r length r> set-WSABUF-len ]
[ nip ]
2tri ; inline
2008-05-15 01:13:08 -04:00
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
2008-05-15 02:45:32 -04:00
swap >>port
dup port>> handle>> handle>> >>s
2008-05-15 01:13:08 -04:00
swap make-sockaddr/size
>r malloc-byte-array &free
r> [ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags
0 <uint> >>lpNumberOfBytesSent
(make-overlapped) >>lpOverlapped ; inline
2008-05-15 01:13:08 -04:00
2007-09-20 18:09:08 -04:00
: call-WSASendTo ( WSASendTo -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesSent>> ]
[ dwFlags>> ]
[ lpTo>> ]
[ iToLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSASendTo socket-error* ; inline
2007-09-20 18:09:08 -04:00
M: winnt (send) ( packet addrspec datagram -- )
2007-09-20 18:09:08 -04:00
[
2008-05-15 01:13:08 -04:00
<WSASendTo-args>
[ call-WSASendTo ]
2008-05-15 02:45:32 -04:00
[ wait-for-socket drop ]
2008-05-15 06:50:50 -04:00
bi
2007-09-20 18:09:08 -04:00
] with-destructors ;