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