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 classes.struct windows.kernel32 ;
7 IN: io.sockets.windows.nt
9 : malloc-int ( object -- object )
10 "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; 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 ( AcceptEx -- sockaddr )
106 [ dwReceiveDataLength>> ]
107 [ dwLocalAddressLength>> ]
108 [ dwRemoteAddressLength>> ]
113 [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
115 M: object (accept) ( server addr -- handle sockaddr )
120 [ wait-for-socket drop ]
121 [ sAcceptSocket>> <win32-socket> ]
122 [ extract-remote-address ]
126 TUPLE: WSARecvFrom-args port
127 s lpBuffers dwBufferCount lpNumberOfBytesRecvd
128 lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
130 : make-receive-buffer ( -- WSABUF )
131 WSABUF malloc-struct &free
132 default-buffer-size get
133 [ >>len ] [ malloc &free >>buf ] bi ; inline
135 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
138 dup port>> handle>> handle>> >>s
139 dup port>> addr>> sockaddr-size
140 [ malloc &free >>lpFrom ]
141 [ malloc-int &free >>lpFromLen ] bi
142 make-receive-buffer >>lpBuffers
144 0 malloc-int &free >>lpFlags
145 0 malloc-int &free >>lpNumberOfBytesRecvd
146 (make-overlapped) >>lpOverlapped ; inline
148 : call-WSARecvFrom ( WSARecvFrom -- )
153 [ lpNumberOfBytesRecvd>> ]
158 [ lpCompletionRoutine>> ]
159 } cleave WSARecvFrom socket-error* ; inline
161 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
162 [ lpBuffers>> buf>> swap memory>byte-array ]
163 [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
165 M: winnt (receive) ( datagram -- packet addrspec )
170 [ parse-WSARecvFrom ]
174 TUPLE: WSASendTo-args port
175 s lpBuffers dwBufferCount lpNumberOfBytesSent
176 dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
178 : make-send-buffer ( packet -- WSABUF )
179 [ WSABUF malloc-struct &free ] dip
180 [ malloc-byte-array &free >>buf ]
181 [ length >>len ] bi ; inline
183 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
186 dup port>> handle>> handle>> >>s
187 swap make-sockaddr/size
188 [ malloc-byte-array &free ] dip
189 [ >>lpTo ] [ >>iToLen ] bi*
190 swap make-send-buffer >>lpBuffers
193 0 <uint> >>lpNumberOfBytesSent
194 (make-overlapped) >>lpOverlapped ; inline
196 : call-WSASendTo ( WSASendTo -- )
201 [ lpNumberOfBytesSent>> ]
206 [ lpCompletionRoutine>> ]
207 } cleave WSASendTo socket-error* ; inline
209 M: winnt (send) ( packet addrspec datagram -- )
213 [ wait-for-socket drop ]