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