extra/io/windows/nt/sockets/sockets.factor

   1 USING: alien alien.c-types byte-arrays continuations destructors
   2 io.nonblocking io io.sockets io.sockets.impl
   3 io.streams.duplex io.windows io.windows.nt io.windows.nt.backend
   4 windows.winsock kernel libc math sequences threads tuples.lib ;
   5 IN: io.windows.nt.sockets
   6
   7 : malloc-int ( object -- object )
   8     "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
   9
  10 M: windows-nt-io WSASocket-flags ( -- DWORD )
  11     WSA_FLAG_OVERLAPPED ;
  12
  13 : get-ConnectEx-ptr ( socket -- void* )
  14     SIO_GET_EXTENSION_FUNCTION_POINTER
  15     WSAID_CONNECTEX
  16     "GUID" heap-size
  17     "void*" <c-object>
  18     [
  19         "void*" heap-size
  20         "DWORD" <c-object>
  21         f
  22         f
  23         WSAIoctl SOCKET_ERROR = [
  24             winsock-error-string throw
  25         ] when
  26     ] keep *void* ;
  27
  28 TUPLE: ConnectEx-args port
  29     s* name* namelen* lpSendBuffer* dwSendDataLength*
  30     lpdwBytesSent* lpOverlapped* ptr* ;
  31
  32 : init-connect ( sockaddr sockaddr-name ConnectEx -- )
  33     >r heap-size r>
  34     [ set-ConnectEx-args-namelen* ] keep
  35     [ set-ConnectEx-args-name* ] keep
  36     f over set-ConnectEx-args-lpSendBuffer*
  37     0 over set-ConnectEx-args-dwSendDataLength*
  38     f over set-ConnectEx-args-lpdwBytesSent*
  39     (make-overlapped) swap set-ConnectEx-args-lpOverlapped* ;
  40
  41 : (ConnectEx) ( ConnectEx -- )
  42     \ ConnectEx-args >tuple*<
  43     "int"
  44     { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
  45     "stdcall" alien-indirect drop
  46     winsock-error-string [ throw ] when* ;
  47
  48 : check-connect-error ( ConnectEx -- )
  49     ConnectEx-args-port duplex-stream-in get-overlapped-result drop ;
  50
  51 : connect-continuation ( duplex-stream ConnectEx -- )
  52     [ ConnectEx-args-port duplex-stream-in save-callback ] keep
  53     check-connect-error ;
  54
  55 M: windows-nt-io (client) ( addrspec -- duplex-stream )
  56     [
  57         \ ConnectEx-args construct-empty
  58         over make-sockaddr pick init-connect
  59         over tcp-socket over set-ConnectEx-args-s*
  60         dup ConnectEx-args-s* add-completion
  61         dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
  62         dup ConnectEx-args-s* INADDR_ANY roll bind-socket
  63         dup (ConnectEx)
  64
  65         dup ConnectEx-args-s* <win32-socket> dup handle>duplex-stream
  66         over set-ConnectEx-args-port
  67
  68         [
  69             dup ConnectEx-args-lpOverlapped*
  70             swap ConnectEx-args-port duplex-stream-in set-port-overlapped
  71         ] keep
  72         dup connect-continuation
  73         ConnectEx-args-port
  74         [ duplex-stream-in pending-error ] keep
  75         [ duplex-stream-out pending-error ] keep
  76     ] with-destructors ;
  77
  78 TUPLE: AcceptEx-args port
  79     sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
  80     dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
  81
  82 : init-accept-buffer ( server-port AcceptEx -- )
  83     >r server-port-addr sockaddr-type heap-size 16 +
  84     dup dup 2 * malloc dup [ free ] t add-destructor r>
  85     [ set-AcceptEx-args-lpOutputBuffer* ] keep
  86     [ set-AcceptEx-args-dwLocalAddressLength* ] keep
  87     set-AcceptEx-args-dwRemoteAddressLength* ;
  88
  89 : init-accept ( server-port AcceptEx -- )
  90     [ init-accept-buffer ] 2keep
  91     [ set-AcceptEx-args-port ] 2keep
  92     >r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep
  93     dup AcceptEx-args-port server-port-addr tcp-socket
  94     over set-AcceptEx-args-sAcceptSocket*
  95     0 over set-AcceptEx-args-dwReceiveDataLength*
  96     f over set-AcceptEx-args-lpdwBytesReceived*
  97     (make-overlapped) over set-AcceptEx-args-lpOverlapped*
  98     dup AcceptEx-args-lpOverlapped* swap AcceptEx-args-port set-port-overlapped ;
  99
 100 : (accept) ( AcceptEx -- )
 101     \ AcceptEx-args >tuple*<
 102     AcceptEx drop
 103     winsock-error-string [ throw ] when* ;
 104
 105 : make-accept-continuation ( AcceptEx -- )
 106     AcceptEx-args-port save-callback ;
 107
 108 : check-accept-error ( AcceptEx -- )
 109     AcceptEx-args-port get-overlapped-result drop ;
 110
 111 : extract-remote-host ( AcceptEx -- addrspec )
 112     [
 113         [ AcceptEx-args-lpOutputBuffer* ] keep
 114         [ AcceptEx-args-dwReceiveDataLength* ] keep
 115         [ AcceptEx-args-dwLocalAddressLength* ] keep
 116         AcceptEx-args-dwRemoteAddressLength*
 117         f <void*>
 118         0 <int>
 119         f <void*> [
 120             0 <int> GetAcceptExSockaddrs
 121         ] keep *void*
 122     ] keep AcceptEx-args-port server-port-addr parse-sockaddr ;
 123
 124 : accept-continuation ( AcceptEx -- client )
 125     [ make-accept-continuation ] keep
 126     [ check-accept-error ] keep
 127     [ extract-remote-host ] keep
 128     ! addrspec AcceptEx
 129     [
 130         AcceptEx-args-sAcceptSocket* add-completion
 131     ] keep
 132     AcceptEx-args-sAcceptSocket* <win32-socket> dup handle>duplex-stream
 133     <client-stream> ;
 134
 135 M: windows-nt-io accept ( server -- client )
 136     [
 137         dup check-server-port
 138         dup touch-port
 139         \ AcceptEx-args construct-empty
 140         [ init-accept ] keep
 141         [ (accept) ] keep
 142         [ accept-continuation ] keep
 143         AcceptEx-args-port pending-error
 144         dup duplex-stream-in pending-error
 145         dup duplex-stream-out pending-error
 146     ] with-destructors ;
 147
 148 M: windows-nt-io <server> ( addrspec -- server )
 149     [
 150         [
 151             SOCK_STREAM server-fd dup listen-on-socket
 152             dup add-completion
 153             <win32-socket> f <port>
 154         ] keep <server-port>
 155     ] with-destructors ;
 156
 157
 158 M: windows-nt-io <datagram> ( addrspec -- datagram )
 159     [
 160         [
 161             SOCK_DGRAM server-fd
 162             dup add-completion
 163             <win32-socket> f <port>
 164         ] keep <datagram-port>
 165     ] with-destructors ;
 166
 167 TUPLE: WSARecvFrom-args port
 168        s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
 169        lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
 170
 171 : init-WSARecvFrom ( datagram WSARecvFrom -- )
 172     [ set-WSARecvFrom-args-port ] 2keep
 173     [
 174         >r delegate port-handle delegate win32-file-handle r>
 175         set-WSARecvFrom-args-s*
 176     ] 2keep [
 177         >r datagram-port-addr sockaddr-type heap-size r>
 178         2dup >r malloc dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFrom*
 179         >r malloc-int dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFromLen*
 180     ] keep
 181     "WSABUF" malloc-object dup [ free ] t add-destructor
 182     2dup swap set-WSARecvFrom-args-lpBuffers*
 183     default-buffer-size [ malloc dup [ free ] t add-destructor ] keep
 184     pick set-WSABUF-len
 185     swap set-WSABUF-buf
 186     1 over set-WSARecvFrom-args-dwBufferCount*
 187     0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpFlags*
 188     0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
 189     (make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
 190     swap WSARecvFrom-args-port set-port-overlapped ;
 191
 192 : make-WSARecvFrom-continuation ( WSARecvFrom -- )
 193     WSARecvFrom-args-port save-callback ;
 194
 195 : call-WSARecvFrom ( WSARecvFrom -- )
 196     \ WSARecvFrom-args >tuple*<
 197     WSARecvFrom
 198     socket-error* ;
 199
 200 : WSARecvFrom-continuation ( WSARecvFrom -- n )
 201     [ make-WSARecvFrom-continuation ] keep
 202     WSARecvFrom-args-port get-overlapped-result ;
 203
 204 : parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec )
 205     [
 206         WSARecvFrom-args-lpBuffers* WSABUF-buf
 207         swap memory>string >byte-array
 208     ] keep
 209     [ WSARecvFrom-args-lpFrom* ] keep
 210     WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
 211
 212 M: windows-nt-io receive ( datagram -- packet addrspec )
 213     [
 214         dup check-datagram-port
 215         \ WSARecvFrom-args construct-empty
 216         [ init-WSARecvFrom ] keep
 217         [ call-WSARecvFrom ] keep
 218         [ WSARecvFrom-continuation ] keep
 219         [ WSARecvFrom-args-port pending-error ] keep
 220         parse-WSARecvFrom
 221     ] with-destructors ;
 222
 223 TUPLE: WSASendTo-args port
 224        s* lpBuffers* dwBufferCount* lpNumberOfBytesSent*
 225        dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
 226
 227 : init-WSASendTo ( packet addrspec datagram WSASendTo -- )
 228     [ set-WSASendTo-args-port ] 2keep
 229     [
 230         >r delegate port-handle delegate win32-file-handle r>
 231         set-WSASendTo-args-s*
 232     ] keep [
 233         >r make-sockaddr >r
 234         malloc-byte-array dup [ free ] t add-destructor
 235         r> heap-size r>
 236         [ set-WSASendTo-args-iToLen* ] keep
 237         set-WSASendTo-args-lpTo*
 238     ] keep [
 239         "WSABUF" malloc-object dup [ free ] t add-destructor
 240         dup rot set-WSASendTo-args-lpBuffers*
 241         swap [ malloc-byte-array dup [ free ] t add-destructor ] keep length
 242         rot [ set-WSABUF-len ] keep
 243         set-WSABUF-buf
 244     ] keep
 245     1 over set-WSASendTo-args-dwBufferCount*
 246     0 over set-WSASendTo-args-dwFlags*
 247     (make-overlapped) [ over set-WSASendTo-args-lpOverlapped* ] keep
 248     swap WSASendTo-args-port set-port-overlapped ;
 249
 250 : make-WSASendTo-continuation ( WSASendTo -- )
 251     WSASendTo-args-port save-callback ;
 252
 253 : WSASendTo-continuation ( WSASendTo -- )
 254     [ make-WSASendTo-continuation ] keep
 255     WSASendTo-args-port get-overlapped-result drop ;
 256
 257 : call-WSASendTo ( WSASendTo -- )
 258     \ WSASendTo-args >tuple*<
 259     WSASendTo socket-error* ;
 260
 261 M: windows-nt-io send ( packet addrspec datagram -- )
 262     [
 263         3dup check-datagram-send
 264         \ WSASendTo-args construct-empty
 265         [ init-WSASendTo ] keep
 266         [ call-WSASendTo ] keep
 267         [ WSASendTo-continuation ] keep
 268         WSASendTo-args-port pending-error
 269     ] with-destructors ;
 270