basis/io/windows/nt/sockets/sockets.factor

   1 USING: alien alien.accessors alien.c-types byte-arrays
   2 continuations destructors io.ports io.timeouts io.sockets
   3 io.sockets io namespaces io.streams.duplex io.windows
   4 io.windows.sockets
   5 io.windows.nt.backend windows.winsock kernel libc math sequences
   6 threads classes.tuple.lib system combinators accessors ;
   7 IN: io.windows.nt.sockets
   8
   9 : malloc-int ( object -- object )
  10     "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
  11
  12 M: winnt WSASocket-flags ( -- DWORD )
  13     WSA_FLAG_OVERLAPPED ;
  14
  15 : get-ConnectEx-ptr ( socket -- void* )
  16     SIO_GET_EXTENSION_FUNCTION_POINTER
  17     WSAID_CONNECTEX
  18     "GUID" heap-size
  19     "void*" <c-object>
  20     [
  21         "void*" heap-size
  22         "DWORD" <c-object>
  23         f
  24         f
  25         WSAIoctl SOCKET_ERROR = [
  26             winsock-error-string throw
  27         ] when
  28     ] keep *void* ;
  29
  30 TUPLE: ConnectEx-args port
  31     s* name* namelen* lpSendBuffer* dwSendDataLength*
  32     lpdwBytesSent* lpOverlapped* ptr* ;
  33
  34 : wait-for-socket ( args -- n )
  35     [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
  36
  37 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
  38     ConnectEx-args new
  39         swap >>namelen*
  40         swap >>name*
  41         f >>lpSendBuffer*
  42         0 >>dwSendDataLength*
  43         f >>lpdwBytesSent*
  44         (make-overlapped) >>lpOverlapped* ;
  45
  46 : call-ConnectEx ( ConnectEx -- )
  47     ConnectEx-args >tuple*<
  48     "int"
  49     { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
  50     "stdcall" alien-indirect drop
  51     winsock-error-string [ throw ] when* ;
  52
  53 M: object establish-connection ( client-out remote -- )
  54     make-sockaddr/size <ConnectEx-args>
  55         swap >>port
  56         dup port>> handle>> handle>> >>s*
  57         dup s*>> get-ConnectEx-ptr >>ptr*
  58         dup call-ConnectEx
  59         wait-for-socket drop ;
  60
  61 TUPLE: AcceptEx-args port
  62     sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
  63     dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
  64
  65 : init-accept-buffer ( addr AcceptEx -- )
  66     swap sockaddr-type heap-size 16 +
  67         [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
  68         dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
  69         drop ;
  70
  71 : <AcceptEx-args> ( server addr -- AcceptEx )
  72     AcceptEx-args new
  73         2dup init-accept-buffer
  74         swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
  75         over handle>> handle>> >>sListenSocket*
  76         swap >>port
  77         0 >>dwReceiveDataLength*
  78         f >>lpdwBytesReceived*
  79         (make-overlapped) >>lpOverlapped* ;
  80
  81 : call-AcceptEx ( AcceptEx -- )
  82     AcceptEx-args >tuple*< AcceptEx drop
  83     winsock-error-string [ throw ] when* ;
  84
  85 : extract-remote-address ( AcceptEx -- sockaddr )
  86     {
  87         [ lpOutputBuffer*>> ]
  88         [ dwReceiveDataLength*>> ]
  89         [ dwLocalAddressLength*>> ]
  90         [ dwRemoteAddressLength*>> ]
  91     } cleave
  92     f <void*>
  93     0 <int>
  94     f <void*>
  95     [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
  96
  97 M: object (accept) ( server addr -- handle sockaddr )
  98     [
  99         <AcceptEx-args>
 100         {
 101             [ call-AcceptEx ]
 102             [ wait-for-socket drop ]
 103             [ sAcceptSocket*>> <win32-socket> ]
 104             [ extract-remote-address ]
 105         } cleave
 106     ] with-destructors ;
 107
 108 TUPLE: WSARecvFrom-args port
 109        s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
 110        lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
 111
 112 : make-receive-buffer ( -- WSABUF )
 113     "WSABUF" malloc-object &free
 114     default-buffer-size get over set-WSABUF-len
 115     default-buffer-size get malloc &free over set-WSABUF-buf ;
 116
 117 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
 118     WSARecvFrom-args new
 119         swap >>port
 120         dup port>> handle>> handle>> >>s*
 121         dup port>> addr>> sockaddr-type heap-size
 122             [ malloc &free >>lpFrom* ]
 123             [ malloc-int &free >>lpFromLen* ] bi
 124         make-receive-buffer >>lpBuffers*
 125         1 >>dwBufferCount*
 126         0 malloc-int &free >>lpFlags*
 127         0 malloc-int &free >>lpNumberOfBytesRecvd*
 128         (make-overlapped) >>lpOverlapped* ;
 129
 130 : call-WSARecvFrom ( WSARecvFrom -- )
 131     WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
 132
 133 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
 134     [ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
 135     [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
 136
 137 M: winnt (receive) ( datagram -- packet addrspec )
 138     [
 139         <WSARecvFrom-args>
 140         [ call-WSARecvFrom ]
 141         [ wait-for-socket ]
 142         [ parse-WSARecvFrom ]
 143         tri
 144     ] with-destructors ;
 145
 146 TUPLE: WSASendTo-args port
 147        s* lpBuffers* dwBufferCount* lpNumberOfBytesSent*
 148        dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
 149
 150 : make-send-buffer ( packet -- WSABUF )
 151     "WSABUF" malloc-object &free
 152     [ >r malloc-byte-array &free r> set-WSABUF-buf ]
 153     [ >r length r> set-WSABUF-len ]
 154     [ nip ]
 155     2tri ;
 156
 157 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
 158     WSASendTo-args new
 159         swap >>port
 160         dup port>> handle>> handle>> >>s*
 161         swap make-sockaddr/size
 162             >r malloc-byte-array &free
 163             r> [ >>lpTo* ] [ >>iToLen* ] bi*
 164         swap make-send-buffer >>lpBuffers*
 165         1 >>dwBufferCount*
 166         0 >>dwFlags*
 167         0 <uint> >>lpNumberOfBytesSent*
 168         (make-overlapped) >>lpOverlapped* ;
 169
 170 : call-WSASendTo ( WSASendTo -- )
 171     WSASendTo-args >tuple*< WSASendTo socket-error* ;
 172
 173 M: winnt (send) ( packet addrspec datagram -- )
 174     [
 175         <WSASendTo-args>
 176         [ call-WSASendTo ]
 177         [ wait-for-socket drop ]
 178         bi
 179     ] with-destructors ;