basis/windows/winsock/winsock.factor

   1 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
   2
   3 USING: alien alien.c-types alien.strings alien.syntax arrays
   4 byte-arrays kernel math sequences windows.types windows.kernel32
   5 windows.errors structs windows math.bitwise alias ;
   6 IN: windows.winsock
   7
   8 USE: libc
   9 : alien>byte-array ( alien str -- byte-array )
  10     heap-size dup <byte-array> [ -rot memcpy ] keep ;
  11
  12 TYPEDEF: void* SOCKET
  13
  14 : <wsadata> ( -- byte-array )
  15     HEX: 190 <byte-array> ;
  16
  17 : SOCK_STREAM    1 ; inline
  18 : SOCK_DGRAM     2 ; inline
  19 : SOCK_RAW       3 ; inline
  20 : SOCK_RDM       4 ; inline
  21 : SOCK_SEQPACKET 5 ; inline
  22
  23 : SO_DEBUG       HEX:   1 ; inline
  24 : SO_ACCEPTCONN  HEX:   2 ; inline
  25 : SO_REUSEADDR   HEX:   4 ; inline
  26 : SO_KEEPALIVE   HEX:   8 ; inline
  27 : SO_DONTROUTE   HEX:  10 ; inline
  28 : SO_BROADCAST   HEX:  20 ; inline
  29 : SO_USELOOPBACK HEX:  40 ; inline
  30 : SO_LINGER      HEX:  80 ; inline
  31 : SO_OOBINLINE   HEX: 100 ; inline
  32 : SO_DONTLINGER SO_LINGER bitnot ; inline
  33
  34 : SO_SNDBUF     HEX: 1001 ; inline
  35 : SO_RCVBUF     HEX: 1002 ; inline
  36 : SO_SNDLOWAT   HEX: 1003 ; inline
  37 : SO_RCVLOWAT   HEX: 1004 ; inline
  38 : SO_SNDTIMEO   HEX: 1005 ; inline
  39 : SO_RCVTIMEO   HEX: 1006 ; inline
  40 : SO_ERROR      HEX: 1007 ; inline
  41 : SO_TYPE       HEX: 1008 ; inline
  42
  43 : TCP_NODELAY   HEX:    1 ; inline
  44
  45 : AF_UNSPEC      0 ; inline
  46 : AF_UNIX        1 ; inline
  47 : AF_INET        2 ; inline
  48 : AF_IMPLINK     3 ; inline
  49 : AF_PUP         4 ; inline
  50 : AF_CHAOS       5 ; inline
  51 : AF_NS          6 ; inline
  52 : AF_ISO         7 ; inline
  53 : AF_OSI    AF_ISO ; inline
  54 : AF_ECMA        8 ; inline
  55 : AF_DATAKIT     9 ; inline
  56 : AF_CCITT      10 ; inline
  57 : AF_SNA        11 ; inline
  58 : AF_DECnet     12 ; inline
  59 : AF_DLI        13 ; inline
  60 : AF_LAT        14 ; inline
  61 : AF_HYLINK     15 ; inline
  62 : AF_APPLETALK  16 ; inline
  63 : AF_NETBIOS    17 ; inline
  64 : AF_MAX        18 ; inline
  65 : AF_INET6      23 ; inline
  66 : AF_IRDA       26 ; inline
  67 : AF_BTM        32 ; inline
  68
  69 : PF_UNSPEC      0 ; inline
  70 : PF_LOCAL       1 ; inline
  71 : PF_INET        2 ; inline
  72 : PF_INET6      23 ; inline
  73
  74 : AI_PASSIVE     1 ; inline
  75 : AI_CANONNAME   2 ; inline
  76 : AI_NUMERICHOST 4 ; inline
  77 : AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
  78
  79 : NI_NUMERICHOST 1 ;
  80 : NI_NUMERICSERV 2 ;
  81
  82 : IPPROTO_TCP    6 ; inline
  83 : IPPROTO_UDP   17 ; inline
  84 : IPPROTO_RM   113 ; inline
  85
  86 : WSA_FLAG_OVERLAPPED 1 ; inline
  87 : WSA_WAIT_EVENT_0 WAIT_OBJECT_0 ; inline
  88 : WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS ; inline
  89 : WSA_INVALID_EVENT f ; inline
  90 : WSA_WAIT_FAILED -1 ; inline
  91 : WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION ; inline
  92 : WSA_WAIT_TIMEOUT WAIT_TIMEOUT ; inline
  93 : WSA_INFINITE INFINITE ; inline
  94 : WSA_IO_PENDING ERROR_IO_PENDING ; inline
  95
  96 : INADDR_ANY 0 ; inline
  97
  98 : INVALID_SOCKET -1 <alien> ; inline
  99 : SOCKET_ERROR -1 ; inline
 100
 101 : SD_RECV 0 ; inline
 102 : SD_SEND 1 ; inline
 103 : SD_BOTH 2 ; inline
 104
 105 : SOL_SOCKET HEX: ffff ; inline
 106
 107 ! TYPEDEF: uint in_addr_t
 108 ! C-STRUCT: in_addr
 109     ! { "in_addr_t" "s_addr" } ;
 110
 111 C-STRUCT: sockaddr-in
 112     { "short" "family" }
 113     { "ushort" "port" }
 114     { "uint" "addr" }
 115     { { "char" 8 } "pad" } ;
 116
 117 C-STRUCT: sockaddr-in6
 118     { "uchar" "family" }
 119     { "ushort" "port" }
 120     { "uint" "flowinfo" }
 121     { { "uchar" 16 } "addr" }
 122     { "uint" "scopeid" } ;
 123
 124 C-STRUCT: hostent
 125     { "char*" "name" }
 126     { "void*" "aliases" }
 127     { "short" "addrtype" }
 128     { "short" "length" }
 129     { "void*" "addr-list" } ;
 130
 131 C-STRUCT: addrinfo
 132     { "int" "flags" }
 133     { "int" "family" }
 134     { "int" "socktype" }
 135     { "int" "protocol" }
 136     { "size_t" "addrlen" }
 137     { "char*" "canonname" }
 138     { "sockaddr*" "addr" }
 139     { "addrinfo*" "next" } ;
 140
 141 : hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
 142
 143 LIBRARY: winsock
 144
 145
 146 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
 147
 148 FUNCTION: ushort htons ( ushort n ) ;
 149 FUNCTION: ushort ntohs ( ushort n ) ;
 150 FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
 151 FUNCTION: int listen ( void* socket, int backlog ) ;
 152 FUNCTION: char* inet_ntoa ( int in-addr ) ;
 153 FUNCTION: int getaddrinfo ( char* nodename,
 154                             char* servername,
 155                             addrinfo* hints,
 156                             addrinfo** res ) ;
 157
 158 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
 159
 160
 161 FUNCTION: hostent* gethostbyname ( char* name ) ;
 162 FUNCTION: int gethostname ( char* name, int len ) ;
 163 FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
 164 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
 165 FUNCTION: int closesocket ( SOCKET s ) ;
 166 FUNCTION: int shutdown ( SOCKET s, int how ) ;
 167 FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
 168 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
 169
 170 FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
 171 FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
 172
 173 TYPEDEF: uint SERVICETYPE
 174 TYPEDEF: OVERLAPPED WSAOVERLAPPED
 175 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
 176 TYPEDEF: uint GROUP
 177 TYPEDEF: void* LPCONDITIONPROC
 178 TYPEDEF: HANDLE WSAEVENT
 179 TYPEDEF: LPHANDLE LPWSAEVENT
 180 TYPEDEF: sockaddr* LPSOCKADDR
 181
 182 C-STRUCT: FLOWSPEC
 183     { "uint"        "TokenRate" }
 184     { "uint"        "TokenBucketSize" }
 185     { "uint"        "PeakBandwidth" }
 186     { "uint"        "Latency" }
 187     { "uint"        "DelayVariation" }
 188     { "SERVICETYPE" "ServiceType" }
 189     { "uint"        "MaxSduSize" }
 190     { "uint"        "MinimumPolicedSize" } ;
 191 TYPEDEF: FLOWSPEC* PFLOWSPEC
 192 TYPEDEF: FLOWSPEC* LPFLOWSPEC
 193
 194 C-STRUCT: WSABUF
 195     { "ulong" "len" }
 196     { "void*" "buf" } ;
 197 TYPEDEF: WSABUF* LPWSABUF
 198
 199 C-STRUCT: QOS
 200     { "FLOWSPEC" "SendingFlowspec" }
 201     { "FLOWSPEC" "ReceivingFlowspec" }
 202     { "WSABUF" "ProviderSpecific" } ;
 203 TYPEDEF: QOS* LPQOS
 204
 205 : MAX_PROTOCOL_CHAIN 7 ; inline
 206
 207 C-STRUCT: WSAPROTOCOLCHAIN
 208     { "int" "ChainLen" }
 209     ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
 210     { { "DWORD" 7 } "ChainEntries" } ;
 211 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
 212
 213 : WSAPROTOCOL_LEN 255 ; inline
 214
 215 C-STRUCT: WSAPROTOCOL_INFOW
 216     { "DWORD" "dwServiceFlags1" }
 217     { "DWORD" "dwServiceFlags2" }
 218     { "DWORD" "dwServiceFlags3" }
 219     { "DWORD" "dwServiceFlags4" }
 220     { "DWORD" "dwProviderFlags" }
 221     { "GUID" "ProviderId" }
 222     { "DWORD" "dwCatalogEntryId" }
 223     { "WSAPROTOCOLCHAIN" "ProtocolChain" }
 224     { "int" "iVersion" }
 225     { "int" "iAddressFamily" }
 226     { "int" "iMaxSockAddr" }
 227     { "int" "iMinSockAddr" }
 228     { "int" "iSocketType" }
 229     { "int" "iProtocol" }
 230     { "int" "iProtocolMaxOffset" }
 231     { "int" "iNetworkByteOrder" }
 232     { "int" "iSecurityScheme" }
 233     { "DWORD" "dwMessageSize" }
 234     { "DWORD" "dwProviderReserved" }
 235     { { "WCHAR" 256 } "szProtocol" } ;
 236     ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ;
 237 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
 238 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
 239 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
 240 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
 241 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
 242
 243
 244 C-STRUCT: WSANAMESPACE_INFOW
 245     { "GUID"    "NSProviderId" }
 246     { "DWORD"   "dwNameSpace" }
 247     { "BOOL"    "fActive" }
 248     { "DWORD"   "dwVersion" }
 249     { "LPWSTR"  "lpszIdentifier" } ;
 250 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
 251 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
 252 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
 253 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
 254 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
 255
 256 : FD_MAX_EVENTS 10 ;
 257
 258 C-STRUCT: WSANETWORKEVENTS
 259     { "long" "lNetworkEvents" }
 260     ! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ;
 261     { { "int" 10 } "iErrorCode" } ;
 262 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
 263 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
 264
 265 ! C-STRUCT: WSAOVERLAPPED
 266     ! { "DWORD" "Internal" }
 267     ! { "DWORD" "InternalHigh" }
 268     ! { "DWORD" "Offset" }
 269     ! { "DWORD" "OffsetHigh" }
 270     ! { "WSAEVENT" "hEvent" }
 271     ! { "DWORD" "bytesTransferred" } ;
 272 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
 273
 274 FUNCTION: SOCKET WSAAccept ( SOCKET s,
 275                              sockaddr* addr,
 276                              LPINT addrlen,
 277                              LPCONDITIONPROC lpfnCondition,
 278                              DWORD dwCallbackData ) ;
 279
 280 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
 281
 282 FUNCTION: int WSACleanup ( ) ;
 283 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
 284
 285 FUNCTION: int WSAConnect ( SOCKET s,
 286                            sockaddr* name,
 287                            int namelen,
 288                            LPWSABUF lpCallerData,
 289                            LPWSABUF lpCalleeData,
 290                            LPQOS lpSQOS,
 291                            LPQOS lpGQOS ) ;
 292 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
 293 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
 294 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
 295                                      WSAEVENT hEventObject,
 296                                      LPWSANETWORKEVENTS lpNetworkEvents ) ;
 297 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
 298
 299 FUNCTION: int WSAEventSelect ( SOCKET s,
 300                                WSAEVENT hEventObject,
 301                                long lNetworkEvents ) ;
 302 FUNCTION: int WSAGetLastError ( ) ;
 303 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
 304                                         LPWSAOVERLAPPED lpOverlapped,
 305                                         LPDWORD lpcbTransfer,
 306                                         BOOL fWait,
 307                                         LPDWORD lpdwFlags ) ;
 308
 309 FUNCTION: int WSAIoctl ( SOCKET s,
 310                          DWORD dwIoControlCode,
 311                          LPVOID lpvInBuffer,
 312                          DWORD cbInBuffer,
 313                          LPVOID lpvOutBuffer,
 314                          DWORD cbOutBuffer,
 315                          LPDWORD lpcbBytesReturned,
 316                          void* lpOverlapped,
 317                          void* lpCompletionRoutine ) ;
 318
 319 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
 320 FUNCTION: int WSARecv ( SOCKET s,
 321                         LPWSABUF lpBuffers,
 322                         DWORD dwBufferCount,
 323                         LPDWORD lpNumberOfBytesRecvd,
 324                         LPDWORD lpFlags,
 325                         LPWSAOVERLAPPED lpOverlapped,
 326                     LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
 327
 328 FUNCTION: int WSARecvFrom ( SOCKET s,
 329                     LPWSABUF lpBuffers,
 330                     DWORD dwBufferCount,
 331                     LPDWORD lpNumberOfBytesRecvd,
 332                     LPDWORD lpFlags,
 333                     sockaddr* lpFrom,
 334                     LPINT lpFromlen,
 335                     LPWSAOVERLAPPED lpOverlapped,
 336                     LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
 337
 338 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
 339 FUNCTION: int WSASend ( SOCKET s,
 340                         LPWSABUF lpBuffers,
 341                         DWORD dwBufferCount,
 342                         LPDWORD lpNumberOfBytesSent,
 343                         LPDWORD lpFlags,
 344                         LPWSAOVERLAPPED lpOverlapped,
 345                  LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
 346
 347 FUNCTION: int WSASendTo ( SOCKET s,
 348                           LPWSABUF lpBuffers,
 349                           DWORD dwBufferCount,
 350                           LPDWORD lpNumberOfBytesSent,
 351                           DWORD dwFlags,
 352                           sockaddr* lpTo,
 353                           int iToLen,
 354                           LPWSAOVERLAPPED lpOverlapped,
 355   LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
 356
 357
 358 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
 359
 360
 361
 362 FUNCTION: SOCKET WSASocketW ( int af,
 363                              int type,
 364                              int protocol,
 365                              LPWSAPROTOCOL_INFOW lpProtocolInfo,
 366                              GROUP g,
 367                              DWORD flags ) ;
 368 ALIAS: WSASocket WSASocketW
 369
 370 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
 371                                            WSAEVENT* lphEvents,
 372                                            BOOL fWaitAll,
 373                                            DWORD dwTimeout,
 374                                            BOOL fAlertable ) ;
 375
 376
 377
 378
 379 LIBRARY: mswsock
 380
 381 ! Not in Windows CE
 382 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
 383 FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
 384
 385 : SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 ; inline
 386
 387 : WSAID_CONNECTEX ( -- GUID )
 388     "GUID" <c-object>
 389     HEX: 25a207b9 over set-GUID-Data1
 390     HEX: ddf3 over set-GUID-Data2
 391     HEX: 4660 over set-GUID-Data3
 392     B{
 393         HEX: 8e HEX: e9 HEX: 76 HEX: e5
 394         HEX: 8c HEX: 74 HEX: 06 HEX: 3e
 395     } over set-GUID-Data4 ;
 396
 397 : winsock-expected-error? ( n -- ? )
 398     ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
 399
 400 : (winsock-error-string) ( n -- str )
 401     ! #! WSAStartup returns the error code 'n' directly
 402     dup winsock-expected-error?
 403     [ drop f ] [ error_message utf16n alien>string ] if ;
 404
 405 : winsock-error-string ( -- string/f )
 406     WSAGetLastError (winsock-error-string) ;
 407
 408 : winsock-error ( -- )
 409     winsock-error-string [ throw ] when* ;
 410
 411 : winsock-error=0/f ( n/f -- )
 412     { 0 f } member? [
 413         winsock-error-string throw
 414     ] when ;
 415
 416 : winsock-error!=0/f ( n/f -- )
 417     { 0 f } member? [
 418         winsock-error-string throw
 419     ] unless ;
 420
 421 : winsock-return-check ( n/f -- )
 422     dup { 0 f } member? [
 423         drop
 424     ] [
 425         (winsock-error-string) throw
 426     ] if ;
 427
 428 : socket-error* ( n -- )
 429     SOCKET_ERROR = [
 430         WSAGetLastError
 431         dup WSA_IO_PENDING = [
 432             drop
 433         ] [
 434             (winsock-error-string) throw
 435         ] if
 436     ] when ;
 437
 438 : socket-error ( n -- )
 439     SOCKET_ERROR = [ winsock-error ] when ;
 440
 441 : init-winsock ( -- )
 442     HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
 443