1 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data alien.strings
4 alien.syntax arrays byte-arrays classes.struct grouping init
5 io.encodings.utf16n kernel literals math math.bitwise
6 math.parser sequences system vocabs.parser windows.com.syntax
7 windows.errors windows.kernel32 windows.types ;
8 FROM: alien.c-types => short ;
12 ! Some differences between Win32 and Win64
13 cpu x86.64? "windows.winsock.64" "windows.winsock.32" ? use-vocab
18 : <wsadata> ( -- byte-array )
21 CONSTANT: SOCK_STREAM 1
22 CONSTANT: SOCK_DGRAM 2
25 CONSTANT: SOCK_SEQPACKET 5
27 CONSTANT: SO_DEBUG 0x1
28 CONSTANT: SO_ACCEPTCONN 0x2
29 CONSTANT: SO_REUSEADDR 0x4
30 CONSTANT: SO_KEEPALIVE 0x8
31 CONSTANT: SO_DONTROUTE 0x10
32 CONSTANT: SO_BROADCAST 0x20
33 CONSTANT: SO_USELOOPBACK 0x40
34 CONSTANT: SO_LINGER 0x80
35 CONSTANT: SO_OOBINLINE 0x100
36 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
38 CONSTANT: SO_SNDBUF 0x1001
39 CONSTANT: SO_RCVBUF 0x1002
40 CONSTANT: SO_SNDLOWAT 0x1003
41 CONSTANT: SO_RCVLOWAT 0x1004
42 CONSTANT: SO_SNDTIMEO 0x1005
43 CONSTANT: SO_RCVTIMEO 0x1006
44 CONSTANT: SO_ERROR 0x1007
45 CONSTANT: SO_TYPE 0x1008
47 CONSTANT: TCP_NODELAY 0x1
52 CONSTANT: AF_IMPLINK 3
59 CONSTANT: AF_DATAKIT 9
62 CONSTANT: AF_DECnet 12
65 CONSTANT: AF_HYLINK 15
66 CONSTANT: AF_APPLETALK 16
67 CONSTANT: AF_NETBIOS 17
78 CONSTANT: AI_PASSIVE 1
79 CONSTANT: AI_CANONNAME 2
80 CONSTANT: AI_NUMERICHOST 4
82 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
84 CONSTANT: NI_NUMERICHOST 1
85 CONSTANT: NI_NUMERICSERV 2
87 CONSTANT: IPPROTO_TCP 6
88 CONSTANT: IPPROTO_UDP 17
89 CONSTANT: IPPROTO_RM 113
91 CONSTANT: FIOASYNC 0x8004667d
92 CONSTANT: FIONBIO 0x8004667e
93 CONSTANT: FIONREAD 0x4004667f
95 CONSTANT: WSA_FLAG_OVERLAPPED 1
96 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
97 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
98 CONSTANT: WSA_INVALID_EVENT f
99 CONSTANT: WSA_WAIT_FAILED -1
100 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
101 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
102 ALIAS: WSA_INFINITE INFINITE
103 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
105 CONSTANT: INADDR_ANY 0
107 : INVALID_SOCKET ( -- n ) -1 <alien> ; inline
109 : SOCKET_ERROR ( -- n ) -1 ; inline
115 CONSTANT: SOL_SOCKET 0xffff
137 { addr-list void* } ;
150 { canonname c-string }
158 GENERIC: sockaddr>ip ( sockaddr -- string )
160 M: sockaddr-in sockaddr>ip ( sockaddr -- string )
161 addr>> uint <ref> [ number>string ] { } map-as "." join ;
163 M: sockaddr-in6 sockaddr>ip ( uchar-array -- string )
164 addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
168 { fd_array SOCKET[64] } ;
172 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen ) ;
173 FUNCTION: int ioctlsocket ( SOCKET s, long cmd, ulong* *argp ) ;
175 FUNCTION: ushort htons ( ushort n ) ;
176 FUNCTION: ushort ntohs ( ushort n ) ;
177 FUNCTION: int bind ( SOCKET socket, sockaddr-in* sockaddr, int len ) ;
178 FUNCTION: int listen ( SOCKET socket, int backlog ) ;
179 FUNCTION: c-string inet_ntoa ( int in-addr ) ;
180 FUNCTION: int getaddrinfo ( c-string nodename,
185 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
188 FUNCTION: hostent* gethostbyname ( c-string name ) ;
189 FUNCTION: int gethostname ( c-string name, int len ) ;
190 FUNCTION: SOCKET socket ( int domain, int type, int protocol ) ;
191 FUNCTION: int connect ( SOCKET socket, sockaddr-in* sockaddr, int addrlen ) ;
192 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
193 FUNCTION: int closesocket ( SOCKET s ) ;
194 FUNCTION: int shutdown ( SOCKET s, int how ) ;
195 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags ) ;
196 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags ) ;
198 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
199 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
201 FUNCTION: protoent* getprotobyname ( c-string name ) ;
203 FUNCTION: servent* getservbyname ( c-string name, c-string prot ) ;
204 FUNCTION: servent* getservbyport ( int port, c-string prot ) ;
206 TYPEDEF: uint SERVICETYPE
207 TYPEDEF: void* LPWSADATA
208 TYPEDEF: OVERLAPPED WSAOVERLAPPED
209 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
211 TYPEDEF: void* LPCONDITIONPROC
212 TYPEDEF: HANDLE WSAEVENT
213 TYPEDEF: LPHANDLE LPWSAEVENT
214 TYPEDEF: sockaddr* LPSOCKADDR
218 { TokenBucketSize uint }
219 { PeakBandwidth uint }
221 { DelayVariation uint }
222 { ServiceType SERVICETYPE }
224 { MinimumPolicedSize uint } ;
225 TYPEDEF: FLOWSPEC* PFLOWSPEC
226 TYPEDEF: FLOWSPEC* LPFLOWSPEC
231 TYPEDEF: WSABUF* LPWSABUF
234 { SendingFlowspec FLOWSPEC }
235 { ReceivingFlowspec FLOWSPEC }
236 { ProviderSpecific WSABUF } ;
239 CONSTANT: MAX_PROTOCOL_CHAIN 7
241 STRUCT: WSAPROTOCOLCHAIN
243 { ChainEntries { DWORD 7 } } ;
244 ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
245 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
247 CONSTANT: WSAPROTOCOL_LEN 255
249 STRUCT: WSAPROTOCOL_INFOW
250 { dwServiceFlags1 DWORD }
251 { dwServiceFlags2 DWORD }
252 { dwServiceFlags3 DWORD }
253 { dwServiceFlags4 DWORD }
254 { dwProviderFlags DWORD }
256 { dwCatalogEntryId DWORD }
257 { ProtocolChain WSAPROTOCOLCHAIN }
259 { iAddressFamily int }
264 { iProtocolMaxOffset int }
265 { iNetworkByteOrder int }
266 { iSecurityScheme int }
267 { dwMessageSize DWORD }
268 { dwProviderReserved DWORD }
269 { szProtocol { WCHAR 256 } } ;
270 ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
271 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
272 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
273 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
274 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
275 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
278 STRUCT: WSANAMESPACE_INFOW
279 { NSProviderId GUID }
280 { dwNameSpace DWORD }
283 { lpszIdentifier LPWSTR } ;
284 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
285 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
286 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
287 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
288 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
290 CONSTANT: FD_MAX_EVENTS 10
292 STRUCT: WSANETWORKEVENTS
293 { lNetworkEvents long }
294 { iErrorCode { int FD_MAX_EVENTS } } ;
295 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
296 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
298 ! STRUCT: WSAOVERLAPPED
300 ! { InternalHigh DWORD }
302 ! { OffsetHigh DWORD }
303 ! { hEvent WSAEVENT }
304 ! { bytesTransferred DWORD } ;
305 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
307 FUNCTION: SOCKET WSAAccept ( SOCKET s,
310 LPCONDITIONPROC lpfnCondition,
311 DWORD dwCallbackData ) ;
313 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
315 FUNCTION: int WSACleanup ( ) ;
316 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
318 FUNCTION: int WSAConnect ( SOCKET s,
321 LPWSABUF lpCallerData,
322 LPWSABUF lpCalleeData,
325 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
326 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
327 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
328 WSAEVENT hEventObject,
329 LPWSANETWORKEVENTS lpNetworkEvents ) ;
330 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
332 FUNCTION: int WSAEventSelect ( SOCKET s,
333 WSAEVENT hEventObject,
334 long lNetworkEvents ) ;
335 FUNCTION: int WSAGetLastError ( ) ;
336 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
337 LPWSAOVERLAPPED lpOverlapped,
338 LPDWORD lpcbTransfer,
340 LPDWORD lpdwFlags ) ;
342 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
343 FUNCTION: int WSAIoctl ( SOCKET s,
344 DWORD dwIoControlCode,
349 LPDWORD lpcbBytesReturned,
350 LPWSAOVERLAPPED lpOverlapped,
351 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
353 FUNCTION: int WSARecv ( SOCKET s,
356 LPDWORD lpNumberOfBytesRecvd,
358 LPWSAOVERLAPPED lpOverlapped,
359 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
361 FUNCTION: int WSARecvFrom ( SOCKET s,
364 LPDWORD lpNumberOfBytesRecvd,
368 LPWSAOVERLAPPED lpOverlapped,
369 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
371 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
372 FUNCTION: int WSASend ( SOCKET s,
375 LPDWORD lpNumberOfBytesSent,
377 LPWSAOVERLAPPED lpOverlapped,
378 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
380 FUNCTION: int WSASendTo ( SOCKET s,
383 LPDWORD lpNumberOfBytesSent,
387 LPWSAOVERLAPPED lpOverlapped,
388 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
390 FUNCTION: int WSAStartup ( WORD version, LPWSADATA out-data ) ;
392 FUNCTION: SOCKET WSASocketW ( int af,
395 LPWSAPROTOCOL_INFOW lpProtocolInfo,
398 ALIAS: WSASocket WSASocketW
400 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
409 FUNCTION: int AcceptEx ( SOCKET listen,
416 LPOVERLAPPED overlapped ) ;
418 FUNCTION: void GetAcceptExSockaddrs (
419 PVOID lpOutputBuffer,
420 DWORD dwReceiveDataLength,
421 DWORD dwLocalAddressLength,
422 DWORD dwRemoteAddressLength,
423 LPSOCKADDR* LocalSockaddr,
424 LPINT LocalSockaddrLength,
425 LPSOCKADDR* RemoteSockaddr,
426 LPINT RemoteSockaddrLength
429 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
431 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
433 ERROR: winsock-exception n string ;
435 : winsock-expected-error? ( n -- ? )
436 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
438 : (maybe-winsock-exception) ( n -- winsock-exception/f )
439 ! #! WSAStartup returns the error code 'n' directly
440 dup winsock-expected-error?
441 [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
443 : maybe-winsock-exception ( -- winsock-exception/f )
444 WSAGetLastError (maybe-winsock-exception) ;
446 : winsock-error ( -- )
447 maybe-winsock-exception [ throw ] when* ;
449 : (throw-winsock-error) ( n -- * )
450 [ ] [ n>win32-error-string ] bi winsock-exception ;
452 : throw-winsock-error ( -- * )
453 WSAGetLastError (throw-winsock-error) ;
455 : winsock-error=0/f ( n/f -- )
456 { 0 f } member? [ throw-winsock-error ] when ;
458 : winsock-error!=0/f ( n/f -- )
459 { 0 f } member? [ throw-winsock-error ] unless ;
461 ! WSAStartup and WSACleanup return the error code directly
462 : winsock-return-check ( n/f -- )
463 dup { 0 f } member? [
466 [ ] [ n>win32-error-string ] bi winsock-exception
469 : socket-error* ( n -- )
472 dup WSA_IO_PENDING = [
475 (maybe-winsock-exception) throw
479 : socket-error ( n -- )
480 SOCKET_ERROR = [ winsock-error ] when ;
482 : init-winsock ( -- )
483 0x0202 <wsadata> WSAStartup winsock-return-check ;
485 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
487 [ init-winsock ] "windows.winsock" add-startup-hook
488 [ shutdown-winsock ] "windows.winsock" add-shutdown-hook