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.syntax
4 byte-arrays classes.struct grouping init kernel literals math
5 math.parser sequences system vocabs.parser windows.com.syntax
6 windows.errors windows.kernel32 windows.types ;
7 FROM: alien.c-types => short ;
11 ! Some differences between Win32 and Win64
12 cpu x86.64? "windows.winsock.64" "windows.winsock.32" ? use-vocab
17 : <wsadata> ( -- byte-array )
20 CONSTANT: SOCK_STREAM 1
21 CONSTANT: SOCK_DGRAM 2
24 CONSTANT: SOCK_SEQPACKET 5
26 CONSTANT: SO_DEBUG 0x1
27 CONSTANT: SO_ACCEPTCONN 0x2
28 CONSTANT: SO_REUSEADDR 0x4
29 CONSTANT: SO_KEEPALIVE 0x8
30 CONSTANT: SO_DONTROUTE 0x10
31 CONSTANT: SO_BROADCAST 0x20
32 CONSTANT: SO_USELOOPBACK 0x40
33 CONSTANT: SO_LINGER 0x80
34 CONSTANT: SO_OOBINLINE 0x100
35 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
37 CONSTANT: SO_SNDBUF 0x1001
38 CONSTANT: SO_RCVBUF 0x1002
39 CONSTANT: SO_SNDLOWAT 0x1003
40 CONSTANT: SO_RCVLOWAT 0x1004
41 CONSTANT: SO_SNDTIMEO 0x1005
42 CONSTANT: SO_RCVTIMEO 0x1006
43 CONSTANT: SO_ERROR 0x1007
44 CONSTANT: SO_TYPE 0x1008
46 CONSTANT: TCP_NODELAY 0x1
51 CONSTANT: AF_IMPLINK 3
58 CONSTANT: AF_DATAKIT 9
61 CONSTANT: AF_DECnet 12
64 CONSTANT: AF_HYLINK 15
65 CONSTANT: AF_APPLETALK 16
66 CONSTANT: AF_NETBIOS 17
77 CONSTANT: AI_PASSIVE 0x0001
78 CONSTANT: AI_CANONNAME 0x0002
79 CONSTANT: AI_NUMERICHOST 0x0004
80 CONSTANT: AI_ALL 0x0100
81 CONSTANT: AI_ADDRCONFIG 0x0400
83 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
85 CONSTANT: NI_NUMERICHOST 1
86 CONSTANT: NI_NUMERICSERV 2
88 CONSTANT: IPPROTO_IP 0 ! Dummy protocol for TCP.
89 CONSTANT: IPPROTO_ICMP 1 ! Internet Control Message Protocol.
90 CONSTANT: IPPROTO_IGMP 2 ! Internet Group Management Protocol. */
91 CONSTANT: IPPROTO_IPIP 4 ! IPIP tunnels (older KA9Q tunnels use 94).
92 CONSTANT: IPPROTO_TCP 6 ! Transmission Control Protocol.
93 CONSTANT: IPPROTO_EGP 8 ! Exterior Gateway Protocol.
94 CONSTANT: IPPROTO_PUP 12 ! PUP protocol.
95 CONSTANT: IPPROTO_UDP 17 ! User Datagram Protocol.
96 CONSTANT: IPPROTO_IDP 22 ! XNS IDP protocol.
97 CONSTANT: IPPROTO_TP 29 ! SO Transport Protocol Class 4.
98 CONSTANT: IPPROTO_DCCP 33 ! Datagram Congestion Control Protocol.
99 CONSTANT: IPPROTO_IPV6 41 ! IPv6 header.
100 CONSTANT: IPPROTO_RSVP 46 ! Reservation Protocol.
101 CONSTANT: IPPROTO_GRE 47 ! General Routing Encapsulation.
102 CONSTANT: IPPROTO_ESP 50 ! encapsulating security payload.
103 CONSTANT: IPPROTO_AH 51 ! authentication header.
104 CONSTANT: IPPROTO_MTP 92 ! Multicast Transport Protocol.
105 CONSTANT: IPPROTO_BEETPH 94 ! IP option pseudo header for BEET.
106 CONSTANT: IPPROTO_ENCAP 98 ! Encapsulation Header.
107 CONSTANT: IPPROTO_PIM 103 ! Protocol Independent Multicast.
108 CONSTANT: IPPROTO_COMP 108 ! Compression Header Protocol.
109 CONSTANT: IPPROTO_RM 113 ! Reliable Multicast aka PGM
110 CONSTANT: IPPROTO_SCTP 132 ! Stream Control Transmission Protocol.
111 CONSTANT: IPPROTO_UDPLITE 136 ! UDP-Lite protocol.
112 CONSTANT: IPPROTO_MPLS 137 ! MPLS in IP.
113 CONSTANT: IPPROTO_RAW 255 ! Raw IP packets.
115 CONSTANT: FIOASYNC 0x8004667d
116 CONSTANT: FIONBIO 0x8004667e
117 CONSTANT: FIONREAD 0x4004667f
119 CONSTANT: IP_OPTIONS 1
120 CONSTANT: IP_HDRINCL 2
123 CONSTANT: IP_MULTICAST_IF 9
124 CONSTANT: IP_MULTICAST_TTL 10
125 CONSTANT: IP_MULTICAST_LOOP 11
126 CONSTANT: IP_ADD_MEMBERSHIP 12
127 CONSTANT: IP_DROP_MEMBERSHIP 13
128 CONSTANT: IP_DONTFRAGMENT 14
129 CONSTANT: IP_ADD_SOURCE_MEMBERSHIP 15
130 CONSTANT: IP_DROP_SOURCE_MEMBERSHIP 16
131 CONSTANT: IP_BLOCK_SOURCE 17
132 CONSTANT: IP_UNBLOCK_SOURCE 18
133 CONSTANT: IP_PKTINFO 19
134 CONSTANT: IP_RECEIVE_BROADCAST 22
137 CONSTANT: WSA_FLAG_OVERLAPPED 1
138 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
139 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
140 CONSTANT: WSA_INVALID_EVENT f
141 CONSTANT: WSA_WAIT_FAILED -1
142 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
143 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
144 ALIAS: WSA_INFINITE INFINITE
145 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
147 CONSTANT: INADDR_ANY 0
149 : INVALID_SOCKET ( -- n ) -1 <alien> ; inline
151 : SOCKET_ERROR ( -- n ) -1 ; inline
157 CONSTANT: SOL_SOCKET 0xffff
179 { addr-list void* } ;
192 { canonname c-string }
200 GENERIC: sockaddr>ip ( sockaddr -- string )
202 M: sockaddr-in sockaddr>ip
203 addr>> uint <ref> [ number>string ] { } map-as "." join ;
205 M: sockaddr-in6 sockaddr>ip
206 addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
210 { fd_array SOCKET[64] } ;
214 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen )
215 FUNCTION: int ioctlsocket ( SOCKET s, long cmd, ulong* *argp )
217 FUNCTION: ushort htons ( ushort n )
218 FUNCTION: ushort ntohs ( ushort n )
219 FUNCTION: int bind ( SOCKET socket, sockaddr-in* sockaddr, int len )
220 FUNCTION: int listen ( SOCKET socket, int backlog )
221 FUNCTION: c-string inet_ntoa ( int in-addr )
222 FUNCTION: int getaddrinfo ( c-string nodename,
227 FUNCTION: void freeaddrinfo ( addrinfo* ai )
230 FUNCTION: hostent* gethostbyname ( c-string name )
231 FUNCTION: int gethostname ( c-string name, int len )
232 FUNCTION: SOCKET socket ( int domain, int type, int protocol )
233 FUNCTION: int connect ( SOCKET socket, sockaddr-in* sockaddr, int addrlen )
234 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout )
235 FUNCTION: int closesocket ( SOCKET s )
236 FUNCTION: int shutdown ( SOCKET s, int how )
237 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags )
238 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags )
240 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen )
241 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen )
243 FUNCTION: protoent* getprotobyname ( c-string name )
245 FUNCTION: servent* getservbyname ( c-string name, c-string prot )
246 FUNCTION: servent* getservbyport ( int port, c-string prot )
248 TYPEDEF: uint SERVICETYPE
249 TYPEDEF: void* LPWSADATA
250 TYPEDEF: OVERLAPPED WSAOVERLAPPED
251 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
253 TYPEDEF: void* LPCONDITIONPROC
254 TYPEDEF: HANDLE WSAEVENT
255 TYPEDEF: LPHANDLE LPWSAEVENT
256 TYPEDEF: sockaddr* LPSOCKADDR
260 { TokenBucketSize uint }
261 { PeakBandwidth uint }
263 { DelayVariation uint }
264 { ServiceType SERVICETYPE }
266 { MinimumPolicedSize uint } ;
267 TYPEDEF: FLOWSPEC* PFLOWSPEC
268 TYPEDEF: FLOWSPEC* LPFLOWSPEC
273 TYPEDEF: WSABUF* LPWSABUF
276 { SendingFlowspec FLOWSPEC }
277 { ReceivingFlowspec FLOWSPEC }
278 { ProviderSpecific WSABUF } ;
281 CONSTANT: MAX_PROTOCOL_CHAIN 7
283 STRUCT: WSAPROTOCOLCHAIN
285 { ChainEntries { DWORD 7 } } ;
286 ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
287 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
289 CONSTANT: WSAPROTOCOL_LEN 255
291 STRUCT: WSAPROTOCOL_INFOW
292 { dwServiceFlags1 DWORD }
293 { dwServiceFlags2 DWORD }
294 { dwServiceFlags3 DWORD }
295 { dwServiceFlags4 DWORD }
296 { dwProviderFlags DWORD }
298 { dwCatalogEntryId DWORD }
299 { ProtocolChain WSAPROTOCOLCHAIN }
301 { iAddressFamily int }
306 { iProtocolMaxOffset int }
307 { iNetworkByteOrder int }
308 { iSecurityScheme int }
309 { dwMessageSize DWORD }
310 { dwProviderReserved DWORD }
311 { szProtocol { WCHAR 256 } } ;
312 ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
313 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
314 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
315 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
316 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
317 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
320 STRUCT: WSANAMESPACE_INFOW
321 { NSProviderId GUID }
322 { dwNameSpace DWORD }
325 { lpszIdentifier LPWSTR } ;
326 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
327 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
328 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
329 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
330 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
332 CONSTANT: FD_MAX_EVENTS 10
334 STRUCT: WSANETWORKEVENTS
335 { lNetworkEvents long }
336 { iErrorCode { int FD_MAX_EVENTS } } ;
337 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
338 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
340 ! STRUCT: WSAOVERLAPPED
342 ! { InternalHigh DWORD }
344 ! { OffsetHigh DWORD }
345 ! { hEvent WSAEVENT }
346 ! { bytesTransferred DWORD } ;
347 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
349 FUNCTION: SOCKET WSAAccept ( SOCKET s,
352 LPCONDITIONPROC lpfnCondition,
353 DWORD dwCallbackData )
355 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
357 FUNCTION: int WSACleanup ( )
358 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent )
360 FUNCTION: int WSAConnect ( SOCKET s,
363 LPWSABUF lpCallerData,
364 LPWSABUF lpCalleeData,
367 FUNCTION: WSAEVENT WSACreateEvent ( )
368 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
369 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
370 WSAEVENT hEventObject,
371 LPWSANETWORKEVENTS lpNetworkEvents )
372 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
374 FUNCTION: int WSAEventSelect ( SOCKET s,
375 WSAEVENT hEventObject,
376 long lNetworkEvents )
377 FUNCTION: int WSAGetLastError ( )
378 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
379 LPWSAOVERLAPPED lpOverlapped,
380 LPDWORD lpcbTransfer,
384 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
385 FUNCTION: int WSAIoctl ( SOCKET s,
386 DWORD dwIoControlCode,
391 LPDWORD lpcbBytesReturned,
392 LPWSAOVERLAPPED lpOverlapped,
393 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
395 FUNCTION: int WSARecv ( SOCKET s,
398 LPDWORD lpNumberOfBytesRecvd,
400 LPWSAOVERLAPPED lpOverlapped,
401 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
403 FUNCTION: int WSARecvFrom ( SOCKET s,
406 LPDWORD lpNumberOfBytesRecvd,
410 LPWSAOVERLAPPED lpOverlapped,
411 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
413 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent )
414 FUNCTION: int WSASend ( SOCKET s,
417 LPDWORD lpNumberOfBytesSent,
419 LPWSAOVERLAPPED lpOverlapped,
420 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
422 FUNCTION: int WSASendTo ( SOCKET s,
425 LPDWORD lpNumberOfBytesSent,
429 LPWSAOVERLAPPED lpOverlapped,
430 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
432 FUNCTION: int WSAStartup ( WORD version, LPWSADATA out-data )
434 FUNCTION: SOCKET WSASocketW ( int af,
437 LPWSAPROTOCOL_INFOW lpProtocolInfo,
440 ALIAS: WSASocket WSASocketW
442 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
451 FUNCTION: int AcceptEx ( SOCKET listen,
458 LPOVERLAPPED overlapped )
460 FUNCTION: void GetAcceptExSockaddrs (
461 PVOID lpOutputBuffer,
462 DWORD dwReceiveDataLength,
463 DWORD dwLocalAddressLength,
464 DWORD dwRemoteAddressLength,
465 LPSOCKADDR* LocalSockaddr,
466 LPINT LocalSockaddrLength,
467 LPSOCKADDR* RemoteSockaddr,
468 LPINT RemoteSockaddrLength
471 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
473 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
475 ERROR: winsock-exception n string ;
477 : winsock-expected-error? ( n -- ? )
478 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
480 : (maybe-winsock-exception) ( n -- winsock-exception/f )
481 ! ! WSAStartup returns the error code 'n' directly
482 dup winsock-expected-error?
483 [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
485 : maybe-winsock-exception ( -- winsock-exception/f )
486 WSAGetLastError (maybe-winsock-exception) ;
488 : winsock-error ( -- )
489 maybe-winsock-exception [ throw ] when* ;
491 : (winsock-error) ( n -- * )
492 [ ] [ n>win32-error-string ] bi winsock-exception ;
494 : throw-winsock-error ( -- * )
495 WSAGetLastError (winsock-error) ;
497 : winsock-error=0/f ( n/f -- )
498 { 0 f } member? [ winsock-error ] when ;
500 : winsock-error!=0/f ( n/f -- )
501 { 0 f } member? [ winsock-error ] unless ;
503 ! WSAStartup and WSACleanup return the error code directly
504 : winsock-return-check ( n/f -- )
505 dup { 0 f } member? [
508 [ ] [ n>win32-error-string ] bi winsock-exception
511 : socket-error* ( n -- )
514 dup WSA_IO_PENDING = [
517 (maybe-winsock-exception) throw
521 : socket-error ( n -- )
522 SOCKET_ERROR = [ winsock-error ] when ;
524 : init-winsock ( -- )
525 0x0202 <wsadata> WSAStartup winsock-return-check ;
527 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
529 STARTUP-HOOK: init-winsock
530 SHUTDOWN-HOOK: shutdown-winsock