1 USING: alien alien.accessors alien.c-types byte-arrays
2 continuations destructors io.ports io.timeouts io.sockets
3 io namespaces io.streams.duplex io.backend.windows
4 io.sockets.windows io.backend.windows.nt windows.winsock kernel
5 libc math sequences threads system combinators accessors ;
6 IN: io.sockets.windows.nt
8 : malloc-int ( object -- object )
9 "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
11 M: winnt WSASocket-flags ( -- DWORD )
14 : get-ConnectEx-ptr ( socket -- void* )
15 SIO_GET_EXTENSION_FUNCTION_POINTER
24 WSAIoctl SOCKET_ERROR = [
25 winsock-error-string throw
29 TUPLE: ConnectEx-args port
30 s name namelen lpSendBuffer dwSendDataLength
31 lpdwBytesSent lpOverlapped ptr ;
33 : wait-for-socket ( args -- n )
34 [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
36 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
43 (make-overlapped) >>lpOverlapped ; inline
45 : call-ConnectEx ( ConnectEx -- )
51 [ dwSendDataLength>> ]
57 { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
58 "stdcall" alien-indirect drop
59 winsock-error-string [ throw ] when* ; inline
61 M: object establish-connection ( client-out remote -- )
62 make-sockaddr/size <ConnectEx-args>
64 dup port>> handle>> handle>> >>s
65 dup s>> get-ConnectEx-ptr >>ptr
67 wait-for-socket drop ;
69 TUPLE: AcceptEx-args port
70 sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
71 dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
73 : init-accept-buffer ( addr AcceptEx -- )
74 swap sockaddr-size 16 +
75 [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
76 dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
79 : <AcceptEx-args> ( server addr -- AcceptEx )
81 2dup init-accept-buffer
82 swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
83 over handle>> handle>> >>sListenSocket
85 0 >>dwReceiveDataLength
87 (make-overlapped) >>lpOverlapped ; inline
89 : call-AcceptEx ( AcceptEx -- )
94 [ dwReceiveDataLength>> ]
95 [ dwLocalAddressLength>> ]
96 [ dwRemoteAddressLength>> ]
97 [ lpdwBytesReceived>> ]
99 } cleave AcceptEx drop
100 winsock-error-string [ throw ] when* ; inline
102 : extract-remote-address ( AcceptEx -- sockaddr )
105 [ dwReceiveDataLength>> ]
106 [ dwLocalAddressLength>> ]
107 [ dwRemoteAddressLength>> ]
112 [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
114 M: object (accept) ( server addr -- handle sockaddr )
119 [ wait-for-socket drop ]
120 [ sAcceptSocket>> <win32-socket> ]
121 [ extract-remote-address ]
125 TUPLE: WSARecvFrom-args port
126 s lpBuffers dwBufferCount lpNumberOfBytesRecvd
127 lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
129 : make-receive-buffer ( -- WSABUF )
130 "WSABUF" malloc-object &free
131 default-buffer-size get over set-WSABUF-len
132 default-buffer-size get malloc &free over set-WSABUF-buf ; inline
134 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
137 dup port>> handle>> handle>> >>s
138 dup port>> addr>> sockaddr-size
139 [ malloc &free >>lpFrom ]
140 [ malloc-int &free >>lpFromLen ] bi
141 make-receive-buffer >>lpBuffers
143 0 malloc-int &free >>lpFlags
144 0 malloc-int &free >>lpNumberOfBytesRecvd
145 (make-overlapped) >>lpOverlapped ; inline
147 : call-WSARecvFrom ( WSARecvFrom -- )
152 [ lpNumberOfBytesRecvd>> ]
157 [ lpCompletionRoutine>> ]
158 } cleave WSARecvFrom socket-error* ; inline
160 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
161 [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
162 [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
164 M: winnt (receive) ( datagram -- packet addrspec )
169 [ parse-WSARecvFrom ]
173 TUPLE: WSASendTo-args port
174 s lpBuffers dwBufferCount lpNumberOfBytesSent
175 dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
177 : make-send-buffer ( packet -- WSABUF )
178 "WSABUF" malloc-object &free
179 [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
180 [ [ length ] dip set-WSABUF-len ]
184 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
187 dup port>> handle>> handle>> >>s
188 swap make-sockaddr/size
189 [ malloc-byte-array &free ] dip
190 [ >>lpTo ] [ >>iToLen ] bi*
191 swap make-send-buffer >>lpBuffers
194 0 <uint> >>lpNumberOfBytesSent
195 (make-overlapped) >>lpOverlapped ; inline
197 : call-WSASendTo ( WSASendTo -- )
202 [ lpNumberOfBytesSent>> ]
207 [ lpCompletionRoutine>> ]
208 } cleave WSASendTo socket-error* ; inline
210 M: winnt (send) ( packet addrspec datagram -- )
214 [ wait-for-socket drop ]