1 USING: alien alien.accessors alien.c-types alien.data 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
8 IN: io.sockets.windows.nt
10 : malloc-int ( n -- alien )
11 <int> malloc-byte-array ; inline
13 M: winnt WSASocket-flags ( -- DWORD )
16 : get-ConnectEx-ptr ( socket -- void* )
17 SIO_GET_EXTENSION_FUNCTION_POINTER
26 WSAIoctl SOCKET_ERROR = [
27 winsock-error-string throw
31 TUPLE: ConnectEx-args port
32 s name namelen lpSendBuffer dwSendDataLength
33 lpdwBytesSent lpOverlapped ptr ;
35 : wait-for-socket ( args -- n )
36 [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
38 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
45 (make-overlapped) >>lpOverlapped ; inline
47 : call-ConnectEx ( ConnectEx -- )
53 [ dwSendDataLength>> ]
59 { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
60 "stdcall" alien-indirect drop
61 winsock-error-string [ throw ] when* ; inline
63 M: object establish-connection ( client-out remote -- )
64 make-sockaddr/size <ConnectEx-args>
66 dup port>> handle>> handle>> >>s
67 dup s>> get-ConnectEx-ptr >>ptr
69 wait-for-socket drop ;
71 TUPLE: AcceptEx-args port
72 sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
73 dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
75 : init-accept-buffer ( addr AcceptEx -- )
76 swap sockaddr-size 16 +
77 [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
78 dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
81 : <AcceptEx-args> ( server addr -- AcceptEx )
83 2dup init-accept-buffer
84 swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
85 over handle>> handle>> >>sListenSocket
87 0 >>dwReceiveDataLength
89 (make-overlapped) >>lpOverlapped ; inline
91 : call-AcceptEx ( AcceptEx -- )
96 [ dwReceiveDataLength>> ]
97 [ dwLocalAddressLength>> ]
98 [ dwRemoteAddressLength>> ]
99 [ lpdwBytesReceived>> ]
101 } cleave AcceptEx drop
102 winsock-error-string [ throw ] when* ; inline
104 : (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
105 f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
107 : extract-remote-address ( AcceptEx -- sockaddr )
111 [ dwReceiveDataLength>> ]
112 [ dwLocalAddressLength>> ]
113 [ dwRemoteAddressLength>> ]
115 (extract-remote-address)
116 ] [ port>> addr>> protocol-family ] bi
117 sockaddr-of-family ; inline
119 M: object (accept) ( server addr -- handle sockaddr )
124 [ wait-for-socket drop ]
125 [ sAcceptSocket>> <win32-socket> ]
126 [ extract-remote-address ]
130 TUPLE: WSARecvFrom-args port
131 s lpBuffers dwBufferCount lpNumberOfBytesRecvd
132 lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
134 : make-receive-buffer ( -- WSABUF )
135 WSABUF malloc-struct &free
136 default-buffer-size get
137 [ >>len ] [ malloc &free >>buf ] bi ; inline
139 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
142 dup port>> handle>> handle>> >>s
143 dup port>> addr>> sockaddr-size
144 [ malloc &free >>lpFrom ]
145 [ malloc-int &free >>lpFromLen ] bi
146 make-receive-buffer >>lpBuffers
148 0 malloc-int &free >>lpFlags
149 0 malloc-int &free >>lpNumberOfBytesRecvd
150 (make-overlapped) >>lpOverlapped ; inline
152 : call-WSARecvFrom ( WSARecvFrom -- )
157 [ lpNumberOfBytesRecvd>> ]
162 [ lpCompletionRoutine>> ]
163 } cleave WSARecvFrom socket-error* ; inline
165 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
166 [ lpBuffers>> buf>> swap memory>byte-array ]
168 [ port>> addr>> empty-sockaddr dup ]
174 M: winnt (receive) ( datagram -- packet addrspec )
179 [ parse-WSARecvFrom ]
183 TUPLE: WSASendTo-args port
184 s lpBuffers dwBufferCount lpNumberOfBytesSent
185 dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
187 : make-send-buffer ( packet -- WSABUF )
188 [ WSABUF malloc-struct &free ] dip
189 [ malloc-byte-array &free >>buf ]
190 [ length >>len ] bi ; inline
192 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
195 dup port>> handle>> handle>> >>s
196 swap make-sockaddr/size
197 [ malloc-byte-array &free ] dip
198 [ >>lpTo ] [ >>iToLen ] bi*
199 swap make-send-buffer >>lpBuffers
202 0 <uint> >>lpNumberOfBytesSent
203 (make-overlapped) >>lpOverlapped ; inline
205 : call-WSASendTo ( WSASendTo -- )
210 [ lpNumberOfBytesSent>> ]
215 [ lpCompletionRoutine>> ]
216 } cleave WSASendTo socket-error* ; inline
218 M: winnt (send) ( packet addrspec datagram -- )
222 [ wait-for-socket drop ]