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 math.bitwise io.encodings.utf16n ;
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 CONSTANT: SOCK_STREAM 1
18 CONSTANT: SOCK_DGRAM 2
21 CONSTANT: SOCK_SEQPACKET 5
23 CONSTANT: SO_DEBUG HEX: 1
24 CONSTANT: SO_ACCEPTCONN HEX: 2
25 CONSTANT: SO_REUSEADDR HEX: 4
26 CONSTANT: SO_KEEPALIVE HEX: 8
27 CONSTANT: SO_DONTROUTE HEX: 10
28 CONSTANT: SO_BROADCAST HEX: 20
29 CONSTANT: SO_USELOOPBACK HEX: 40
30 CONSTANT: SO_LINGER HEX: 80
31 CONSTANT: SO_OOBINLINE HEX: 100
32 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
34 CONSTANT: SO_SNDBUF HEX: 1001
35 CONSTANT: SO_RCVBUF HEX: 1002
36 CONSTANT: SO_SNDLOWAT HEX: 1003
37 CONSTANT: SO_RCVLOWAT HEX: 1004
38 CONSTANT: SO_SNDTIMEO HEX: 1005
39 CONSTANT: SO_RCVTIMEO HEX: 1006
40 CONSTANT: SO_ERROR HEX: 1007
41 CONSTANT: SO_TYPE HEX: 1008
43 CONSTANT: TCP_NODELAY HEX: 1
48 CONSTANT: AF_IMPLINK 3
55 CONSTANT: AF_DATAKIT 9
58 CONSTANT: AF_DECnet 12
61 CONSTANT: AF_HYLINK 15
62 CONSTANT: AF_APPLETALK 16
63 CONSTANT: AF_NETBIOS 17
74 CONSTANT: AI_PASSIVE 1
75 CONSTANT: AI_CANONNAME 2
76 CONSTANT: AI_NUMERICHOST 4
77 : AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
79 CONSTANT: NI_NUMERICHOST 1
80 CONSTANT: NI_NUMERICSERV 2
82 CONSTANT: IPPROTO_TCP 6
83 CONSTANT: IPPROTO_UDP 17
84 CONSTANT: IPPROTO_RM 113
86 CONSTANT: WSA_FLAG_OVERLAPPED 1
87 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
88 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
89 CONSTANT: WSA_INVALID_EVENT f
90 CONSTANT: WSA_WAIT_FAILED -1
91 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
92 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
93 ALIAS: WSA_INFINITE INFINITE
94 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
96 CONSTANT: INADDR_ANY 0
98 : INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
99 CONSTANT: SOCKET_ERROR -1
105 CONSTANT: SOL_SOCKET HEX: ffff
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 CONSTANT: MAX_PROTOCOL_CHAIN 7
211 C-STRUCT: WSAPROTOCOLCHAIN
213 ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
214 { { "DWORD" 7 } "ChainEntries" } ;
215 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
217 CONSTANT: WSAPROTOCOL_LEN 255
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
260 CONSTANT: FD_MAX_EVENTS 10
262 C-STRUCT: WSANETWORKEVENTS
263 { "long" "lNetworkEvents" }
264 { { "int" FD_MAX_EVENTS } "iErrorCode" } ;
265 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
266 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
268 ! C-STRUCT: WSAOVERLAPPED
269 ! { "DWORD" "Internal" }
270 ! { "DWORD" "InternalHigh" }
271 ! { "DWORD" "Offset" }
272 ! { "DWORD" "OffsetHigh" }
273 ! { "WSAEVENT" "hEvent" }
274 ! { "DWORD" "bytesTransferred" } ;
275 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
277 FUNCTION: SOCKET WSAAccept ( SOCKET s,
280 LPCONDITIONPROC lpfnCondition,
281 DWORD dwCallbackData ) ;
283 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
285 FUNCTION: int WSACleanup ( ) ;
286 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
288 FUNCTION: int WSAConnect ( SOCKET s,
291 LPWSABUF lpCallerData,
292 LPWSABUF lpCalleeData,
295 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
296 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
297 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
298 WSAEVENT hEventObject,
299 LPWSANETWORKEVENTS lpNetworkEvents ) ;
300 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
302 FUNCTION: int WSAEventSelect ( SOCKET s,
303 WSAEVENT hEventObject,
304 long lNetworkEvents ) ;
305 FUNCTION: int WSAGetLastError ( ) ;
306 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
307 LPWSAOVERLAPPED lpOverlapped,
308 LPDWORD lpcbTransfer,
310 LPDWORD lpdwFlags ) ;
312 FUNCTION: int WSAIoctl ( SOCKET s,
313 DWORD dwIoControlCode,
318 LPDWORD lpcbBytesReturned,
320 void* lpCompletionRoutine ) ;
322 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
323 FUNCTION: int WSARecv ( SOCKET s,
326 LPDWORD lpNumberOfBytesRecvd,
328 LPWSAOVERLAPPED lpOverlapped,
329 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
331 FUNCTION: int WSARecvFrom ( SOCKET s,
334 LPDWORD lpNumberOfBytesRecvd,
338 LPWSAOVERLAPPED lpOverlapped,
339 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
341 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
342 FUNCTION: int WSASend ( SOCKET s,
345 LPDWORD lpNumberOfBytesSent,
347 LPWSAOVERLAPPED lpOverlapped,
348 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
350 FUNCTION: int WSASendTo ( SOCKET s,
353 LPDWORD lpNumberOfBytesSent,
357 LPWSAOVERLAPPED lpOverlapped,
358 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
361 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
365 FUNCTION: SOCKET WSASocketW ( int af,
368 LPWSAPROTOCOL_INFOW lpProtocolInfo,
371 ALIAS: WSASocket WSASocketW
373 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
385 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
386 FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
388 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
390 : WSAID_CONNECTEX ( -- GUID )
392 HEX: 25a207b9 over set-GUID-Data1
393 HEX: ddf3 over set-GUID-Data2
394 HEX: 4660 over set-GUID-Data3
396 HEX: 8e HEX: e9 HEX: 76 HEX: e5
397 HEX: 8c HEX: 74 HEX: 06 HEX: 3e
398 } over set-GUID-Data4 ;
400 : winsock-expected-error? ( n -- ? )
401 ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
403 : (winsock-error-string) ( n -- str )
404 ! #! WSAStartup returns the error code 'n' directly
405 dup winsock-expected-error?
406 [ drop f ] [ n>win32-error-string ] if ;
408 : winsock-error-string ( -- string/f )
409 WSAGetLastError (winsock-error-string) ;
411 : winsock-error ( -- )
412 winsock-error-string [ throw ] when* ;
414 : winsock-error=0/f ( n/f -- )
416 winsock-error-string throw
419 : winsock-error!=0/f ( n/f -- )
421 winsock-error-string throw
424 : winsock-return-check ( n/f -- )
425 dup { 0 f } member? [
428 (winsock-error-string) throw
431 : socket-error* ( n -- )
434 dup WSA_IO_PENDING = [
437 (winsock-error-string) throw
441 : socket-error ( n -- )
442 SOCKET_ERROR = [ winsock-error ] when ;
444 : init-winsock ( -- )
445 HEX: 0202 <wsadata> WSAStartup winsock-return-check ;