1 USING: alien alien.accessors alien.c-types byte-arrays
2 continuations destructors io.ports io.timeouts io.sockets
3 io.sockets.private io namespaces io.streams.duplex
4 io.backend.windows io.sockets.windows io.backend.windows.nt
5 windows.winsock kernel libc math sequences threads system
6 combinators accessors classes.struct windows.kernel32 ;
7 IN: io.sockets.windows.nt
9 : malloc-int ( n -- alien )
10 <int> malloc-byte-array ; inline
12 M: winnt WSASocket-flags ( -- DWORD )
15 : get-ConnectEx-ptr ( socket -- void* )
16 SIO_GET_EXTENSION_FUNCTION_POINTER
25 WSAIoctl SOCKET_ERROR = [
26 winsock-error-string throw
30 TUPLE: ConnectEx-args port
31 s name namelen lpSendBuffer dwSendDataLength
32 lpdwBytesSent lpOverlapped ptr ;
34 : wait-for-socket ( args -- n )
35 [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
37 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
44 (make-overlapped) >>lpOverlapped ; inline
46 : call-ConnectEx ( ConnectEx -- )
52 [ dwSendDataLength>> ]
58 { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
59 "stdcall" alien-indirect drop
60 winsock-error-string [ throw ] when* ; inline
62 M: object establish-connection ( client-out remote -- )
63 make-sockaddr/size <ConnectEx-args>
65 dup port>> handle>> handle>> >>s
66 dup s>> get-ConnectEx-ptr >>ptr
68 wait-for-socket drop ;
70 TUPLE: AcceptEx-args port
71 sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
72 dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
74 : init-accept-buffer ( addr AcceptEx -- )
75 swap sockaddr-size 16 +
76 [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
77 dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
80 : <AcceptEx-args> ( server addr -- AcceptEx )
82 2dup init-accept-buffer
83 swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
84 over handle>> handle>> >>sListenSocket
86 0 >>dwReceiveDataLength
88 (make-overlapped) >>lpOverlapped ; inline
90 : call-AcceptEx ( AcceptEx -- )
95 [ dwReceiveDataLength>> ]
96 [ dwLocalAddressLength>> ]
97 [ dwRemoteAddressLength>> ]
98 [ lpdwBytesReceived>> ]
100 } cleave AcceptEx drop
101 winsock-error-string [ throw ] when* ; inline
103 : (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
104 f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
106 : extract-remote-address ( AcceptEx -- sockaddr )
110 [ dwReceiveDataLength>> ]
111 [ dwLocalAddressLength>> ]
112 [ dwRemoteAddressLength>> ]
114 (extract-remote-address)
115 ] [ port>> addr>> protocol-family ] bi
116 sockaddr-of-family ; inline
118 M: object (accept) ( server addr -- handle sockaddr )
123 [ wait-for-socket drop ]
124 [ sAcceptSocket>> <win32-socket> ]
125 [ extract-remote-address ]
129 TUPLE: WSARecvFrom-args port
130 s lpBuffers dwBufferCount lpNumberOfBytesRecvd
131 lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
133 : make-receive-buffer ( -- WSABUF )
134 WSABUF malloc-struct &free
135 default-buffer-size get
136 [ >>len ] [ malloc &free >>buf ] bi ; inline
138 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
141 dup port>> handle>> handle>> >>s
142 dup port>> addr>> sockaddr-size
143 [ malloc &free >>lpFrom ]
144 [ malloc-int &free >>lpFromLen ] bi
145 make-receive-buffer >>lpBuffers
147 0 malloc-int &free >>lpFlags
148 0 malloc-int &free >>lpNumberOfBytesRecvd
149 (make-overlapped) >>lpOverlapped ; inline
151 : call-WSARecvFrom ( WSARecvFrom -- )
156 [ lpNumberOfBytesRecvd>> ]
161 [ lpCompletionRoutine>> ]
162 } cleave WSARecvFrom socket-error* ; inline
164 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
165 [ lpBuffers>> buf>> swap memory>byte-array ]
167 [ port>> addr>> empty-sockaddr dup ]
173 M: winnt (receive) ( datagram -- packet addrspec )
178 [ parse-WSARecvFrom ]
182 TUPLE: WSASendTo-args port
183 s lpBuffers dwBufferCount lpNumberOfBytesSent
184 dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
186 : make-send-buffer ( packet -- WSABUF )
187 [ WSABUF malloc-struct &free ] dip
188 [ malloc-byte-array &free >>buf ]
189 [ length >>len ] bi ; inline
191 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
194 dup port>> handle>> handle>> >>s
195 swap make-sockaddr/size
196 [ malloc-byte-array &free ] dip
197 [ >>lpTo ] [ >>iToLen ] bi*
198 swap make-send-buffer >>lpBuffers
201 0 <uint> >>lpNumberOfBytesSent
202 (make-overlapped) >>lpOverlapped ; inline
204 : call-WSASendTo ( WSASendTo -- )
209 [ lpNumberOfBytesSent>> ]
214 [ lpCompletionRoutine>> ]
215 } cleave WSASendTo socket-error* ; inline
217 M: winnt (send) ( packet addrspec datagram -- )
221 [ wait-for-socket drop ]