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