1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# OPTIONS_GHC -funbox-strict-fields #-}
#include "HsNet.h"
module Network.Socket.Win32.CmsgHdr (
Cmsg(..)
, withCmsgs
, parseCmsgs
) where
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.ForeignPtr
import qualified Data.ByteString as B
import Data.ByteString.Internal
import Network.Socket.Imports
import Network.Socket.Win32.Cmsg
import Network.Socket.Win32.MsgHdr
import Network.Socket.Types
data CmsgHdr = CmsgHdr {
cmsgHdrLen :: !CUInt
, cmsgHdrLevel :: !CInt
, cmsgHdrType :: !CInt
} deriving (Eq, Show)
instance Storable CmsgHdr where
sizeOf _ = #{size WSACMSGHDR}
alignment _ = #alignment WSACMSGHDR
peek p = do
len <- (#peek WSACMSGHDR, cmsg_len) p
lvl <- (#peek WSACMSGHDR, cmsg_level) p
typ <- (#peek WSACMSGHDR, cmsg_type) p
return $ CmsgHdr len lvl typ
poke p (CmsgHdr len lvl typ) = do
zeroMemory p (#size WSACMSGHDR)
(#poke WSACMSGHDR, cmsg_len) p len
(#poke WSACMSGHDR, cmsg_level) p lvl
(#poke WSACMSGHDR, cmsg_type) p typ
withCmsgs :: [Cmsg] -> (Ptr CmsgHdr -> Int -> IO a) -> IO a
withCmsgs cmsgs0 action
| total == 0 = action nullPtr 0
| otherwise = allocaBytes total $ \ctrlPtr -> do
loop ctrlPtr cmsgs0 spaces
action ctrlPtr total
where
loop ctrlPtr (cmsg:cmsgs) (s:ss) = do
toCmsgHdr cmsg ctrlPtr
let nextPtr = ctrlPtr `plusPtr` s
loop nextPtr cmsgs ss
loop _ _ _ = return ()
cmsg_space = fromIntegral . c_cmsg_space . fromIntegral
spaces = map (cmsg_space . B.length . cmsgData) cmsgs0
total = sum spaces
toCmsgHdr :: Cmsg -> Ptr CmsgHdr -> IO ()
toCmsgHdr (Cmsg (CmsgId lvl typ) (PS fptr off len)) ctrlPtr = do
poke ctrlPtr $ CmsgHdr (c_cmsg_len (fromIntegral len)) lvl typ
withForeignPtr fptr $ \src0 -> do
let src = src0 `plusPtr` off
dst <- c_cmsg_data ctrlPtr
memcpy dst src len
parseCmsgs :: SocketAddress sa => Ptr (MsgHdr sa) -> IO [Cmsg]
parseCmsgs msgptr = do
ptr <- c_cmsg_firsthdr msgptr
loop ptr id
where
loop ptr build
| ptr == nullPtr = return $ build []
| otherwise = do
val <- fromCmsgHdr ptr
case val of
Nothing -> return $ build []
Just cmsg -> do
nextPtr <- c_cmsg_nxthdr msgptr ptr
loop nextPtr (build . (cmsg :))
fromCmsgHdr :: Ptr CmsgHdr -> IO (Maybe Cmsg)
fromCmsgHdr ptr = do
CmsgHdr len lvl typ <- peek ptr
src <- c_cmsg_data ptr
let siz = fromIntegral len - (src `minusPtr` ptr)
if siz < 0
then return Nothing
else Just . Cmsg (CmsgId lvl typ) <$> create (fromIntegral siz) (\dst -> memcpy dst src siz)
foreign import ccall unsafe "cmsg_firsthdr"
c_cmsg_firsthdr :: Ptr (MsgHdr sa) -> IO (Ptr CmsgHdr)
foreign import ccall unsafe "cmsg_nxthdr"
c_cmsg_nxthdr :: Ptr (MsgHdr sa) -> Ptr CmsgHdr -> IO (Ptr CmsgHdr)
foreign import ccall unsafe "cmsg_data"
c_cmsg_data :: Ptr CmsgHdr -> IO (Ptr Word8)
foreign import ccall unsafe "cmsg_space"
c_cmsg_space :: CUInt -> CUInt
foreign import ccall unsafe "cmsg_len"
c_cmsg_len :: CUInt -> CUInt
|
