basis/io/sockets/windows/windows.factor

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