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

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