basis/windows/winsock/winsock.factor

   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 ;
   8 IN: windows.winsock
   9
  10 <<
  11 ! Some differences between Win32 and Win64
  12 cpu x86.64? "windows.winsock.64" "windows.winsock.32" ? use-vocab
  13 >>
  14
  15 TYPEDEF: int* SOCKET
  16
  17 : <wsadata> ( -- byte-array )
  18     0x190 <byte-array> ;
  19
  20 CONSTANT: SOCK_STREAM    1
  21 CONSTANT: SOCK_DGRAM     2
  22 CONSTANT: SOCK_RAW       3
  23 CONSTANT: SOCK_RDM       4
  24 CONSTANT: SOCK_SEQPACKET 5
  25
  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
  36
  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
  45
  46 CONSTANT: TCP_NODELAY   0x1
  47
  48 CONSTANT: AF_UNSPEC      0
  49 CONSTANT: AF_UNIX        1
  50 CONSTANT: AF_INET        2
  51 CONSTANT: AF_IMPLINK     3
  52 CONSTANT: AF_PUP         4
  53 CONSTANT: AF_CHAOS       5
  54 CONSTANT: AF_NS          6
  55 CONSTANT: AF_ISO         7
  56 ALIAS: AF_OSI    AF_ISO
  57 CONSTANT: AF_ECMA        8
  58 CONSTANT: AF_DATAKIT     9
  59 CONSTANT: AF_CCITT      10
  60 CONSTANT: AF_SNA        11
  61 CONSTANT: AF_DECnet     12
  62 CONSTANT: AF_DLI        13
  63 CONSTANT: AF_LAT        14
  64 CONSTANT: AF_HYLINK     15
  65 CONSTANT: AF_APPLETALK  16
  66 CONSTANT: AF_NETBIOS    17
  67 CONSTANT: AF_MAX        18
  68 CONSTANT: AF_INET6      23
  69 CONSTANT: AF_IRDA       26
  70 CONSTANT: AF_BTM        32
  71
  72 CONSTANT: PF_UNSPEC      0
  73 CONSTANT: PF_LOCAL       1
  74 CONSTANT: PF_INET        2
  75 CONSTANT: PF_INET6      23
  76
  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
  82
  83 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
  84
  85 CONSTANT: NI_NUMERICHOST 1
  86 CONSTANT: NI_NUMERICSERV 2
  87
  88 CONSTANT: IPPROTO_TCP    6
  89 CONSTANT: IPPROTO_UDP   17
  90 CONSTANT: IPPROTO_RM   113
  91
  92 CONSTANT: FIOASYNC      0x8004667d
  93 CONSTANT: FIONBIO       0x8004667e
  94 CONSTANT: FIONREAD      0x4004667f
  95
  96 CONSTANT: WSA_FLAG_OVERLAPPED 1
  97 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
  98 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
  99 CONSTANT: WSA_INVALID_EVENT f
 100 CONSTANT: WSA_WAIT_FAILED -1
 101 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
 102 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
 103 ALIAS: WSA_INFINITE INFINITE
 104 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
 105
 106 CONSTANT: INADDR_ANY 0
 107
 108 : INVALID_SOCKET ( -- n ) -1 <alien> ; inline
 109
 110 : SOCKET_ERROR ( -- n ) -1 ; inline
 111
 112 CONSTANT: SD_RECV 0
 113 CONSTANT: SD_SEND 1
 114 CONSTANT: SD_BOTH 2
 115
 116 CONSTANT: SOL_SOCKET 0xffff
 117
 118 C-TYPE: sockaddr
 119
 120 STRUCT: sockaddr-in
 121     { family short }
 122     { port ushort }
 123     { addr uint }
 124     { pad char[8] } ;
 125
 126 STRUCT: sockaddr-in6
 127     { family uchar }
 128     { port ushort }
 129     { flowinfo uint }
 130     { addr uchar[16] }
 131     { scopeid uint } ;
 132
 133 STRUCT: hostent
 134     { name c-string }
 135     { aliases void* }
 136     { addrtype short }
 137     { length short }
 138     { addr-list void* } ;
 139
 140 STRUCT: protoent
 141     { name c-string }
 142     { aliases void* }
 143     { proto short } ;
 144
 145 STRUCT: addrinfo
 146     { flags int }
 147     { family int }
 148     { socktype int }
 149     { protocol int }
 150     { addrlen size_t }
 151     { canonname c-string }
 152     { addr sockaddr* }
 153     { next addrinfo* } ;
 154
 155 STRUCT: timeval
 156     { sec long }
 157     { usec long } ;
 158
 159 GENERIC: sockaddr>ip ( sockaddr -- string )
 160
 161 M: sockaddr-in sockaddr>ip
 162     addr>> uint <ref> [ number>string ] { } map-as "." join ;
 163
 164 M: sockaddr-in6 sockaddr>ip
 165     addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
 166
 167 STRUCT: fd_set
 168     { fd_count uint }
 169     { fd_array SOCKET[64] } ;
 170
 171 LIBRARY: winsock
 172
 173 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen )
 174 FUNCTION: int ioctlsocket ( SOCKET s, long cmd, ulong* *argp )
 175
 176 FUNCTION: ushort htons ( ushort n )
 177 FUNCTION: ushort ntohs ( ushort n )
 178 FUNCTION: int bind ( SOCKET socket, sockaddr-in* sockaddr, int len )
 179 FUNCTION: int listen ( SOCKET socket, int backlog )
 180 FUNCTION: c-string inet_ntoa ( int in-addr )
 181 FUNCTION: int getaddrinfo ( c-string nodename,
 182                             c-string servername,
 183                             addrinfo* hints,
 184                             addrinfo** res )
 185
 186 FUNCTION: void freeaddrinfo ( addrinfo* ai )
 187
 188
 189 FUNCTION: hostent* gethostbyname ( c-string name )
 190 FUNCTION: int gethostname ( c-string name, int len )
 191 FUNCTION: SOCKET socket ( int domain, int type, int protocol )
 192 FUNCTION: int connect ( SOCKET socket, sockaddr-in* sockaddr, int addrlen )
 193 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout )
 194 FUNCTION: int closesocket ( SOCKET s )
 195 FUNCTION: int shutdown ( SOCKET s, int how )
 196 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags )
 197 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags )
 198
 199 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen )
 200 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen )
 201
 202 FUNCTION: protoent* getprotobyname ( c-string name )
 203
 204 FUNCTION: servent* getservbyname ( c-string name, c-string prot )
 205 FUNCTION: servent* getservbyport ( int port, c-string prot )
 206
 207 TYPEDEF: uint SERVICETYPE
 208 TYPEDEF: void* LPWSADATA
 209 TYPEDEF: OVERLAPPED WSAOVERLAPPED
 210 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
 211 TYPEDEF: uint GROUP
 212 TYPEDEF: void* LPCONDITIONPROC
 213 TYPEDEF: HANDLE WSAEVENT
 214 TYPEDEF: LPHANDLE LPWSAEVENT
 215 TYPEDEF: sockaddr* LPSOCKADDR
 216
 217 STRUCT: FLOWSPEC
 218     { TokenRate          uint        }
 219     { TokenBucketSize    uint        }
 220     { PeakBandwidth      uint        }
 221     { Latency            uint        }
 222     { DelayVariation     uint        }
 223     { ServiceType        SERVICETYPE }
 224     { MaxSduSize         uint        }
 225     { MinimumPolicedSize uint        } ;
 226 TYPEDEF: FLOWSPEC* PFLOWSPEC
 227 TYPEDEF: FLOWSPEC* LPFLOWSPEC
 228
 229 STRUCT: WSABUF
 230     { len ulong }
 231     { buf void* } ;
 232 TYPEDEF: WSABUF* LPWSABUF
 233
 234 STRUCT: QOS
 235     { SendingFlowspec FLOWSPEC }
 236     { ReceivingFlowspec FLOWSPEC }
 237     { ProviderSpecific WSABUF } ;
 238 TYPEDEF: QOS* LPQOS
 239
 240 CONSTANT: MAX_PROTOCOL_CHAIN 7
 241
 242 STRUCT: WSAPROTOCOLCHAIN
 243     { ChainLen int }
 244     { ChainEntries { DWORD 7 } } ;
 245     ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
 246 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
 247
 248 CONSTANT: WSAPROTOCOL_LEN 255
 249
 250 STRUCT: WSAPROTOCOL_INFOW
 251     { dwServiceFlags1 DWORD }
 252     { dwServiceFlags2 DWORD }
 253     { dwServiceFlags3 DWORD }
 254     { dwServiceFlags4 DWORD }
 255     { dwProviderFlags DWORD }
 256     { ProviderId GUID }
 257     { dwCatalogEntryId DWORD }
 258     { ProtocolChain WSAPROTOCOLCHAIN }
 259     { iVersion int }
 260     { iAddressFamily int }
 261     { iMaxSockAddr int }
 262     { iMinSockAddr int }
 263     { iSocketType int }
 264     { iProtocol int }
 265     { iProtocolMaxOffset int }
 266     { iNetworkByteOrder int }
 267     { iSecurityScheme int }
 268     { dwMessageSize DWORD }
 269     { dwProviderReserved DWORD }
 270     { szProtocol { WCHAR 256 } } ;
 271     ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
 272 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
 273 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
 274 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
 275 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
 276 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
 277
 278
 279 STRUCT: WSANAMESPACE_INFOW
 280     { NSProviderId   GUID    }
 281     { dwNameSpace    DWORD   }
 282     { fActive        BOOL    }
 283     { dwVersion      DWORD   }
 284     { lpszIdentifier LPWSTR  } ;
 285 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
 286 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
 287 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
 288 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
 289 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
 290
 291 CONSTANT: FD_MAX_EVENTS 10
 292
 293 STRUCT: WSANETWORKEVENTS
 294     { lNetworkEvents long }
 295     { iErrorCode { int FD_MAX_EVENTS } } ;
 296 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
 297 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
 298
 299 ! STRUCT: WSAOVERLAPPED
 300     ! { Internal DWORD }
 301     ! { InternalHigh DWORD }
 302     ! { Offset DWORD }
 303     ! { OffsetHigh DWORD }
 304     ! { hEvent WSAEVENT }
 305     ! { bytesTransferred DWORD } ;
 306 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
 307
 308 FUNCTION: SOCKET WSAAccept ( SOCKET s,
 309                              sockaddr* addr,
 310                              LPINT addrlen,
 311                              LPCONDITIONPROC lpfnCondition,
 312                              DWORD dwCallbackData )
 313
 314 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
 315
 316 FUNCTION: int WSACleanup ( )
 317 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent )
 318
 319 FUNCTION: int WSAConnect ( SOCKET s,
 320                            sockaddr* name,
 321                            int namelen,
 322                            LPWSABUF lpCallerData,
 323                            LPWSABUF lpCalleeData,
 324                            LPQOS lpSQOS,
 325                            LPQOS lpGQOS )
 326 FUNCTION: WSAEVENT WSACreateEvent ( )
 327 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
 328 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
 329                                      WSAEVENT hEventObject,
 330                                      LPWSANETWORKEVENTS lpNetworkEvents )
 331 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
 332
 333 FUNCTION: int WSAEventSelect ( SOCKET s,
 334                                WSAEVENT hEventObject,
 335                                long lNetworkEvents )
 336 FUNCTION: int WSAGetLastError ( )
 337 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
 338                                         LPWSAOVERLAPPED lpOverlapped,
 339                                         LPDWORD lpcbTransfer,
 340                                         BOOL fWait,
 341                                         LPDWORD lpdwFlags )
 342
 343 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
 344 FUNCTION: int WSAIoctl ( SOCKET s,
 345                          DWORD dwIoControlCode,
 346                          LPVOID lpvInBuffer,
 347                          DWORD cbInBuffer,
 348                          LPVOID lpvOutBuffer,
 349                          DWORD cbOutBuffer,
 350                          LPDWORD lpcbBytesReturned,
 351                          LPWSAOVERLAPPED lpOverlapped,
 352                          LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
 353
 354 FUNCTION: int WSARecv ( SOCKET s,
 355                         LPWSABUF lpBuffers,
 356                         DWORD dwBufferCount,
 357                         LPDWORD lpNumberOfBytesRecvd,
 358                         LPDWORD lpFlags,
 359                         LPWSAOVERLAPPED lpOverlapped,
 360                         LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
 361
 362 FUNCTION: int WSARecvFrom ( SOCKET s,
 363                             LPWSABUF lpBuffers,
 364                             DWORD dwBufferCount,
 365                             LPDWORD lpNumberOfBytesRecvd,
 366                             LPDWORD lpFlags,
 367                             sockaddr* lpFrom,
 368                             LPINT lpFromlen,
 369                             LPWSAOVERLAPPED lpOverlapped,
 370                             LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
 371
 372 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent )
 373 FUNCTION: int WSASend ( SOCKET s,
 374                         LPWSABUF lpBuffers,
 375                         DWORD dwBufferCount,
 376                         LPDWORD lpNumberOfBytesSent,
 377                         LPDWORD lpFlags,
 378                         LPWSAOVERLAPPED lpOverlapped,
 379                  LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
 380
 381 FUNCTION: int WSASendTo ( SOCKET s,
 382                           LPWSABUF lpBuffers,
 383                           DWORD dwBufferCount,
 384                           LPDWORD lpNumberOfBytesSent,
 385                           DWORD dwFlags,
 386                           sockaddr* lpTo,
 387                           int iToLen,
 388                           LPWSAOVERLAPPED lpOverlapped,
 389   LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
 390
 391 FUNCTION: int WSAStartup ( WORD version,  LPWSADATA out-data )
 392
 393 FUNCTION: SOCKET WSASocketW ( int af,
 394                              int type,
 395                              int protocol,
 396                              LPWSAPROTOCOL_INFOW lpProtocolInfo,
 397                              GROUP g,
 398                              DWORD flags )
 399 ALIAS: WSASocket WSASocketW
 400
 401 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
 402                                            WSAEVENT* lphEvents,
 403                                            BOOL fWaitAll,
 404                                            DWORD dwTimeout,
 405                                            BOOL fAlertable )
 406
 407
 408 LIBRARY: mswsock
 409
 410 FUNCTION: int AcceptEx ( SOCKET listen,
 411                          SOCKET accept,
 412                          PVOID out-buf,
 413                          DWORD recv-len,
 414                          DWORD addr-len,
 415                          DWORD remote-len,
 416                          LPDWORD out-len,
 417                          LPOVERLAPPED overlapped )
 418
 419 FUNCTION: void GetAcceptExSockaddrs (
 420   PVOID lpOutputBuffer,
 421   DWORD dwReceiveDataLength,
 422   DWORD dwLocalAddressLength,
 423   DWORD dwRemoteAddressLength,
 424   LPSOCKADDR* LocalSockaddr,
 425   LPINT LocalSockaddrLength,
 426   LPSOCKADDR* RemoteSockaddr,
 427   LPINT RemoteSockaddrLength
 428 )
 429
 430 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
 431
 432 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
 433
 434 ERROR: winsock-exception n string ;
 435
 436 : winsock-expected-error? ( n -- ? )
 437     ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
 438
 439 : (maybe-winsock-exception) ( n -- winsock-exception/f )
 440     ! ! WSAStartup returns the error code 'n' directly
 441     dup winsock-expected-error?
 442     [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
 443
 444 : maybe-winsock-exception ( -- winsock-exception/f )
 445     WSAGetLastError (maybe-winsock-exception) ;
 446
 447 : winsock-error ( -- )
 448     maybe-winsock-exception [ throw ] when* ;
 449
 450 : (winsock-error) ( n -- * )
 451     [ ] [ n>win32-error-string ] bi winsock-exception ;
 452
 453 : throw-winsock-error ( -- * )
 454     WSAGetLastError (winsock-error) ;
 455
 456 : winsock-error=0/f ( n/f -- )
 457     { 0 f } member? [ winsock-error ] when ;
 458
 459 : winsock-error!=0/f ( n/f -- )
 460     { 0 f } member? [ winsock-error ] unless ;
 461
 462 ! WSAStartup and WSACleanup return the error code directly
 463 : winsock-return-check ( n/f -- )
 464     dup { 0 f } member? [
 465         drop
 466     ] [
 467         [ ] [ n>win32-error-string ] bi winsock-exception
 468     ] if ;
 469
 470 : socket-error* ( n -- )
 471     SOCKET_ERROR = [
 472         WSAGetLastError
 473         dup WSA_IO_PENDING = [
 474             drop
 475         ] [
 476             (maybe-winsock-exception) throw
 477         ] if
 478     ] when ;
 479
 480 : socket-error ( n -- )
 481     SOCKET_ERROR = [ winsock-error ] when ;
 482
 483 : init-winsock ( -- )
 484     0x0202 <wsadata> WSAStartup winsock-return-check ;
 485
 486 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
 487
 488 [ init-winsock ] "windows.winsock" add-startup-hook
 489 [ shutdown-winsock ] "windows.winsock" add-shutdown-hook