1 ! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors alien alien.c-types alien.data alien.strings
5 byte-arrays classes.struct combinators destructors io.backend
6 io.encodings.ascii io.files.windows io.ports io.sockets
7 io.sockets.icmp io.sockets.private kernel libc locals math
8 sequences system windows.errors windows.handles windows.kernel32
9 windows.types windows.winsock ;
11 FROM: namespaces => get ;
12 IN: io.sockets.windows
14 : set-socket-option ( handle level opt -- )
15 [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;
17 : set-ioctl-socket ( handle cmd arg -- )
18 [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;
20 M: windows addrinfo-error-string ( n -- string )
21 n>win32-error-string ;
23 M: windows sockaddr-of-family ( alien af -- addrspec )
25 { AF_INET [ sockaddr-in memory>struct ] }
26 { AF_INET6 [ sockaddr-in6 memory>struct ] }
30 M: windows addrspec-of-family ( af -- addrspec )
32 { AF_INET [ T{ ipv4 } ] }
33 { AF_INET6 [ T{ ipv6 } ] }
37 TUPLE: win32-socket < win32-file ;
39 : <win32-socket> ( handle -- win32-socket )
40 win32-socket new-win32-handle ;
42 M: win32-socket dispose* ( stream -- )
43 handle>> closesocket socket-error* ;
45 : unspecific-sockaddr/size ( addrspec -- sockaddr len )
46 [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;
48 : opened-socket ( handle -- win32-socket )
49 <win32-socket> |dispose add-completion ;
51 : open-socket ( addrspec type -- win32-socket )
52 [ drop protocol-family ] [ swap protocol ] 2bi
53 f 0 WSA_FLAG_OVERLAPPED WSASocket
57 M: object (get-local-address) ( socket addrspec -- sockaddr )
58 [ handle>> ] dip empty-sockaddr/size int <ref>
59 [ getsockname socket-error ] keepd ;
61 M: object (get-remote-address) ( socket addrspec -- sockaddr )
62 [ handle>> ] dip empty-sockaddr/size int <ref>
63 [ getpeername socket-error ] keepd ;
65 : bind-socket ( win32-socket sockaddr len -- )
66 [ handle>> ] 2dip bind socket-error ;
68 M: object remote>handle ( addrspec -- handle )
69 [ SOCK_STREAM open-socket ] keep
71 bind-local-address get
72 [ nip make-sockaddr/size ]
73 [ unspecific-sockaddr/size ] if* bind-socket
76 : server-socket ( addrspec type -- fd )
77 [ open-socket ] [ drop ] 2bi
78 [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
80 ! http://support.microsoft.com/kb/127144
81 ! NOTE: Possibly tweak this because of SYN flood attacks
82 : listen-backlog ( -- n ) 0x7fffffff ; inline
84 M: object (server) ( addrspec -- handle )
86 SOCK_STREAM server-socket
87 dup handle>> listen-backlog listen winsock-return-check
90 M: windows (datagram) ( addrspec -- handle )
91 [ SOCK_DGRAM server-socket ] with-destructors ;
93 M: windows (raw) ( addrspec -- handle )
94 [ SOCK_RAW server-socket ] with-destructors ;
96 M: windows (broadcast) ( datagram -- datagram )
97 dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
99 : malloc-int ( n -- alien )
100 int <ref> malloc-byte-array ; inline
102 : get-ConnectEx-ptr ( socket -- void* )
103 SIO_GET_EXTENSION_FUNCTION_POINTER
112 WSAIoctl SOCKET_ERROR = [
113 maybe-winsock-exception throw
115 ] with-out-parameters ;
117 TUPLE: ConnectEx-args port
118 s name namelen lpSendBuffer dwSendDataLength
119 lpdwBytesSent lpOverlapped ptr ;
121 : wait-for-socket ( args -- count )
122 [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
124 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
131 (make-overlapped) >>lpOverlapped ; inline
133 : call-ConnectEx ( ConnectEx -- )
139 [ dwSendDataLength>> ]
145 { SOCKET void* int PVOID DWORD LPDWORD void* }
146 stdcall alien-indirect drop
147 winsock-error ; inline
149 M: object establish-connection ( client-out remote -- )
150 make-sockaddr/size-outgoing <ConnectEx-args>
152 dup port>> handle>> handle>> >>s
153 dup s>> get-ConnectEx-ptr >>ptr
155 wait-for-socket drop ;
157 TUPLE: AcceptEx-args port
158 sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
159 dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
161 : init-accept-buffer ( addr AcceptEx -- )
162 swap sockaddr-size 16 +
163 [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
164 dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
167 : <AcceptEx-args> ( server addr -- AcceptEx )
169 2dup init-accept-buffer
170 swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
171 over handle>> handle>> >>sListenSocket
173 0 >>dwReceiveDataLength
174 f >>lpdwBytesReceived
175 (make-overlapped) >>lpOverlapped ; inline
177 ! AcceptEx return value is useless
178 : call-AcceptEx ( AcceptEx -- )
183 [ dwReceiveDataLength>> ]
184 [ dwLocalAddressLength>> ]
185 [ dwRemoteAddressLength>> ]
186 [ lpdwBytesReceived>> ]
188 } cleave AcceptEx drop winsock-error ; inline
190 : (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
191 f void* <ref> 0 int <ref> f void* <ref>
192 [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
194 : extract-remote-address ( AcceptEx -- sockaddr )
198 [ dwReceiveDataLength>> ]
199 [ dwLocalAddressLength>> ]
200 [ dwRemoteAddressLength>> ]
202 (extract-remote-address)
203 ] [ port>> addr>> protocol-family ] bi
204 sockaddr-of-family ; inline
206 M: object (accept) ( server addr -- handle sockaddr )
211 [ wait-for-socket drop ]
212 [ sAcceptSocket>> <win32-socket> ]
213 [ extract-remote-address ]
217 TUPLE: WSARecvFrom-args port
218 s lpBuffers dwBufferCount lpNumberOfBytesRecvd
219 lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
221 :: make-receive-buffer ( n buf -- buf' WSABUF )
222 buf >c-ptr pinned-alien?
223 [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'
225 WSABUF malloc-struct &free
229 :: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )
230 n buf make-receive-buffer :> ( buf' wsaBuf )
234 datagram handle>> handle>> >>s
235 datagram addr>> sockaddr-size
236 [ malloc &free >>lpFrom ]
237 [ malloc-int &free >>lpFromLen ] bi
240 0 malloc-int &free >>lpFlags
241 0 malloc-int &free >>lpNumberOfBytesRecvd
242 (make-overlapped) >>lpOverlapped ; inline
244 : call-WSARecvFrom ( WSARecvFrom -- )
249 [ lpNumberOfBytesRecvd>> ]
254 [ lpCompletionRoutine>> ]
255 } cleave WSARecvFrom socket-error* ; inline
257 :: finalize-buf ( buf buf' count -- )
258 buf buf' eq? [ buf buf' count memcpy ] unless ; inline
260 :: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )
261 buf buf' count finalize-buf
263 [ port>> addr>> empty-sockaddr dup ]
265 [ lpFromLen>> int deref ]
268 M: windows (receive-unsafe) ( n buf datagram -- count addrspec )
273 [ parse-WSARecvFrom ]
277 TUPLE: WSASendTo-args port
278 s lpBuffers dwBufferCount lpNumberOfBytesSent
279 dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
281 : make-send-buffer ( packet -- WSABUF )
282 [ WSABUF malloc-struct &free ] dip
283 [ malloc-byte-array &free >>buf ]
284 [ length >>len ] bi ; inline
286 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
289 dup port>> handle>> handle>> >>s
290 swap make-sockaddr/size-outgoing
291 [ malloc-byte-array &free ] dip
292 [ >>lpTo ] [ >>iToLen ] bi*
293 swap make-send-buffer >>lpBuffers
296 0 uint <ref> >>lpNumberOfBytesSent
297 (make-overlapped) >>lpOverlapped ; inline
299 : call-WSASendTo ( WSASendTo -- )
304 [ lpNumberOfBytesSent>> ]
309 [ lpCompletionRoutine>> ]
310 } cleave WSASendTo socket-error* ; inline
312 M: windows (send) ( packet addrspec datagram -- )
316 [ wait-for-socket drop ]
321 256 [ <byte-array> dup ] keep gethostname socket-error