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