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 windows.com.syntax windows.errors
7 windows.kernel32 windows.types ;
8 FROM: alien.c-types => short ;
13 : <wsadata> ( -- byte-array )
16 CONSTANT: SOCK_STREAM 1
17 CONSTANT: SOCK_DGRAM 2
20 CONSTANT: SOCK_SEQPACKET 5
22 CONSTANT: SO_DEBUG 0x1
23 CONSTANT: SO_ACCEPTCONN 0x2
24 CONSTANT: SO_REUSEADDR 0x4
25 CONSTANT: SO_KEEPALIVE 0x8
26 CONSTANT: SO_DONTROUTE 0x10
27 CONSTANT: SO_BROADCAST 0x20
28 CONSTANT: SO_USELOOPBACK 0x40
29 CONSTANT: SO_LINGER 0x80
30 CONSTANT: SO_OOBINLINE 0x100
31 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
33 CONSTANT: SO_SNDBUF 0x1001
34 CONSTANT: SO_RCVBUF 0x1002
35 CONSTANT: SO_SNDLOWAT 0x1003
36 CONSTANT: SO_RCVLOWAT 0x1004
37 CONSTANT: SO_SNDTIMEO 0x1005
38 CONSTANT: SO_RCVTIMEO 0x1006
39 CONSTANT: SO_ERROR 0x1007
40 CONSTANT: SO_TYPE 0x1008
42 CONSTANT: TCP_NODELAY 0x1
47 CONSTANT: AF_IMPLINK 3
54 CONSTANT: AF_DATAKIT 9
57 CONSTANT: AF_DECnet 12
60 CONSTANT: AF_HYLINK 15
61 CONSTANT: AF_APPLETALK 16
62 CONSTANT: AF_NETBIOS 17
73 CONSTANT: AI_PASSIVE 1
74 CONSTANT: AI_CANONNAME 2
75 CONSTANT: AI_NUMERICHOST 4
77 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
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 ( -- n ) -1 <alien> ; inline
100 : SOCKET_ERROR ( -- n ) -1 <alien> ; inline
106 CONSTANT: SOL_SOCKET 0xffff
128 { addr-list void* } ;
141 { canonname c-string }
149 GENERIC: sockaddr>ip ( sockaddr -- string )
151 M: sockaddr-in sockaddr>ip ( sockaddr -- string )
152 addr>> uint <ref> [ number>string ] { } map-as "." join ;
154 M: sockaddr-in6 sockaddr>ip ( uchar-array -- string )
155 addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
161 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen ) ;
163 FUNCTION: ushort htons ( ushort n ) ;
164 FUNCTION: ushort ntohs ( ushort n ) ;
165 FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
166 FUNCTION: int listen ( void* socket, int backlog ) ;
167 FUNCTION: c-string inet_ntoa ( int in-addr ) ;
168 FUNCTION: int getaddrinfo ( c-string nodename,
173 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
176 FUNCTION: hostent* gethostbyname ( c-string name ) ;
177 FUNCTION: int gethostname ( c-string name, int len ) ;
178 FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
179 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
180 FUNCTION: int closesocket ( SOCKET s ) ;
181 FUNCTION: int shutdown ( SOCKET s, int how ) ;
182 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags ) ;
183 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags ) ;
185 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
186 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
188 FUNCTION: protoent* getprotobyname ( c-string name ) ;
190 TYPEDEF: uint SERVICETYPE
191 TYPEDEF: OVERLAPPED WSAOVERLAPPED
192 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
194 TYPEDEF: void* LPCONDITIONPROC
195 TYPEDEF: HANDLE WSAEVENT
196 TYPEDEF: LPHANDLE LPWSAEVENT
197 TYPEDEF: sockaddr* LPSOCKADDR
201 { TokenBucketSize uint }
202 { PeakBandwidth uint }
204 { DelayVariation uint }
205 { ServiceType SERVICETYPE }
207 { MinimumPolicedSize uint } ;
208 TYPEDEF: FLOWSPEC* PFLOWSPEC
209 TYPEDEF: FLOWSPEC* LPFLOWSPEC
214 TYPEDEF: WSABUF* LPWSABUF
217 { SendingFlowspec FLOWSPEC }
218 { ReceivingFlowspec FLOWSPEC }
219 { ProviderSpecific WSABUF } ;
222 CONSTANT: MAX_PROTOCOL_CHAIN 7
224 STRUCT: WSAPROTOCOLCHAIN
226 { ChainEntries { DWORD 7 } } ;
227 ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
228 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
230 CONSTANT: WSAPROTOCOL_LEN 255
232 STRUCT: WSAPROTOCOL_INFOW
233 { dwServiceFlags1 DWORD }
234 { dwServiceFlags2 DWORD }
235 { dwServiceFlags3 DWORD }
236 { dwServiceFlags4 DWORD }
237 { dwProviderFlags DWORD }
239 { dwCatalogEntryId DWORD }
240 { ProtocolChain WSAPROTOCOLCHAIN }
242 { iAddressFamily int }
247 { iProtocolMaxOffset int }
248 { iNetworkByteOrder int }
249 { iSecurityScheme int }
250 { dwMessageSize DWORD }
251 { dwProviderReserved DWORD }
252 { szProtocol { WCHAR 256 } } ;
253 ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
254 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
255 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
256 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
257 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
258 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
261 STRUCT: WSANAMESPACE_INFOW
262 { NSProviderId GUID }
263 { dwNameSpace DWORD }
266 { lpszIdentifier LPWSTR } ;
267 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
268 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
269 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
270 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
271 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
273 CONSTANT: FD_MAX_EVENTS 10
275 STRUCT: WSANETWORKEVENTS
276 { lNetworkEvents long }
277 { iErrorCode { int FD_MAX_EVENTS } } ;
278 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
279 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
281 ! STRUCT: WSAOVERLAPPED
283 ! { InternalHigh DWORD }
285 ! { OffsetHigh DWORD }
286 ! { hEvent WSAEVENT }
287 ! { bytesTransferred DWORD } ;
288 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
290 FUNCTION: SOCKET WSAAccept ( SOCKET s,
293 LPCONDITIONPROC lpfnCondition,
294 DWORD dwCallbackData ) ;
296 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
298 FUNCTION: int WSACleanup ( ) ;
299 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
301 FUNCTION: int WSAConnect ( SOCKET s,
304 LPWSABUF lpCallerData,
305 LPWSABUF lpCalleeData,
308 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
309 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
310 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
311 WSAEVENT hEventObject,
312 LPWSANETWORKEVENTS lpNetworkEvents ) ;
313 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
315 FUNCTION: int WSAEventSelect ( SOCKET s,
316 WSAEVENT hEventObject,
317 long lNetworkEvents ) ;
318 FUNCTION: int WSAGetLastError ( ) ;
319 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
320 LPWSAOVERLAPPED lpOverlapped,
321 LPDWORD lpcbTransfer,
323 LPDWORD lpdwFlags ) ;
325 FUNCTION: int WSAIoctl ( SOCKET s,
326 DWORD dwIoControlCode,
331 LPDWORD lpcbBytesReturned,
333 void* lpCompletionRoutine ) ;
335 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
336 FUNCTION: int WSARecv ( SOCKET s,
339 LPDWORD lpNumberOfBytesRecvd,
341 LPWSAOVERLAPPED lpOverlapped,
342 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
344 FUNCTION: int WSARecvFrom ( SOCKET s,
347 LPDWORD lpNumberOfBytesRecvd,
351 LPWSAOVERLAPPED lpOverlapped,
352 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
354 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
355 FUNCTION: int WSASend ( SOCKET s,
358 LPDWORD lpNumberOfBytesSent,
360 LPWSAOVERLAPPED lpOverlapped,
361 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
363 FUNCTION: int WSASendTo ( SOCKET s,
366 LPDWORD lpNumberOfBytesSent,
370 LPWSAOVERLAPPED lpOverlapped,
371 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
374 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
378 FUNCTION: SOCKET WSASocketW ( int af,
381 LPWSAPROTOCOL_INFOW lpProtocolInfo,
384 ALIAS: WSASocket WSASocketW
386 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
395 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
397 FUNCTION: void GetAcceptExSockaddrs (
398 PVOID lpOutputBuffer,
399 DWORD dwReceiveDataLength,
400 DWORD dwLocalAddressLength,
401 DWORD dwRemoteAddressLength,
402 LPSOCKADDR* LocalSockaddr,
403 LPINT LocalSockaddrLength,
404 LPSOCKADDR* RemoteSockaddr,
405 LPINT RemoteSockaddrLength
408 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
410 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
412 ERROR: winsock-exception n string ;
414 : winsock-expected-error? ( n -- ? )
415 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
417 : (maybe-winsock-exception) ( n -- winsock-exception/f )
418 ! #! WSAStartup returns the error code 'n' directly
419 dup winsock-expected-error?
420 [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
422 : maybe-winsock-exception ( -- winsock-exception/f )
423 WSAGetLastError (maybe-winsock-exception) ;
425 : winsock-error ( -- )
426 maybe-winsock-exception [ throw ] when* ;
428 : (throw-winsock-error) ( n -- * )
429 [ ] [ n>win32-error-string ] bi winsock-exception ;
431 : throw-winsock-error ( -- * )
432 WSAGetLastError (throw-winsock-error) ;
434 : winsock-error=0/f ( n/f -- )
435 { 0 f } member? [ throw-winsock-error ] when ;
437 : winsock-error!=0/f ( n/f -- )
438 { 0 f } member? [ throw-winsock-error ] unless ;
440 ! WSAStartup and WSACleanup return the error code directly
441 : winsock-return-check ( n/f -- )
442 dup { 0 f } member? [
445 [ ] [ n>win32-error-string ] bi winsock-exception
448 : socket-error* ( n -- )
451 dup WSA_IO_PENDING = [
454 (maybe-winsock-exception) throw
458 : socket-error ( n -- )
459 SOCKET_ERROR = [ winsock-error ] when ;
461 : init-winsock ( -- )
462 0x0202 <wsadata> WSAStartup winsock-return-check ;
464 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
466 [ init-winsock ] "windows.winsock" add-startup-hook
467 [ shutdown-winsock ] "windows.winsock" add-shutdown-hook