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

   1 USING: alien alien.accessors alien.c-types alien.data byte-arrays
   2 continuations destructors io.ports io.timeouts io.sockets
   3 io.sockets.private io namespaces io.streams.duplex
   4 io.backend.windows io.sockets.windows io.backend.windows.nt
   5 windows.winsock kernel libc math sequences threads system
   6 combinators accessors classes.struct windows.kernel32 ;
   7 IN: io.sockets.windows.nt
   8
   9 : malloc-int ( n -- alien )
  10     <int> malloc-byte-array ; 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) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
 104     f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
 105
 106 : extract-remote-address ( AcceptEx -- sockaddr )
 107     [
 108         {
 109             [ lpOutputBuffer>> ]
 110             [ dwReceiveDataLength>> ]
 111             [ dwLocalAddressLength>> ]
 112             [ dwRemoteAddressLength>> ]
 113         } cleave
 114         (extract-remote-address)
 115     ] [ port>> addr>> protocol-family ] bi
 116     sockaddr-of-family ; inline
 117
 118 M: object (accept) ( server addr -- handle sockaddr )
 119     [
 120         <AcceptEx-args>
 121         {
 122             [ call-AcceptEx ]
 123             [ wait-for-socket drop ]
 124             [ sAcceptSocket>> <win32-socket> ]
 125             [ extract-remote-address ]
 126         } cleave
 127     ] with-destructors ;
 128
 129 TUPLE: WSARecvFrom-args port
 130        s lpBuffers dwBufferCount lpNumberOfBytesRecvd
 131        lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
 132
 133 : make-receive-buffer ( -- WSABUF )
 134     WSABUF malloc-struct &free
 135         default-buffer-size get
 136         [ >>len ] [ malloc &free >>buf ] bi ; inline
 137
 138 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
 139     WSARecvFrom-args new
 140         swap >>port
 141         dup port>> handle>> handle>> >>s
 142         dup port>> addr>> sockaddr-size
 143             [ malloc &free >>lpFrom ]
 144             [ malloc-int &free >>lpFromLen ] bi
 145         make-receive-buffer >>lpBuffers
 146         1 >>dwBufferCount
 147         0 malloc-int &free >>lpFlags
 148         0 malloc-int &free >>lpNumberOfBytesRecvd
 149         (make-overlapped) >>lpOverlapped ; inline
 150
 151 : call-WSARecvFrom ( WSARecvFrom -- )
 152     {
 153         [ s>> ]
 154         [ lpBuffers>> ]
 155         [ dwBufferCount>> ]
 156         [ lpNumberOfBytesRecvd>> ]
 157         [ lpFlags>> ]
 158         [ lpFrom>> ]
 159         [ lpFromLen>> ]
 160         [ lpOverlapped>> ]
 161         [ lpCompletionRoutine>> ]
 162     } cleave WSARecvFrom socket-error* ; inline
 163
 164 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
 165     [ lpBuffers>> buf>> swap memory>byte-array ]
 166     [
 167         [ port>> addr>> empty-sockaddr dup ]
 168         [ lpFrom>> ]
 169         [ lpFromLen>> *int ]
 170         tri memcpy
 171     ] bi ; inline
 172
 173 M: winnt (receive) ( datagram -- packet addrspec )
 174     [
 175         <WSARecvFrom-args>
 176         [ call-WSARecvFrom ]
 177         [ wait-for-socket ]
 178         [ parse-WSARecvFrom ]
 179         tri
 180     ] with-destructors ;
 181
 182 TUPLE: WSASendTo-args port
 183        s lpBuffers dwBufferCount lpNumberOfBytesSent
 184        dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
 185
 186 : make-send-buffer ( packet -- WSABUF )
 187     [ WSABUF malloc-struct &free ] dip
 188         [ malloc-byte-array &free >>buf ]
 189         [ length >>len ] bi ; inline
 190
 191 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
 192     WSASendTo-args new
 193         swap >>port
 194         dup port>> handle>> handle>> >>s
 195         swap make-sockaddr/size
 196             [ malloc-byte-array &free ] dip
 197             [ >>lpTo ] [ >>iToLen ] bi*
 198         swap make-send-buffer >>lpBuffers
 199         1 >>dwBufferCount
 200         0 >>dwFlags
 201         0 <uint> >>lpNumberOfBytesSent
 202         (make-overlapped) >>lpOverlapped ; inline
 203
 204 : call-WSASendTo ( WSASendTo -- )
 205     {
 206         [ s>> ]
 207         [ lpBuffers>> ]
 208         [ dwBufferCount>> ]
 209         [ lpNumberOfBytesSent>> ]
 210         [ dwFlags>> ]
 211         [ lpTo>> ]
 212         [ iToLen>> ]
 213         [ lpOverlapped>> ]
 214         [ lpCompletionRoutine>> ]
 215     } cleave WSASendTo socket-error* ; inline
 216
 217 M: winnt (send) ( packet addrspec datagram -- )
 218     [
 219         <WSASendTo-args>
 220         [ call-WSASendTo ]
 221         [ wait-for-socket drop ]
 222         bi
 223     ] with-destructors ;