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