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