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 locals ;\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 ) 0x7fffffff ; 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: windows 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         0 DWORD <ref>\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 -- count )\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* <ref> 0 int <ref> f void* <ref>\r
 185     [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
 186 \r
 187 : extract-remote-address ( AcceptEx -- sockaddr )\r
 188     [\r
 189         {\r
 190             [ lpOutputBuffer>> ]\r
 191             [ dwReceiveDataLength>> ]\r
 192             [ dwLocalAddressLength>> ]\r
 193             [ dwRemoteAddressLength>> ]\r
 194         } cleave\r
 195         (extract-remote-address)\r
 196     ] [ port>> addr>> protocol-family ] bi\r
 197     sockaddr-of-family ; inline\r
 198 \r
 199 M: object (accept) ( server addr -- handle sockaddr )\r
 200     [\r
 201         <AcceptEx-args>\r
 202         {\r
 203             [ call-AcceptEx ]\r
 204             [ wait-for-socket drop ]\r
 205             [ sAcceptSocket>> <win32-socket> ]\r
 206             [ extract-remote-address ]\r
 207         } cleave\r
 208     ] with-destructors ;\r
 209 \r
 210 TUPLE: WSARecvFrom-args port\r
 211        s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
 212        lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
 213 \r
 214 :: make-receive-buffer ( n buf -- buf' WSABUF )\r
 215     buf >c-ptr pinned-alien?\r
 216     [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'\r
 217     buf'\r
 218     WSABUF malloc-struct &free\r
 219         n >>len\r
 220         buf' >>buf ; inline\r
 221 \r
 222 :: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )\r
 223     n buf make-receive-buffer :> ( buf' wsaBuf )\r
 224     buf buf'\r
 225     WSARecvFrom-args new\r
 226         datagram >>port\r
 227         datagram handle>> handle>> >>s\r
 228         datagram addr>> sockaddr-size\r
 229             [ malloc &free >>lpFrom ]\r
 230             [ malloc-int &free >>lpFromLen ] bi\r
 231         wsaBuf >>lpBuffers\r
 232         1 >>dwBufferCount\r
 233         0 malloc-int &free >>lpFlags\r
 234         0 malloc-int &free >>lpNumberOfBytesRecvd\r
 235         (make-overlapped) >>lpOverlapped ; inline\r
 236 \r
 237 : call-WSARecvFrom ( WSARecvFrom -- )\r
 238     {\r
 239         [ s>> ]\r
 240         [ lpBuffers>> ]\r
 241         [ dwBufferCount>> ]\r
 242         [ lpNumberOfBytesRecvd>> ]\r
 243         [ lpFlags>> ]\r
 244         [ lpFrom>> ]\r
 245         [ lpFromLen>> ]\r
 246         [ lpOverlapped>> ]\r
 247         [ lpCompletionRoutine>> ]\r
 248     } cleave WSARecvFrom socket-error* ; inline\r
 249 \r
 250 :: finalize-buf ( buf buf' count -- )\r
 251     buf buf' eq? [ buf buf' count memcpy ] unless ; inline\r
 252 \r
 253 :: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )\r
 254     buf buf' count finalize-buf\r
 255     count wsaRecvFrom\r
 256     [ port>> addr>> empty-sockaddr dup ]\r
 257     [ lpFrom>> ]\r
 258     [ lpFromLen>> int deref ]\r
 259     tri memcpy ; inline\r
 260 \r
 261 M: windows (receive-unsafe) ( n buf datagram -- count addrspec )\r
 262     [\r
 263         <WSARecvFrom-args>\r
 264         [ call-WSARecvFrom ]\r
 265         [ wait-for-socket ]\r
 266         [ parse-WSARecvFrom ]\r
 267         tri\r
 268     ] with-destructors ;\r
 269 \r
 270 TUPLE: WSASendTo-args port\r
 271        s lpBuffers dwBufferCount lpNumberOfBytesSent\r
 272        dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
 273 \r
 274 : make-send-buffer ( packet -- WSABUF )\r
 275     [ WSABUF malloc-struct &free ] dip\r
 276         [ malloc-byte-array &free >>buf ]\r
 277         [ length >>len ] bi ; inline\r
 278 \r
 279 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
 280     WSASendTo-args new\r
 281         swap >>port\r
 282         dup port>> handle>> handle>> >>s\r
 283         swap make-sockaddr/size\r
 284             [ malloc-byte-array &free ] dip\r
 285             [ >>lpTo ] [ >>iToLen ] bi*\r
 286         swap make-send-buffer >>lpBuffers\r
 287         1 >>dwBufferCount\r
 288         0 >>dwFlags\r
 289         0 uint <ref> >>lpNumberOfBytesSent\r
 290         (make-overlapped) >>lpOverlapped ; inline\r
 291 \r
 292 : call-WSASendTo ( WSASendTo -- )\r
 293     {\r
 294         [ s>> ]\r
 295         [ lpBuffers>> ]\r
 296         [ dwBufferCount>> ]\r
 297         [ lpNumberOfBytesSent>> ]\r
 298         [ dwFlags>> ]\r
 299         [ lpTo>> ]\r
 300         [ iToLen>> ]\r
 301         [ lpOverlapped>> ]\r
 302         [ lpCompletionRoutine>> ]\r
 303     } cleave WSASendTo socket-error* ; inline\r
 304 \r
 305 M: windows (send) ( packet addrspec datagram -- )\r
 306     [\r
 307         <WSASendTo-args>\r
 308         [ call-WSASendTo ]\r
 309         [ wait-for-socket drop ]\r
 310         bi\r
 311     ] with-destructors ;\r