! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors io.sockets io.sockets.private\r
-io.backend.windows io.backend windows.winsock system destructors\r
-alien.c-types classes.struct combinators ;\r
+USING: accessors alien alien.c-types alien.data classes.struct\r
+combinators destructors io.backend io.files.windows io.ports\r
+io.sockets io.sockets.icmp io.sockets.private kernel libc math\r
+sequences system windows.handles windows.kernel32 windows.types\r
+windows.winsock locals ;\r
FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
[ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;\r
\r
: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose dup add-completion ;\r
+ <win32-socket> |dispose add-completion ;\r
\r
: open-socket ( addrspec type -- win32-socket )\r
- [ protocol-family ] dip\r
- 0 f 0 WSASocket-flags WSASocket\r
+ [ drop protocol-family ] [ swap protocol ] 2bi\r
+ f 0 WSASocket-flags WSASocket\r
dup socket-error\r
opened-socket ;\r
\r
M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getsockname socket-error ] 2keep drop ;\r
\r
M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getpeername socket-error ] 2keep drop ;\r
\r
: bind-socket ( win32-socket sockaddr len -- )\r
\r
! http://support.microsoft.com/kb/127144\r
! NOTE: Possibly tweak this because of SYN flood attacks\r
-: listen-backlog ( -- n ) HEX: 7fffffff ; inline\r
+: listen-backlog ( -- n ) 0x7fffffff ; inline\r
\r
M: object (server) ( addrspec -- handle )\r
[\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+M: windows (raw) ( addrspec -- handle )\r
+ [ SOCK_RAW server-socket ] with-destructors ;\r
+\r
+: malloc-int ( n -- alien )\r
+ int <ref> malloc-byte-array ; inline\r
+\r
+M: windows WSASocket-flags ( -- DWORD )\r
+ WSA_FLAG_OVERLAPPED ;\r
+\r
+: get-ConnectEx-ptr ( socket -- void* )\r
+ SIO_GET_EXTENSION_FUNCTION_POINTER\r
+ WSAID_CONNECTEX\r
+ GUID heap-size\r
+ { void* }\r
+ [\r
+ void* heap-size\r
+ 0 DWORD <ref>\r
+ f\r
+ f\r
+ WSAIoctl SOCKET_ERROR = [\r
+ maybe-winsock-exception throw\r
+ ] when\r
+ ] with-out-parameters ;\r
+\r
+TUPLE: ConnectEx-args port\r
+ s name namelen lpSendBuffer dwSendDataLength\r
+ lpdwBytesSent lpOverlapped ptr ;\r
+\r
+: wait-for-socket ( args -- count )\r
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline\r
+\r
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )\r
+ ConnectEx-args new\r
+ swap >>namelen\r
+ swap >>name\r
+ f >>lpSendBuffer\r
+ 0 >>dwSendDataLength\r
+ f >>lpdwBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-ConnectEx ( ConnectEx -- )\r
+ {\r
+ [ s>> ]\r
+ [ name>> ]\r
+ [ namelen>> ]\r
+ [ lpSendBuffer>> ]\r
+ [ dwSendDataLength>> ]\r
+ [ lpdwBytesSent>> ]\r
+ [ lpOverlapped>> ]\r
+ [ ptr>> ]\r
+ } cleave\r
+ int\r
+ { SOCKET void* int PVOID DWORD LPDWORD void* }\r
+ stdcall alien-indirect drop\r
+ winsock-error ; inline\r
+\r
+M: object establish-connection ( client-out remote -- )\r
+ make-sockaddr/size <ConnectEx-args>\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup s>> get-ConnectEx-ptr >>ptr\r
+ dup call-ConnectEx\r
+ wait-for-socket drop ;\r
+\r
+TUPLE: AcceptEx-args port\r
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength\r
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;\r
+\r
+: init-accept-buffer ( addr AcceptEx -- )\r
+ swap sockaddr-size 16 +\r
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi\r
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer\r
+ drop ; inline\r
+\r
+: <AcceptEx-args> ( server addr -- AcceptEx )\r
+ AcceptEx-args new\r
+ 2dup init-accept-buffer\r
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket\r
+ over handle>> handle>> >>sListenSocket\r
+ swap >>port\r
+ 0 >>dwReceiveDataLength\r
+ f >>lpdwBytesReceived\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+! AcceptEx return value is useless\r
+: call-AcceptEx ( AcceptEx -- )\r
+ {\r
+ [ sListenSocket>> ]\r
+ [ sAcceptSocket>> ]\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ [ lpdwBytesReceived>> ]\r
+ [ lpOverlapped>> ]\r
+ } cleave AcceptEx drop winsock-error ; inline\r
+\r
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
+ f void* <ref> 0 int <ref> f void* <ref>\r
+ [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
+\r
+: extract-remote-address ( AcceptEx -- sockaddr )\r
+ [\r
+ {\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ } cleave\r
+ (extract-remote-address)\r
+ ] [ port>> addr>> protocol-family ] bi\r
+ sockaddr-of-family ; inline\r
+\r
+M: object (accept) ( server addr -- handle sockaddr )\r
+ [\r
+ <AcceptEx-args>\r
+ {\r
+ [ call-AcceptEx ]\r
+ [ wait-for-socket drop ]\r
+ [ sAcceptSocket>> <win32-socket> ]\r
+ [ extract-remote-address ]\r
+ } cleave\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSARecvFrom-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
+\r
+:: make-receive-buffer ( n buf -- buf' WSABUF )\r
+ buf >c-ptr pinned-alien?\r
+ [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'\r
+ buf'\r
+ WSABUF malloc-struct &free\r
+ n >>len\r
+ buf' >>buf ; inline\r
+\r
+:: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )\r
+ n buf make-receive-buffer :> ( buf' wsaBuf )\r
+ buf buf'\r
+ WSARecvFrom-args new\r
+ datagram >>port\r
+ datagram handle>> handle>> >>s\r
+ datagram addr>> sockaddr-size\r
+ [ malloc &free >>lpFrom ]\r
+ [ malloc-int &free >>lpFromLen ] bi\r
+ wsaBuf >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 malloc-int &free >>lpFlags\r
+ 0 malloc-int &free >>lpNumberOfBytesRecvd\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSARecvFrom ( WSARecvFrom -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesRecvd>> ]\r
+ [ lpFlags>> ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSARecvFrom socket-error* ; inline\r
+\r
+:: finalize-buf ( buf buf' count -- )\r
+ buf buf' eq? [ buf buf' count memcpy ] unless ; inline\r
+\r
+:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )\r
+ buf buf' count finalize-buf\r
+ count wsaRecvFrom\r
+ [ port>> addr>> empty-sockaddr dup ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> int deref ]\r
+ tri memcpy ; inline\r
+\r
+M: windows (receive-unsafe) ( n buf datagram -- count addrspec )\r
+ [\r
+ <WSARecvFrom-args>\r
+ [ call-WSARecvFrom ]\r
+ [ wait-for-socket ]\r
+ [ parse-WSARecvFrom ]\r
+ tri\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSASendTo-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesSent\r
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
+\r
+: make-send-buffer ( packet -- WSABUF )\r
+ [ WSABUF malloc-struct &free ] dip\r
+ [ malloc-byte-array &free >>buf ]\r
+ [ length >>len ] bi ; inline\r
+\r
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
+ WSASendTo-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ swap make-sockaddr/size\r
+ [ malloc-byte-array &free ] dip\r
+ [ >>lpTo ] [ >>iToLen ] bi*\r
+ swap make-send-buffer >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 >>dwFlags\r
+ 0 uint <ref> >>lpNumberOfBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSASendTo ( WSASendTo -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesSent>> ]\r
+ [ dwFlags>> ]\r
+ [ lpTo>> ]\r
+ [ iToLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSASendTo socket-error* ; inline\r
+\r
+M: windows (send) ( packet addrspec datagram -- )\r
+ [\r
+ <WSASendTo-args>\r
+ [ call-WSASendTo ]\r
+ [ wait-for-socket drop ]\r
+ bi\r
+ ] with-destructors ;\r
projects / factor.git / blobdiff