basis/io/sockets/windows/windows.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors alien alien.c-types alien.data alien.strings
   5 byte-arrays classes.struct combinators destructors io.backend
   6 io.encodings.ascii io.files.windows io.ports io.sockets
   7 io.sockets.icmp io.sockets.private kernel libc locals math
   8 sequences system windows.errors windows.handles windows.kernel32
   9 windows.types windows.winsock ;
  10
  11 FROM: namespaces => get ;
  12 IN: io.sockets.windows
  13
  14 : set-socket-option ( handle level opt -- )
  15     [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;
  16
  17 : set-ioctl-socket ( handle cmd arg -- )
  18     [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;
  19
  20 M: windows addrinfo-error-string ( n -- string )
  21     n>win32-error-string ;
  22
  23 M: windows sockaddr-of-family ( alien af -- addrspec )
  24     {
  25         { AF_INET [ sockaddr-in memory>struct ] }
  26         { AF_INET6 [ sockaddr-in6 memory>struct ] }
  27         [ 2drop f ]
  28     } case ;
  29
  30 M: windows addrspec-of-family ( af -- addrspec )
  31     {
  32         { AF_INET [ T{ ipv4 } ] }
  33         { AF_INET6 [ T{ ipv6 } ] }
  34         [ drop f ]
  35     } case ;
  36
  37 TUPLE: win32-socket < win32-file ;
  38
  39 : <win32-socket> ( handle -- win32-socket )
  40     win32-socket new-win32-handle ;
  41
  42 M: win32-socket dispose* ( stream -- )
  43     handle>> closesocket socket-error* ;
  44
  45 : unspecific-sockaddr/size ( addrspec -- sockaddr len )
  46     [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;
  47
  48 : opened-socket ( handle -- win32-socket )
  49     <win32-socket> |dispose add-completion ;
  50
  51 : open-socket ( addrspec type -- win32-socket )
  52     [ drop protocol-family ] [ swap protocol ] 2bi
  53     f 0 WSA_FLAG_OVERLAPPED WSASocket
  54     dup socket-error
  55     opened-socket ;
  56
  57 M: object (get-local-address) ( socket addrspec -- sockaddr )
  58     [ handle>> ] dip empty-sockaddr/size int <ref>
  59     [ getsockname socket-error ] keepd ;
  60
  61 M: object (get-remote-address) ( socket addrspec -- sockaddr )
  62     [ handle>> ] dip empty-sockaddr/size int <ref>
  63     [ getpeername socket-error ] keepd ;
  64
  65 : bind-socket ( win32-socket sockaddr len -- )
  66     [ handle>> ] 2dip bind socket-error ;
  67
  68 M: object remote>handle ( addrspec -- handle )
  69     [ SOCK_STREAM open-socket ] keep
  70     [
  71         bind-local-address get
  72         [ nip make-sockaddr/size ]
  73         [ unspecific-sockaddr/size ] if* bind-socket
  74     ] [ drop ] 2bi ;
  75
  76 : server-socket ( addrspec type -- fd )
  77     [ open-socket ] [ drop ] 2bi
  78     [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
  79
  80 ! http://support.microsoft.com/kb/127144
  81 ! NOTE: Possibly tweak this because of SYN flood attacks
  82 : listen-backlog ( -- n ) 0x7fffffff ; inline
  83
  84 M: object (server) ( addrspec -- handle )
  85     [
  86         SOCK_STREAM server-socket
  87         dup handle>> listen-backlog listen winsock-return-check
  88     ] with-destructors ;
  89
  90 M: windows (datagram) ( addrspec -- handle )
  91     [ SOCK_DGRAM server-socket ] with-destructors ;
  92
  93 M: windows (raw) ( addrspec -- handle )
  94     [ SOCK_RAW server-socket ] with-destructors ;
  95
  96 M: windows (broadcast) ( datagram -- datagram )
  97     dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
  98
  99 : malloc-int ( n -- alien )
 100     int <ref> malloc-byte-array ; inline
 101
 102 : get-ConnectEx-ptr ( socket -- void* )
 103     SIO_GET_EXTENSION_FUNCTION_POINTER
 104     WSAID_CONNECTEX
 105     GUID heap-size
 106     { void* }
 107     [
 108         void* heap-size
 109         0 DWORD <ref>
 110         f
 111         f
 112         WSAIoctl SOCKET_ERROR = [
 113             maybe-winsock-exception throw
 114         ] when
 115     ] with-out-parameters ;
 116
 117 TUPLE: ConnectEx-args port
 118     s name namelen lpSendBuffer dwSendDataLength
 119     lpdwBytesSent lpOverlapped ptr ;
 120
 121 : wait-for-socket ( args -- count )
 122     [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
 123
 124 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
 125     ConnectEx-args new
 126         swap >>namelen
 127         swap >>name
 128         f >>lpSendBuffer
 129         0 >>dwSendDataLength
 130         f >>lpdwBytesSent
 131         (make-overlapped) >>lpOverlapped ; inline
 132
 133 : call-ConnectEx ( ConnectEx -- )
 134     {
 135         [ s>> ]
 136         [ name>> ]
 137         [ namelen>> ]
 138         [ lpSendBuffer>> ]
 139         [ dwSendDataLength>> ]
 140         [ lpdwBytesSent>> ]
 141         [ lpOverlapped>> ]
 142         [ ptr>> ]
 143     } cleave
 144     int
 145     { SOCKET void* int PVOID DWORD LPDWORD void* }
 146     stdcall alien-indirect drop
 147     winsock-error ; inline
 148
 149 M: object establish-connection ( client-out remote -- )
 150     make-sockaddr/size-outgoing <ConnectEx-args>
 151         swap >>port
 152         dup port>> handle>> handle>> >>s
 153         dup s>> get-ConnectEx-ptr >>ptr
 154         dup call-ConnectEx
 155         wait-for-socket drop ;
 156
 157 TUPLE: AcceptEx-args port
 158     sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
 159     dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
 160
 161 : init-accept-buffer ( addr AcceptEx -- )
 162     swap sockaddr-size 16 +
 163         [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
 164         dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
 165         drop ; inline
 166
 167 : <AcceptEx-args> ( server addr -- AcceptEx )
 168     AcceptEx-args new
 169         2dup init-accept-buffer
 170         swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
 171         over handle>> handle>> >>sListenSocket
 172         swap >>port
 173         0 >>dwReceiveDataLength
 174         f >>lpdwBytesReceived
 175         (make-overlapped) >>lpOverlapped ; inline
 176
 177 ! AcceptEx return value is useless
 178 : call-AcceptEx ( AcceptEx -- )
 179     {
 180         [ sListenSocket>> ]
 181         [ sAcceptSocket>> ]
 182         [ lpOutputBuffer>> ]
 183         [ dwReceiveDataLength>> ]
 184         [ dwLocalAddressLength>> ]
 185         [ dwRemoteAddressLength>> ]
 186         [ lpdwBytesReceived>> ]
 187         [ lpOverlapped>> ]
 188     } cleave AcceptEx drop winsock-error ; inline
 189
 190 : (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
 191     f void* <ref> 0 int <ref> f void* <ref>
 192     [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
 193
 194 : extract-remote-address ( AcceptEx -- sockaddr )
 195     [
 196         {
 197             [ lpOutputBuffer>> ]
 198             [ dwReceiveDataLength>> ]
 199             [ dwLocalAddressLength>> ]
 200             [ dwRemoteAddressLength>> ]
 201         } cleave
 202         (extract-remote-address)
 203     ] [ port>> addr>> protocol-family ] bi
 204     sockaddr-of-family ; inline
 205
 206 M: object (accept) ( server addr -- handle sockaddr )
 207     [
 208         <AcceptEx-args>
 209         {
 210             [ call-AcceptEx ]
 211             [ wait-for-socket drop ]
 212             [ sAcceptSocket>> <win32-socket> ]
 213             [ extract-remote-address ]
 214         } cleave
 215     ] with-destructors ;
 216
 217 TUPLE: WSARecvFrom-args port
 218        s lpBuffers dwBufferCount lpNumberOfBytesRecvd
 219        lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
 220
 221 :: make-receive-buffer ( n buf -- buf' WSABUF )
 222     buf >c-ptr pinned-alien?
 223     [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'
 224     buf'
 225     WSABUF malloc-struct &free
 226         n >>len
 227         buf' >>buf ; inline
 228
 229 :: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )
 230     n buf make-receive-buffer :> ( buf' wsaBuf )
 231     buf buf'
 232     WSARecvFrom-args new
 233         datagram >>port
 234         datagram handle>> handle>> >>s
 235         datagram addr>> sockaddr-size
 236             [ malloc &free >>lpFrom ]
 237             [ malloc-int &free >>lpFromLen ] bi
 238         wsaBuf >>lpBuffers
 239         1 >>dwBufferCount
 240         0 malloc-int &free >>lpFlags
 241         0 malloc-int &free >>lpNumberOfBytesRecvd
 242         (make-overlapped) >>lpOverlapped ; inline
 243
 244 : call-WSARecvFrom ( WSARecvFrom -- )
 245     {
 246         [ s>> ]
 247         [ lpBuffers>> ]
 248         [ dwBufferCount>> ]
 249         [ lpNumberOfBytesRecvd>> ]
 250         [ lpFlags>> ]
 251         [ lpFrom>> ]
 252         [ lpFromLen>> ]
 253         [ lpOverlapped>> ]
 254         [ lpCompletionRoutine>> ]
 255     } cleave WSARecvFrom socket-error* ; inline
 256
 257 :: finalize-buf ( buf buf' count -- )
 258     buf buf' eq? [ buf buf' count memcpy ] unless ; inline
 259
 260 :: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )
 261     buf buf' count finalize-buf
 262     count wsaRecvFrom
 263     [ port>> addr>> empty-sockaddr dup ]
 264     [ lpFrom>> ]
 265     [ lpFromLen>> int deref ]
 266     tri memcpy ; inline
 267
 268 M: windows (receive-unsafe) ( n buf datagram -- count addrspec )
 269     [
 270         <WSARecvFrom-args>
 271         [ call-WSARecvFrom ]
 272         [ wait-for-socket ]
 273         [ parse-WSARecvFrom ]
 274         tri
 275     ] with-destructors ;
 276
 277 TUPLE: WSASendTo-args port
 278        s lpBuffers dwBufferCount lpNumberOfBytesSent
 279        dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
 280
 281 : make-send-buffer ( packet -- WSABUF )
 282     [ WSABUF malloc-struct &free ] dip
 283         [ malloc-byte-array &free >>buf ]
 284         [ length >>len ] bi ; inline
 285
 286 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
 287     WSASendTo-args new
 288         swap >>port
 289         dup port>> handle>> handle>> >>s
 290         swap make-sockaddr/size-outgoing
 291             [ malloc-byte-array &free ] dip
 292             [ >>lpTo ] [ >>iToLen ] bi*
 293         swap make-send-buffer >>lpBuffers
 294         1 >>dwBufferCount
 295         0 >>dwFlags
 296         0 uint <ref> >>lpNumberOfBytesSent
 297         (make-overlapped) >>lpOverlapped ; inline
 298
 299 : call-WSASendTo ( WSASendTo -- )
 300     {
 301         [ s>> ]
 302         [ lpBuffers>> ]
 303         [ dwBufferCount>> ]
 304         [ lpNumberOfBytesSent>> ]
 305         [ dwFlags>> ]
 306         [ lpTo>> ]
 307         [ iToLen>> ]
 308         [ lpOverlapped>> ]
 309         [ lpCompletionRoutine>> ]
 310     } cleave WSASendTo socket-error* ; inline
 311
 312 M: windows (send) ( packet addrspec datagram -- )
 313     [
 314         <WSASendTo-args>
 315         [ call-WSASendTo ]
 316         [ wait-for-socket drop ]
 317         bi
 318     ] with-destructors ;
 319
 320 M: windows host-name
 321     256 [ <byte-array> dup ] keep gethostname socket-error
 322     ascii alien>string ;