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