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 io.encodings.utf16n
10 : alien>byte-array ( alien str -- byte-array )
11 heap-size dup <byte-array> [ -rot memcpy ] keep ;
15 : <wsadata> ( -- byte-array )
16 HEX: 190 <byte-array> ;
18 CONSTANT: SOCK_STREAM 1
19 CONSTANT: SOCK_DGRAM 2
22 CONSTANT: SOCK_SEQPACKET 5
24 CONSTANT: SO_DEBUG HEX: 1
25 CONSTANT: SO_ACCEPTCONN HEX: 2
26 CONSTANT: SO_REUSEADDR HEX: 4
27 CONSTANT: SO_KEEPALIVE HEX: 8
28 CONSTANT: SO_DONTROUTE HEX: 10
29 CONSTANT: SO_BROADCAST HEX: 20
30 CONSTANT: SO_USELOOPBACK HEX: 40
31 CONSTANT: SO_LINGER HEX: 80
32 CONSTANT: SO_OOBINLINE HEX: 100
33 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
35 CONSTANT: SO_SNDBUF HEX: 1001
36 CONSTANT: SO_RCVBUF HEX: 1002
37 CONSTANT: SO_SNDLOWAT HEX: 1003
38 CONSTANT: SO_RCVLOWAT HEX: 1004
39 CONSTANT: SO_SNDTIMEO HEX: 1005
40 CONSTANT: SO_RCVTIMEO HEX: 1006
41 CONSTANT: SO_ERROR HEX: 1007
42 CONSTANT: SO_TYPE HEX: 1008
44 CONSTANT: TCP_NODELAY HEX: 1
49 CONSTANT: AF_IMPLINK 3
56 CONSTANT: AF_DATAKIT 9
59 CONSTANT: AF_DECnet 12
62 CONSTANT: AF_HYLINK 15
63 CONSTANT: AF_APPLETALK 16
64 CONSTANT: AF_NETBIOS 17
75 CONSTANT: AI_PASSIVE 1
76 CONSTANT: AI_CANONNAME 2
77 CONSTANT: AI_NUMERICHOST 4
78 : AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
80 CONSTANT: NI_NUMERICHOST 1
81 CONSTANT: NI_NUMERICSERV 2
83 CONSTANT: IPPROTO_TCP 6
84 CONSTANT: IPPROTO_UDP 17
85 CONSTANT: IPPROTO_RM 113
87 CONSTANT: WSA_FLAG_OVERLAPPED 1
88 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
89 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
90 CONSTANT: WSA_INVALID_EVENT f
91 CONSTANT: WSA_WAIT_FAILED -1
92 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
93 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
94 ALIAS: WSA_INFINITE INFINITE
95 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
97 CONSTANT: INADDR_ANY 0
99 : INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
100 CONSTANT: SOCKET_ERROR -1
106 CONSTANT: SOL_SOCKET HEX: ffff
108 ! TYPEDEF: uint in_addr_t
110 ! { "in_addr_t" "s_addr" } ;
112 C-STRUCT: sockaddr-in
116 { { "char" 8 } "pad" } ;
118 C-STRUCT: sockaddr-in6
121 { "uint" "flowinfo" }
122 { { "uchar" 16 } "addr" }
123 { "uint" "scopeid" } ;
127 { "void*" "aliases" }
128 { "short" "addrtype" }
130 { "void*" "addr-list" } ;
137 { "size_t" "addrlen" }
138 { "char*" "canonname" }
139 { "sockaddr*" "addr" }
140 { "addrinfo*" "next" } ;
146 : hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
151 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
153 FUNCTION: ushort htons ( ushort n ) ;
154 FUNCTION: ushort ntohs ( ushort n ) ;
155 FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
156 FUNCTION: int listen ( void* socket, int backlog ) ;
157 FUNCTION: char* inet_ntoa ( int in-addr ) ;
158 FUNCTION: int getaddrinfo ( char* nodename,
163 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
166 FUNCTION: hostent* gethostbyname ( char* name ) ;
167 FUNCTION: int gethostname ( char* name, int len ) ;
168 FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
169 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
170 FUNCTION: int closesocket ( SOCKET s ) ;
171 FUNCTION: int shutdown ( SOCKET s, int how ) ;
172 FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
173 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
175 FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
176 FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
178 TYPEDEF: uint SERVICETYPE
179 TYPEDEF: OVERLAPPED WSAOVERLAPPED
180 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
182 TYPEDEF: void* LPCONDITIONPROC
183 TYPEDEF: HANDLE WSAEVENT
184 TYPEDEF: LPHANDLE LPWSAEVENT
185 TYPEDEF: sockaddr* LPSOCKADDR
188 { "uint" "TokenRate" }
189 { "uint" "TokenBucketSize" }
190 { "uint" "PeakBandwidth" }
192 { "uint" "DelayVariation" }
193 { "SERVICETYPE" "ServiceType" }
194 { "uint" "MaxSduSize" }
195 { "uint" "MinimumPolicedSize" } ;
196 TYPEDEF: FLOWSPEC* PFLOWSPEC
197 TYPEDEF: FLOWSPEC* LPFLOWSPEC
202 TYPEDEF: WSABUF* LPWSABUF
205 { "FLOWSPEC" "SendingFlowspec" }
206 { "FLOWSPEC" "ReceivingFlowspec" }
207 { "WSABUF" "ProviderSpecific" } ;
210 CONSTANT: MAX_PROTOCOL_CHAIN 7
212 C-STRUCT: WSAPROTOCOLCHAIN
214 ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
215 { { "DWORD" 7 } "ChainEntries" } ;
216 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
218 CONSTANT: WSAPROTOCOL_LEN 255
220 C-STRUCT: WSAPROTOCOL_INFOW
221 { "DWORD" "dwServiceFlags1" }
222 { "DWORD" "dwServiceFlags2" }
223 { "DWORD" "dwServiceFlags3" }
224 { "DWORD" "dwServiceFlags4" }
225 { "DWORD" "dwProviderFlags" }
226 { "GUID" "ProviderId" }
227 { "DWORD" "dwCatalogEntryId" }
228 { "WSAPROTOCOLCHAIN" "ProtocolChain" }
230 { "int" "iAddressFamily" }
231 { "int" "iMaxSockAddr" }
232 { "int" "iMinSockAddr" }
233 { "int" "iSocketType" }
234 { "int" "iProtocol" }
235 { "int" "iProtocolMaxOffset" }
236 { "int" "iNetworkByteOrder" }
237 { "int" "iSecurityScheme" }
238 { "DWORD" "dwMessageSize" }
239 { "DWORD" "dwProviderReserved" }
240 { { "WCHAR" 256 } "szProtocol" } ;
241 ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ;
242 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
243 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
244 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
245 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
246 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
249 C-STRUCT: WSANAMESPACE_INFOW
250 { "GUID" "NSProviderId" }
251 { "DWORD" "dwNameSpace" }
253 { "DWORD" "dwVersion" }
254 { "LPWSTR" "lpszIdentifier" } ;
255 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
256 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
257 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
258 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
259 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
263 C-STRUCT: WSANETWORKEVENTS
264 { "long" "lNetworkEvents" }
265 ! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ;
266 { { "int" 10 } "iErrorCode" } ;
267 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
268 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
270 ! C-STRUCT: WSAOVERLAPPED
271 ! { "DWORD" "Internal" }
272 ! { "DWORD" "InternalHigh" }
273 ! { "DWORD" "Offset" }
274 ! { "DWORD" "OffsetHigh" }
275 ! { "WSAEVENT" "hEvent" }
276 ! { "DWORD" "bytesTransferred" } ;
277 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
279 FUNCTION: SOCKET WSAAccept ( SOCKET s,
282 LPCONDITIONPROC lpfnCondition,
283 DWORD dwCallbackData ) ;
285 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
287 FUNCTION: int WSACleanup ( ) ;
288 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
290 FUNCTION: int WSAConnect ( SOCKET s,
293 LPWSABUF lpCallerData,
294 LPWSABUF lpCalleeData,
297 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
298 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
299 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
300 WSAEVENT hEventObject,
301 LPWSANETWORKEVENTS lpNetworkEvents ) ;
302 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
304 FUNCTION: int WSAEventSelect ( SOCKET s,
305 WSAEVENT hEventObject,
306 long lNetworkEvents ) ;
307 FUNCTION: int WSAGetLastError ( ) ;
308 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
309 LPWSAOVERLAPPED lpOverlapped,
310 LPDWORD lpcbTransfer,
312 LPDWORD lpdwFlags ) ;
314 FUNCTION: int WSAIoctl ( SOCKET s,
315 DWORD dwIoControlCode,
320 LPDWORD lpcbBytesReturned,
322 void* lpCompletionRoutine ) ;
324 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
325 FUNCTION: int WSARecv ( SOCKET s,
328 LPDWORD lpNumberOfBytesRecvd,
330 LPWSAOVERLAPPED lpOverlapped,
331 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
333 FUNCTION: int WSARecvFrom ( SOCKET s,
336 LPDWORD lpNumberOfBytesRecvd,
340 LPWSAOVERLAPPED lpOverlapped,
341 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
343 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
344 FUNCTION: int WSASend ( SOCKET s,
347 LPDWORD lpNumberOfBytesSent,
349 LPWSAOVERLAPPED lpOverlapped,
350 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
352 FUNCTION: int WSASendTo ( SOCKET s,
355 LPDWORD lpNumberOfBytesSent,
359 LPWSAOVERLAPPED lpOverlapped,
360 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
363 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
367 FUNCTION: SOCKET WSASocketW ( int af,
370 LPWSAPROTOCOL_INFOW lpProtocolInfo,
373 ALIAS: WSASocket WSASocketW
375 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
387 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
388 FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
390 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
392 : WSAID_CONNECTEX ( -- GUID )
394 HEX: 25a207b9 over set-GUID-Data1
395 HEX: ddf3 over set-GUID-Data2
396 HEX: 4660 over set-GUID-Data3
398 HEX: 8e HEX: e9 HEX: 76 HEX: e5
399 HEX: 8c HEX: 74 HEX: 06 HEX: 3e
400 } over set-GUID-Data4 ;
402 : winsock-expected-error? ( n -- ? )
403 ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
405 : (winsock-error-string) ( n -- str )
406 ! #! WSAStartup returns the error code 'n' directly
407 dup winsock-expected-error?
408 [ drop f ] [ error_message utf16n alien>string ] if ;
410 : winsock-error-string ( -- string/f )
411 WSAGetLastError (winsock-error-string) ;
413 : winsock-error ( -- )
414 winsock-error-string [ throw ] when* ;
416 : winsock-error=0/f ( n/f -- )
418 winsock-error-string throw
421 : winsock-error!=0/f ( n/f -- )
423 winsock-error-string throw
426 : winsock-return-check ( n/f -- )
427 dup { 0 f } member? [
430 (winsock-error-string) throw
433 : socket-error* ( n -- )
436 dup WSA_IO_PENDING = [
439 (winsock-error-string) throw
443 : socket-error ( n -- )
444 SOCKET_ERROR = [ winsock-error ] when ;
446 : init-winsock ( -- )
447 HEX: 0202 <wsadata> WSAStartup winsock-return-check ;