|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 3 | +{-# LANGUAGE PatternSynonyms #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 5 | + |
| 6 | +module Network.Socket.Win32.Cmsg where |
| 7 | + |
| 8 | +#include "HsNet.h" |
| 9 | + |
| 10 | +import Data.ByteString.Internal |
| 11 | +import Foreign.ForeignPtr |
| 12 | +import System.IO.Unsafe (unsafeDupablePerformIO) |
| 13 | +import System.Win32.Types (HANDLE) |
| 14 | + |
| 15 | +import Network.Socket.Imports |
| 16 | +import Network.Socket.Types |
| 17 | + |
| 18 | +-- | Control message (ancillary data) including a pair of level and type. |
| 19 | +data Cmsg = Cmsg { |
| 20 | + cmsgId :: !CmsgId |
| 21 | + , cmsgData :: !ByteString |
| 22 | + } deriving (Eq, Show) |
| 23 | + |
| 24 | +---------------------------------------------------------------- |
| 25 | + |
| 26 | +-- | Identifier of control message (ancillary data). |
| 27 | +data CmsgId = CmsgId { |
| 28 | + cmsgLevel :: !CInt |
| 29 | + , cmsglType :: !CInt |
| 30 | + } deriving (Eq, Show) |
| 31 | + |
| 32 | +-- | The identifier for 'IPv4TTL'. |
| 33 | +pattern CmsgIdIPv4TTL :: CmsgId |
| 34 | +pattern CmsgIdIPv4TTL = CmsgId (#const IPPROTO_IP) (#const IP_TTL) |
| 35 | + |
| 36 | +-- | The identifier for 'IPv6HopLimit'. |
| 37 | +pattern CmsgIdIPv6HopLimit :: CmsgId |
| 38 | +pattern CmsgIdIPv6HopLimit = CmsgId (#const IPPROTO_IPV6) (#const IPV6_HOPLIMIT) |
| 39 | + |
| 40 | +-- | The identifier for 'IPv4TOS'. |
| 41 | +pattern CmsgIdIPv4TOS :: CmsgId |
| 42 | +pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_RECVTOS) |
| 43 | + |
| 44 | +-- | The identifier for 'IPv6TClass'. |
| 45 | +pattern CmsgIdIPv6TClass :: CmsgId |
| 46 | +pattern CmsgIdIPv6TClass = CmsgId (#const IPPROTO_IPV6) (#const IPV6_RECVTCLASS) |
| 47 | + |
| 48 | +-- | The identifier for 'IPv4PktInfo'. |
| 49 | +pattern CmsgIdIPv4PktInfo :: CmsgId |
| 50 | +pattern CmsgIdIPv4PktInfo = CmsgId (#const IPPROTO_IP) (#const IP_PKTINFO) |
| 51 | + |
| 52 | +-- | The identifier for 'IPv6PktInfo'. |
| 53 | +pattern CmsgIdIPv6PktInfo :: CmsgId |
| 54 | +pattern CmsgIdIPv6PktInfo = CmsgId (#const IPPROTO_IPV6) (#const IPV6_PKTINFO) |
| 55 | + |
| 56 | +-- Use WSADuplicateSocket for CmsgIdFd |
| 57 | +-- pattern CmsgIdFd :: CmsgId |
| 58 | + |
| 59 | +---------------------------------------------------------------- |
| 60 | + |
| 61 | +-- | Looking up control message. The following shows an example usage: |
| 62 | +-- |
| 63 | +-- > (lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS |
| 64 | +lookupCmsg :: CmsgId -> [Cmsg] -> Maybe Cmsg |
| 65 | +lookupCmsg _ [] = Nothing |
| 66 | +lookupCmsg cid (cmsg:cmsgs) |
| 67 | + | cmsgId cmsg == cid = Just cmsg |
| 68 | + | otherwise = lookupCmsg cid cmsgs |
| 69 | + |
| 70 | +-- | Filtering control message. |
| 71 | +filterCmsg :: CmsgId -> [Cmsg] -> [Cmsg] |
| 72 | +filterCmsg cid cmsgs = filter (\cmsg -> cmsgId cmsg == cid) cmsgs |
| 73 | + |
| 74 | +---------------------------------------------------------------- |
| 75 | + |
| 76 | +-- | A class to encode and decode control message. |
| 77 | +class Storable a => ControlMessage a where |
| 78 | + controlMessageId :: a -> CmsgId |
| 79 | + |
| 80 | +encodeCmsg :: ControlMessage a => a -> Cmsg |
| 81 | +encodeCmsg x = unsafeDupablePerformIO $ do |
| 82 | + bs <- create siz $ \p0 -> do |
| 83 | + let p = castPtr p0 |
| 84 | + poke p x |
| 85 | + return $ Cmsg (controlMessageId x) bs |
| 86 | + where |
| 87 | + siz = sizeOf x |
| 88 | + |
| 89 | +decodeCmsg :: forall a . Storable a => Cmsg -> Maybe a |
| 90 | +decodeCmsg (Cmsg _ (PS fptr off len)) |
| 91 | + | len < siz = Nothing |
| 92 | + | otherwise = unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do |
| 93 | + let p = castPtr (p0 `plusPtr` off) |
| 94 | + Just <$> peek p |
| 95 | + where |
| 96 | + siz = sizeOf (undefined :: a) |
| 97 | + |
| 98 | +---------------------------------------------------------------- |
| 99 | + |
| 100 | +-- | Time to live of IPv4. |
| 101 | +newtype IPv4TTL = IPv4TTL DWORD deriving (Eq, Show, Storable) |
| 102 | + |
| 103 | +instance ControlMessage IPv4TTL where |
| 104 | + controlMessageId _ = CmsgIdIPv4TTL |
| 105 | + |
| 106 | +---------------------------------------------------------------- |
| 107 | + |
| 108 | +-- | Hop limit of IPv6. |
| 109 | +newtype IPv6HopLimit = IPv6HopLimit DWORD deriving (Eq, Show, Storable) |
| 110 | + |
| 111 | +instance ControlMessage IPv6HopLimit where |
| 112 | + controlMessageId _ = CmsgIdIPv6HopLimit |
| 113 | + |
| 114 | +---------------------------------------------------------------- |
| 115 | + |
| 116 | +-- | TOS of IPv4. |
| 117 | +newtype IPv4TOS = IPv4TOS DWORD deriving (Eq, Show, Storable) |
| 118 | + |
| 119 | +instance ControlMessage IPv4TOS where |
| 120 | + controlMessageId _ = CmsgIdIPv4TOS |
| 121 | + |
| 122 | +---------------------------------------------------------------- |
| 123 | + |
| 124 | +-- | Traffic class of IPv6. |
| 125 | +newtype IPv6TClass = IPv6TClass DWORD deriving (Eq, Show, Storable) |
| 126 | + |
| 127 | +instance ControlMessage IPv6TClass where |
| 128 | + controlMessageId _ = CmsgIdIPv6TClass |
| 129 | + |
| 130 | +---------------------------------------------------------------- |
| 131 | + |
| 132 | +-- | Network interface ID and local IPv4 address. |
| 133 | +data IPv4PktInfo = IPv4PktInfo ULONG HostAddress deriving (Eq) |
| 134 | + |
| 135 | +instance Show IPv4PktInfo where |
| 136 | + show (IPv4PktInfo n sa ha) = "IPv4PktInfo " ++ show n ++ " " ++ show (hostAddressToTuple ha) |
| 137 | + |
| 138 | +instance ControlMessage IPv4PktInfo where |
| 139 | + controlMessageId _ = CmsgIdIPv4PktInfo |
| 140 | + |
| 141 | +instance Storable IPv4PktInfo where |
| 142 | + sizeOf _ = const #{size IN_PKTINFO} |
| 143 | + alignment _ = #alignment IN_PKTINFO |
| 144 | + poke p (IPv4PktInfo n sa ha) = do |
| 145 | + (#poke IN_PKTINFO, ipi_ifindex) p (fromIntegral n :: CInt) |
| 146 | + (#poke IN_PKTINFO, ipi_addr) p ha |
| 147 | + peek p = do |
| 148 | + n <- (#peek IN_PKTINFO, ipi_ifindex) p |
| 149 | + ha <- (#peek IN_PKTINFO, ipi_addr) p |
| 150 | + return $ IPv4PktInfo n ha |
| 151 | + |
| 152 | +---------------------------------------------------------------- |
| 153 | + |
| 154 | +-- | Network interface ID and local IPv4 address. |
| 155 | +data IPv6PktInfo = IPv6PktInfo Int HostAddress6 deriving (Eq) |
| 156 | + |
| 157 | +instance Show IPv6PktInfo where |
| 158 | + show (IPv6PktInfo n ha6) = "IPv6PktInfo " ++ show n ++ " " ++ show (hostAddress6ToTuple ha6) |
| 159 | + |
| 160 | +instance ControlMessage IPv6PktInfo where |
| 161 | + controlMessageId _ = CmsgIdIPv6PktInfo |
| 162 | + |
| 163 | +instance Storable IPv6PktInfo where |
| 164 | + sizeOf _ = const #{size IN6_PKTINFO} |
| 165 | + alignment _ = #alignment IN6_PKTINFO |
| 166 | + poke p (IPv6PktInfo n ha6) = do |
| 167 | + (#poke IN6_PKTINFO, ipi6_ifindex) p (fromIntegral n :: CInt) |
| 168 | + (#poke IN6_PKTINFO, ipi6_addr) p (In6Addr ha6) |
| 169 | + peek p = do |
| 170 | + In6Addr ha6 <- (#peek IN6_PKTINFO, ipi6_addr) p |
| 171 | + n :: ULONG <- (#peek IN6_PKTINFO, ipi6_ifindex) p |
| 172 | + return $ IPv6PktInfo (fromIntegral n) ha6 |
0 commit comments