Skip to content

Commit 834e6ff

Browse files
Mistukekazu-yamamoto
Mistuke
authored and
kazu-yamamoto
committed
First implementation Windows msg
1 parent 4ae61a3 commit 834e6ff

File tree

12 files changed

+235
-38
lines changed

12 files changed

+235
-38
lines changed

‎Network/Socket.hs

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -192,12 +192,14 @@ module Network.Socket
192192
, socketPortSafe
193193
, socketPort
194194

195+
#if !defined(mingw32_HOST_OS)
195196
-- * UNIX-domain socket
196197
, isUnixDomainSocketAvailable
197198
, socketPair
198199
, sendFd
199200
, recvFd
200201
, getPeerCredential
202+
#endif
201203

202204
-- * Name information
203205
, getNameInfo
@@ -254,9 +256,13 @@ import Network.Socket.Info
254256
import Network.Socket.Internal
255257
import Network.Socket.Name hiding (getPeerName, getSocketName)
256258
import Network.Socket.Options
257-
import Network.Socket.Posix.Cmsg
258259
import Network.Socket.Shutdown
259260
import Network.Socket.SockAddr
260261
import Network.Socket.Syscall hiding (connect, bind, accept)
261262
import Network.Socket.Types
263+
#if !defined(mingw32_HOST_OS)
264+
import Network.Socket.Posix.Cmsg
262265
import Network.Socket.Unix
266+
#else
267+
import Network.Socket.Win32.Cmsg
268+
#endif

‎Network/Socket/Buffer.hsc

Lines changed: 12 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ module Network.Socket.Buffer (
1818
#if !defined(mingw32_HOST_OS)
1919
import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK)
2020
#else
21-
import System.Win32.Types
2221
import Foreign.Ptr (nullPtr)
2322
#endif
2423
import Foreign.Marshal.Alloc (alloca, allocaBytes)
@@ -43,6 +42,11 @@ import Network.Socket.Name
4342
import Network.Socket.Types
4443
import Network.Socket.Flag
4544

45+
#if defined(mingw32_HOST_OS)
46+
type DWORD = Word32
47+
type LPDWORD = Ptr DWORD
48+
#endif
49+
4650
-- | Send data to the socket. The recipient can be specified
4751
-- explicitly, so the socket need not be in a connected state.
4852
-- Returns the number of bytes sent. Applications are responsible for
@@ -230,7 +234,7 @@ sendBufMsg s sa bufsizs cmsgs flags = do
230234
c_sendmsg fd msgHdrPtr cflags
231235
#else
232236
alloca $ \send_ptr ->
233-
c_sendmsg fd msgHdrPtr cflags send_ptr nullPtr nullPtr
237+
c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr
234238
#endif
235239
return $ fromIntegral sz
236240

@@ -270,20 +274,20 @@ recvBufMsg s bufsizs clen flags = do
270274
_cflags = fromMsgFlag flags
271275
withFdSocket s $ \fd -> do
272276
with msgHdr $ \msgHdrPtr -> do
273-
len <- fromIntegral <$>
277+
len <- (fmap fromIntegral) <$>
274278
#if !defined(mingw32_HOST_OS)
275279
throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $
276280
c_recvmsg fd msgHdrPtr _cflags
277281
#else
278-
alloca $ \len_ptr ->
279-
throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $
280-
c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
281-
peek len_ptr :: IO DWORD
282+
alloca $ \len_ptr -> do
283+
_ <- throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $
284+
c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
285+
peek len_ptr
282286
#endif
283287
sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s
284288
hdr <- peek msgHdrPtr
285289
cmsgs <- parseCmsgs msgHdrPtr
286-
let flags' = MsgFlag $ msgFlags hdr
290+
let flags' = MsgFlag $ fromIntegral $ msgFlags hdr
287291
return (sockaddr, len, cmsgs, flags')
288292

289293
#if !defined(mingw32_HOST_OS)
@@ -303,8 +307,6 @@ foreign import CALLCONV SAFE_ON_WIN "sendmsg"
303307
c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
304308
foreign import CALLCONV SAFE_ON_WIN "recvmsg"
305309
c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
306-
307-
failIfSockError = failIf_ (==#{const SOCKET_ERROR})
308310
#endif
309311

310312
foreign import ccall unsafe "recv"

‎Network/Socket/ByteString/IO.hsc

Lines changed: 43 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -49,16 +49,22 @@ import Network.Socket.ByteString.Internal
4949
import Network.Socket.Imports
5050
import Network.Socket.Types
5151

52-
#if !defined(mingw32_HOST_OS)
5352
import Data.ByteString.Internal (create, ByteString(..))
5453
import Foreign.ForeignPtr (withForeignPtr)
5554
import Foreign.Marshal.Utils (with)
5655
import Network.Socket.Internal
5756

5857
import Network.Socket.Flag
58+
59+
#if !defined(mingw32_HOST_OS)
5960
import Network.Socket.Posix.Cmsg
6061
import Network.Socket.Posix.IOVec
6162
import Network.Socket.Posix.MsgHdr (MsgHdr(..))
63+
#else
64+
import Foreign.Marshal.Alloc (alloca)
65+
import Network.Socket.Win32.Cmsg
66+
import Network.Socket.Win32.WSABuf
67+
import Network.Socket.Win32.MsgHdr (MsgHdr(..))
6268
#endif
6369

6470
-- ----------------------------------------------------------------------------
@@ -130,21 +136,27 @@ sendAllTo s xs sa = do
130136
sendMany :: Socket -- ^ Connected socket
131137
-> [ByteString] -- ^ Data to send
132138
-> IO ()
133-
#if !defined(mingw32_HOST_OS)
134139
sendMany _ [] = return ()
135140
sendMany s cs = do
136141
sent <- sendManyInner
137142
waitWhen0 sent s
138143
when (sent >= 0) $ sendMany s $ remainingChunks sent cs
139144
where
140145
sendManyInner =
146+
#if !defined(mingw32_HOST_OS)
141147
fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) ->
142148
withFdSocket s $ \fd -> do
143149
let len = fromIntegral $ min iovsLen (#const IOV_MAX)
144150
throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $
145151
c_writev fd iovsPtr len
146152
#else
147-
sendMany s = sendAll s . B.concat
153+
fmap fromIntegral . withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) ->
154+
withFdSocket s $ \fd -> do
155+
let len = fromIntegral wsabsLen
156+
alloca $ \send_ptr -> do
157+
_ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $
158+
c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr
159+
peek send_ptr
148160
#endif
149161

150162
-- | Send data to the socket. The recipient can be specified
@@ -157,7 +169,6 @@ sendManyTo :: Socket -- ^ Socket
157169
-> [ByteString] -- ^ Data to send
158170
-> SockAddr -- ^ Recipient address
159171
-> IO ()
160-
#if !defined(mingw32_HOST_OS)
161172
sendManyTo _ [] _ = return ()
162173
sendManyTo s cs addr = do
163174
sent <- fromIntegral <$> sendManyToInner
@@ -166,6 +177,7 @@ sendManyTo s cs addr = do
166177
where
167178
sendManyToInner =
168179
withSockAddr addr $ \addrPtr addrSize ->
180+
#if !defined(mingw32_HOST_OS)
169181
withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> do
170182
let msgHdr = MsgHdr {
171183
msgName = addrPtr
@@ -181,7 +193,22 @@ sendManyTo s cs addr = do
181193
throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $
182194
c_sendmsg fd msgHdrPtr 0
183195
#else
184-
sendManyTo s cs = sendAllTo s (B.concat cs)
196+
withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> do
197+
let msgHdr = MsgHdr {
198+
msgName = addrPtr
199+
, msgNameLen = fromIntegral addrSize
200+
, msgBuffer = wsabsPtr
201+
, msgBufferLen = fromIntegral wsabsLen
202+
, msgCtrl = nullPtr
203+
, msgCtrlLen = 0
204+
, msgFlags = 0
205+
}
206+
withFdSocket s $ \fd ->
207+
with msgHdr $ \msgHdrPtr ->
208+
alloca $ \send_ptr -> do
209+
_ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $
210+
c_sendmsg fd msgHdrPtr 0 send_ptr nullPtr nullPtr
211+
peek send_ptr
185212
#endif
186213

187214
-- ----------------------------------------------------------------------------
@@ -224,7 +251,7 @@ recvFrom sock nbytes =
224251
-- ----------------------------------------------------------------------------
225252
-- Not exported
226253

227-
#if !defined(mingw32_HOST_OS)
254+
228255
-- | Suppose we try to transmit a list of chunks @cs@ via a gathering write
229256
-- operation and find that @n@ bytes were sent. Then @remainingChunks n cs@ is
230257
-- list of chunks remaining to be sent.
@@ -236,6 +263,7 @@ remainingChunks i (x:xs)
236263
where
237264
len = B.length x
238265

266+
#if !defined(mingw32_HOST_OS)
239267
-- | @withIOVecfromBS cs f@ executes the computation @f@, passing as argument a pair
240268
-- consisting of a pointer to a temporarily allocated array of pointers to
241269
-- IOVec made from @cs@ and the number of pointers (@length cs@).
@@ -244,6 +272,15 @@ withIOVecfromBS :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a
244272
withIOVecfromBS cs f = do
245273
bufsizs <- mapM getBufsiz cs
246274
withIOVec bufsizs f
275+
#else
276+
-- | @withWSABuffromBS cs f@ executes the computation @f@, passing as argument a pair
277+
-- consisting of a pointer to a temporarily allocated array of pointers to
278+
-- WSABuf made from @cs@ and the number of pointers (@length cs@).
279+
-- /Windows only/.
280+
withWSABuffromBS :: [ByteString] -> ((Ptr WSABuf, Int) -> IO a) -> IO a
281+
withWSABuffromBS cs f = do
282+
bufsizs <- mapM getBufsiz cs
283+
withWSABuf bufsizs f
247284
#endif
248285

249286
getBufsiz :: ByteString -> IO (Ptr Word8, Int)

‎Network/Socket/ByteString/Internal.hs

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,11 +14,15 @@ module Network.Socket.ByteString.Internal
1414
mkInvalidRecvArgError
1515
#if !defined(mingw32_HOST_OS)
1616
, c_writev
17+
#else
18+
, c_wsasend
19+
#endif
1720
, c_sendmsg
1821
, c_recvmsg
19-
#endif
2022
) where
2123

24+
#include "HsNetDef.h"
25+
2226
import GHC.IO.Exception (IOErrorType(..))
2327
import System.IO.Error (ioeSetErrorString, mkIOError)
2428

@@ -29,6 +33,17 @@ import Network.Socket.Imports
2933
import Network.Socket.Posix.IOVec (IOVec)
3034
import Network.Socket.Posix.MsgHdr (MsgHdr)
3135
import Network.Socket.Types
36+
#else
37+
import Data.Word
38+
import Foreign.C.Types
39+
import Foreign.Ptr
40+
41+
import Network.Socket.Win32.WSABuf (WSABuf)
42+
import Network.Socket.Win32.MsgHdr (MsgHdr)
43+
import Network.Socket.Types
44+
45+
type DWORD = Word32
46+
type LPDWORD = Ptr DWORD
3247
#endif
3348

3449
mkInvalidRecvArgError :: String -> IOError
@@ -45,4 +60,12 @@ foreign import ccall unsafe "sendmsg"
4560

4661
foreign import ccall unsafe "recvmsg"
4762
c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
63+
#else
64+
-- fixme Handle for SOCKET, see #426
65+
foreign import CALLCONV SAFE_ON_WIN "wsasend"
66+
c_wsasend :: CInt -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
67+
foreign import CALLCONV SAFE_ON_WIN "sendmsg"
68+
c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
69+
foreign import CALLCONV SAFE_ON_WIN "recvmsg"
70+
c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
4871
#endif

‎Network/Socket/SockAddr.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
module Network.Socket.SockAddr (
23
getPeerName
34
, getSocketName
@@ -15,7 +16,11 @@ import qualified Network.Socket.Name as G
1516
import qualified Network.Socket.Syscall as G
1617
import Network.Socket.Flag
1718
import Network.Socket.Imports
19+
#if !defined(mingw32_HOST_OS)
1820
import Network.Socket.Posix.Cmsg
21+
#else
22+
import Network.Socket.Win32.Cmsg
23+
#endif
1924
import Network.Socket.Types
2025

2126
-- | Getting peer's 'SockAddr'.

‎Network/Socket/Win32/Cmsg.hsc

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -10,11 +10,13 @@ module Network.Socket.Win32.Cmsg where
1010
import Data.ByteString.Internal
1111
import Foreign.ForeignPtr
1212
import System.IO.Unsafe (unsafeDupablePerformIO)
13-
import System.Win32.Types (HANDLE)
1413

1514
import Network.Socket.Imports
1615
import Network.Socket.Types
1716

17+
type DWORD = Word32
18+
type ULONG = Word32
19+
1820
-- | Control message (ancillary data) including a pair of level and type.
1921
data Cmsg = Cmsg {
2022
cmsgId :: !CmsgId
@@ -133,15 +135,15 @@ instance ControlMessage IPv6TClass where
133135
data IPv4PktInfo = IPv4PktInfo ULONG HostAddress deriving (Eq)
134136

135137
instance Show IPv4PktInfo where
136-
show (IPv4PktInfo n sa ha) = "IPv4PktInfo " ++ show n ++ " " ++ show (hostAddressToTuple ha)
138+
show (IPv4PktInfo n ha) = "IPv4PktInfo " ++ show n ++ " " ++ show (hostAddressToTuple ha)
137139

138140
instance ControlMessage IPv4PktInfo where
139141
controlMessageId _ = CmsgIdIPv4PktInfo
140142

141143
instance Storable IPv4PktInfo where
142-
sizeOf _ = const #{size IN_PKTINFO}
144+
sizeOf = const #{size IN_PKTINFO}
143145
alignment _ = #alignment IN_PKTINFO
144-
poke p (IPv4PktInfo n sa ha) = do
146+
poke p (IPv4PktInfo n ha) = do
145147
(#poke IN_PKTINFO, ipi_ifindex) p (fromIntegral n :: CInt)
146148
(#poke IN_PKTINFO, ipi_addr) p ha
147149
peek p = do
@@ -161,7 +163,7 @@ instance ControlMessage IPv6PktInfo where
161163
controlMessageId _ = CmsgIdIPv6PktInfo
162164

163165
instance Storable IPv6PktInfo where
164-
sizeOf _ = const #{size IN6_PKTINFO}
166+
sizeOf = const #{size IN6_PKTINFO}
165167
alignment _ = #alignment IN6_PKTINFO
166168
poke p (IPv6PktInfo n ha6) = do
167169
(#poke IN6_PKTINFO, ipi6_ifindex) p (fromIntegral n :: CInt)

‎Network/Socket/Win32/CmsgHdr.hsc

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,16 +18,14 @@ import Network.Socket.Win32.Cmsg
1818
import Network.Socket.Win32.MsgHdr
1919
import Network.Socket.Types
2020

21-
import System.Win32.Types
22-
2321
data CmsgHdr = CmsgHdr {
2422
cmsgHdrLen :: !CUInt
2523
, cmsgHdrLevel :: !CInt
2624
, cmsgHdrType :: !CInt
2725
} deriving (Eq, Show)
2826

2927
instance Storable CmsgHdr where
30-
sizeOf _ = const #{size WSACMSGHDR}
28+
sizeOf = const #{size WSACMSGHDR}
3129
alignment _ = #alignment WSACMSGHDR
3230

3331
peek p = do

‎Network/Socket/Win32/MsgHdr.hsc

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,19 @@
11
{-# OPTIONS_GHC -funbox-strict-fields #-}
2+
{-# LANGUAGE CPP #-}
23

34
-- | Support module for the Windows 'WSASendMsg' system call.
45
module Network.Socket.Win32.MsgHdr
56
( MsgHdr(..)
67
) where
78

9+
#include "HsNet.h"
10+
811
import Network.Socket.Imports
912
import Network.Socket.Internal (zeroMemory)
1013
import Network.Socket.Win32.WSABuf
1114

12-
import System.Win32.Types
15+
type DWORD = Word32
16+
type ULONG = Word32
1317

1418
-- The size of BufferLen is different on pre-vista compilers.
1519
-- But since those platforms are out of support anyway we ignore that.
@@ -18,13 +22,13 @@ data MsgHdr sa = MsgHdr
1822
, msgNameLen :: !CInt
1923
, msgBuffer :: !(Ptr WSABuf)
2024
, msgBufferLen :: !DWORD
21-
, msgCtr :: !(Ptr Word8)
22-
, msgCtrLen :: !ULONG
25+
, msgCtrl :: !(Ptr Word8)
26+
, msgCtrlLen :: !ULONG
2327
, msgFlags :: !DWORD
2428
}
2529

2630
instance Storable (MsgHdr sa) where
27-
sizeOf _ = const #{size WSAMSG}
31+
sizeOf = const #{size WSAMSG}
2832
alignment _ = #alignment WSAMSG
2933

3034
peek p = do

0 commit comments

Comments
 (0)