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