1 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.strings alien.syntax arrays
4 byte-arrays kernel math sequences windows.types windows.kernel32
5 windows.errors windows math.bitwise alias ;
9 : alien>byte-array ( alien str -- byte-array )
10 heap-size dup <byte-array> [ -rot memcpy ] keep ;
14 : <wsadata> ( -- byte-array )
15 HEX: 190 <byte-array> ;
17 : SOCK_STREAM 1 ; inline
18 : SOCK_DGRAM 2 ; inline
21 : SOCK_SEQPACKET 5 ; inline
23 : SO_DEBUG HEX: 1 ; inline
24 : SO_ACCEPTCONN HEX: 2 ; inline
25 : SO_REUSEADDR HEX: 4 ; inline
26 : SO_KEEPALIVE HEX: 8 ; inline
27 : SO_DONTROUTE HEX: 10 ; inline
28 : SO_BROADCAST HEX: 20 ; inline
29 : SO_USELOOPBACK HEX: 40 ; inline
30 : SO_LINGER HEX: 80 ; inline
31 : SO_OOBINLINE HEX: 100 ; inline
32 : SO_DONTLINGER SO_LINGER bitnot ; inline
34 : SO_SNDBUF HEX: 1001 ; inline
35 : SO_RCVBUF HEX: 1002 ; inline
36 : SO_SNDLOWAT HEX: 1003 ; inline
37 : SO_RCVLOWAT HEX: 1004 ; inline
38 : SO_SNDTIMEO HEX: 1005 ; inline
39 : SO_RCVTIMEO HEX: 1006 ; inline
40 : SO_ERROR HEX: 1007 ; inline
41 : SO_TYPE HEX: 1008 ; inline
43 : TCP_NODELAY HEX: 1 ; inline
45 : AF_UNSPEC 0 ; inline
48 : AF_IMPLINK 3 ; inline
53 : AF_OSI AF_ISO ; inline
55 : AF_DATAKIT 9 ; inline
56 : AF_CCITT 10 ; inline
58 : AF_DECnet 12 ; inline
61 : AF_HYLINK 15 ; inline
62 : AF_APPLETALK 16 ; inline
63 : AF_NETBIOS 17 ; inline
65 : AF_INET6 23 ; inline
69 : PF_UNSPEC 0 ; inline
72 : PF_INET6 23 ; inline
74 : AI_PASSIVE 1 ; inline
75 : AI_CANONNAME 2 ; inline
76 : AI_NUMERICHOST 4 ; inline
77 : AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
82 : IPPROTO_TCP 6 ; inline
83 : IPPROTO_UDP 17 ; inline
84 : IPPROTO_RM 113 ; inline
86 : WSA_FLAG_OVERLAPPED 1 ; inline
87 : WSA_WAIT_EVENT_0 WAIT_OBJECT_0 ; inline
88 : WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS ; inline
89 : WSA_INVALID_EVENT f ; inline
90 : WSA_WAIT_FAILED -1 ; inline
91 : WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION ; inline
92 : WSA_WAIT_TIMEOUT WAIT_TIMEOUT ; inline
93 : WSA_INFINITE INFINITE ; inline
94 : WSA_IO_PENDING ERROR_IO_PENDING ; inline
96 : INADDR_ANY 0 ; inline
98 : INVALID_SOCKET -1 <alien> ; inline
99 : SOCKET_ERROR -1 ; inline
105 : SOL_SOCKET HEX: ffff ; inline
107 ! TYPEDEF: uint in_addr_t
109 ! { "in_addr_t" "s_addr" } ;
111 C-STRUCT: sockaddr-in
115 { { "char" 8 } "pad" } ;
117 C-STRUCT: sockaddr-in6
120 { "uint" "flowinfo" }
121 { { "uchar" 16 } "addr" }
122 { "uint" "scopeid" } ;
126 { "void*" "aliases" }
127 { "short" "addrtype" }
129 { "void*" "addr-list" } ;
136 { "size_t" "addrlen" }
137 { "char*" "canonname" }
138 { "sockaddr*" "addr" }
139 { "addrinfo*" "next" } ;
145 : hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
150 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
152 FUNCTION: ushort htons ( ushort n ) ;
153 FUNCTION: ushort ntohs ( ushort n ) ;
154 FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
155 FUNCTION: int listen ( void* socket, int backlog ) ;
156 FUNCTION: char* inet_ntoa ( int in-addr ) ;
157 FUNCTION: int getaddrinfo ( char* nodename,
162 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
165 FUNCTION: hostent* gethostbyname ( char* name ) ;
166 FUNCTION: int gethostname ( char* name, int len ) ;
167 FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
168 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
169 FUNCTION: int closesocket ( SOCKET s ) ;
170 FUNCTION: int shutdown ( SOCKET s, int how ) ;
171 FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
172 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
174 FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
175 FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
177 TYPEDEF: uint SERVICETYPE
178 TYPEDEF: OVERLAPPED WSAOVERLAPPED
179 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
181 TYPEDEF: void* LPCONDITIONPROC
182 TYPEDEF: HANDLE WSAEVENT
183 TYPEDEF: LPHANDLE LPWSAEVENT
184 TYPEDEF: sockaddr* LPSOCKADDR
187 { "uint" "TokenRate" }
188 { "uint" "TokenBucketSize" }
189 { "uint" "PeakBandwidth" }
191 { "uint" "DelayVariation" }
192 { "SERVICETYPE" "ServiceType" }
193 { "uint" "MaxSduSize" }
194 { "uint" "MinimumPolicedSize" } ;
195 TYPEDEF: FLOWSPEC* PFLOWSPEC
196 TYPEDEF: FLOWSPEC* LPFLOWSPEC
201 TYPEDEF: WSABUF* LPWSABUF
204 { "FLOWSPEC" "SendingFlowspec" }
205 { "FLOWSPEC" "ReceivingFlowspec" }
206 { "WSABUF" "ProviderSpecific" } ;
209 : MAX_PROTOCOL_CHAIN 7 ; inline
211 C-STRUCT: WSAPROTOCOLCHAIN
213 ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
214 { { "DWORD" 7 } "ChainEntries" } ;
215 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
217 : WSAPROTOCOL_LEN 255 ; inline
219 C-STRUCT: WSAPROTOCOL_INFOW
220 { "DWORD" "dwServiceFlags1" }
221 { "DWORD" "dwServiceFlags2" }
222 { "DWORD" "dwServiceFlags3" }
223 { "DWORD" "dwServiceFlags4" }
224 { "DWORD" "dwProviderFlags" }
225 { "GUID" "ProviderId" }
226 { "DWORD" "dwCatalogEntryId" }
227 { "WSAPROTOCOLCHAIN" "ProtocolChain" }
229 { "int" "iAddressFamily" }
230 { "int" "iMaxSockAddr" }
231 { "int" "iMinSockAddr" }
232 { "int" "iSocketType" }
233 { "int" "iProtocol" }
234 { "int" "iProtocolMaxOffset" }
235 { "int" "iNetworkByteOrder" }
236 { "int" "iSecurityScheme" }
237 { "DWORD" "dwMessageSize" }
238 { "DWORD" "dwProviderReserved" }
239 { { "WCHAR" 256 } "szProtocol" } ;
240 ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ;
241 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
242 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
243 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
244 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
245 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
248 C-STRUCT: WSANAMESPACE_INFOW
249 { "GUID" "NSProviderId" }
250 { "DWORD" "dwNameSpace" }
252 { "DWORD" "dwVersion" }
253 { "LPWSTR" "lpszIdentifier" } ;
254 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
255 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
256 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
257 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
258 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
262 C-STRUCT: WSANETWORKEVENTS
263 { "long" "lNetworkEvents" }
264 ! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ;
265 { { "int" 10 } "iErrorCode" } ;
266 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
267 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
269 ! C-STRUCT: WSAOVERLAPPED
270 ! { "DWORD" "Internal" }
271 ! { "DWORD" "InternalHigh" }
272 ! { "DWORD" "Offset" }
273 ! { "DWORD" "OffsetHigh" }
274 ! { "WSAEVENT" "hEvent" }
275 ! { "DWORD" "bytesTransferred" } ;
276 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
278 FUNCTION: SOCKET WSAAccept ( SOCKET s,
281 LPCONDITIONPROC lpfnCondition,
282 DWORD dwCallbackData ) ;
284 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
286 FUNCTION: int WSACleanup ( ) ;
287 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
289 FUNCTION: int WSAConnect ( SOCKET s,
292 LPWSABUF lpCallerData,
293 LPWSABUF lpCalleeData,
296 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
297 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
298 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
299 WSAEVENT hEventObject,
300 LPWSANETWORKEVENTS lpNetworkEvents ) ;
301 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
303 FUNCTION: int WSAEventSelect ( SOCKET s,
304 WSAEVENT hEventObject,
305 long lNetworkEvents ) ;
306 FUNCTION: int WSAGetLastError ( ) ;
307 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
308 LPWSAOVERLAPPED lpOverlapped,
309 LPDWORD lpcbTransfer,
311 LPDWORD lpdwFlags ) ;
313 FUNCTION: int WSAIoctl ( SOCKET s,
314 DWORD dwIoControlCode,
319 LPDWORD lpcbBytesReturned,
321 void* lpCompletionRoutine ) ;
323 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
324 FUNCTION: int WSARecv ( SOCKET s,
327 LPDWORD lpNumberOfBytesRecvd,
329 LPWSAOVERLAPPED lpOverlapped,
330 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
332 FUNCTION: int WSARecvFrom ( SOCKET s,
335 LPDWORD lpNumberOfBytesRecvd,
339 LPWSAOVERLAPPED lpOverlapped,
340 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
342 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
343 FUNCTION: int WSASend ( SOCKET s,
346 LPDWORD lpNumberOfBytesSent,
348 LPWSAOVERLAPPED lpOverlapped,
349 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
351 FUNCTION: int WSASendTo ( SOCKET s,
354 LPDWORD lpNumberOfBytesSent,
358 LPWSAOVERLAPPED lpOverlapped,
359 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
362 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
366 FUNCTION: SOCKET WSASocketW ( int af,
369 LPWSAPROTOCOL_INFOW lpProtocolInfo,
372 ALIAS: WSASocket WSASocketW
374 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
386 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
387 FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
389 : SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 ; inline
391 : WSAID_CONNECTEX ( -- GUID )
393 HEX: 25a207b9 over set-GUID-Data1
394 HEX: ddf3 over set-GUID-Data2
395 HEX: 4660 over set-GUID-Data3
397 HEX: 8e HEX: e9 HEX: 76 HEX: e5
398 HEX: 8c HEX: 74 HEX: 06 HEX: 3e
399 } over set-GUID-Data4 ;
401 : winsock-expected-error? ( n -- ? )
402 ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
404 : (winsock-error-string) ( n -- str )
405 ! #! WSAStartup returns the error code 'n' directly
406 dup winsock-expected-error?
407 [ drop f ] [ error_message utf16n alien>string ] if ;
409 : winsock-error-string ( -- string/f )
410 WSAGetLastError (winsock-error-string) ;
412 : winsock-error ( -- )
413 winsock-error-string [ throw ] when* ;
415 : winsock-error=0/f ( n/f -- )
417 winsock-error-string throw
420 : winsock-error!=0/f ( n/f -- )
422 winsock-error-string throw
425 : winsock-return-check ( n/f -- )
426 dup { 0 f } member? [
429 (winsock-error-string) throw
432 : socket-error* ( n -- )
435 dup WSA_IO_PENDING = [
438 (winsock-error-string) throw
442 : socket-error ( n -- )
443 SOCKET_ERROR = [ winsock-error ] when ;
445 : init-winsock ( -- )
446 HEX: 0202 <wsadata> WSAStartup winsock-return-check ;