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