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