{-# LINE 1 "src/System/Linux/RTNetlink/Address.hsc" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module System.Linux.RTNetlink.Address
( IfInetAddress(..)
, IfInet6Address(..)
, IfIndex(..)
, IfPrefix(..)
, IfScope(..)
, IfLabel(..)
, Precedence(..)
, DuplicateAddressDetection(..)
, DuplicateAddressDetectionFlags(..)
, Mip6Homing(..)
, Preference(..)
, Permanence(..)
, PrefixRoute(..)
, MulticastAutoJoin(..)
, IfSeconds(..)
, IfLifetime(..)
, AnyInterface(..)
, IfAddrMsg(..)
, InetAddress
, inetAddressFromTuple
, inetAddressToTuple
, Inet6Address
, inet6AddressFromTuple
, inet6AddressToTuple
) where
import Control.Applicative ((<$>), (<*>))
import Control.Exception (throw)
import Control.Monad (guard, when)
import Data.Bits ((.&.))
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, (<>))
import Data.Serialize (Serialize, Get, Putter, get, put, runPut)
import Data.Serialize (getWord32host, putWord32host, getWord8)
import Data.Serialize (putWord8, getWord16be, putWord16be)
import Data.String (IsString)
import Data.Word (Word8, Word32)
import System.Socket.Family.Inet (InetAddress, inetAddressToTuple)
import System.Socket.Family.Inet (inetAddressFromTuple)
import System.Socket.Family.Inet6 (Inet6Address, inet6AddressToTuple)
import System.Socket.Family.Inet6 (inet6AddressFromTuple)
import qualified Data.ByteString.Char8 as S
import qualified Foreign.C.Error as C
import System.Linux.RTNetlink.Message
import System.Linux.RTNetlink.Packet
import System.Linux.RTNetlink.Util
putInetAddress :: Putter InetAddress
putInetAddress i = putWord8 a >> putWord8 b >> putWord8 c >> putWord8 d
where (a,b,c,d) = inetAddressToTuple i
getInetAddress :: Get InetAddress
getInetAddress = inetAddressFromTuple <$> getTuple
where getTuple = (,,,) <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8
instance Message InetAddress where
type MessageHeader InetAddress = IfAddrMsg
messageAttrs address = AttributeList
[ Attribute 2 ipv4
{-# LINE 88 "src/System/Linux/RTNetlink/Address.hsc" #-}
, Attribute 1 ipv4
{-# LINE 89 "src/System/Linux/RTNetlink/Address.hsc" #-}
] where ipv4 = runPut $ putInetAddress address
instance Reply InetAddress where
type ReplyHeader InetAddress = IfAddrMsg
fromNLMessage NLMessage {..} = do
guard $ (addrFamily nlmHeader) == 2
{-# LINE 94 "src/System/Linux/RTNetlink/Address.hsc" #-}
findAttributeGet getInetAddress [1] nlmAttrs
{-# LINE 95 "src/System/Linux/RTNetlink/Address.hsc" #-}
putInet6Address :: Putter Inet6Address
putInet6Address i = mapM_ putWord16be [a,b,c,d,e,f,g,h]
where (a,b,c,d,e,f,g,h) = inet6AddressToTuple i
getInet6Address :: Get Inet6Address
getInet6Address = inet6AddressFromTuple <$> getTuple
where
getTuple = (,,,,,,,)
<$> getWord16be
<*> getWord16be
<*> getWord16be
<*> getWord16be
<*> getWord16be
<*> getWord16be
<*> getWord16be
<*> getWord16be
instance Message Inet6Address where
type MessageHeader Inet6Address = IfAddrMsg
messageAttrs address = AttributeList
[ Attribute 2 ipv6
{-# LINE 119 "src/System/Linux/RTNetlink/Address.hsc" #-}
, Attribute 1 ipv6
{-# LINE 120 "src/System/Linux/RTNetlink/Address.hsc" #-}
] where ipv6 = runPut $ putInet6Address address
instance Reply Inet6Address where
type ReplyHeader Inet6Address = IfAddrMsg
fromNLMessage NLMessage {..} = do
guard $ (addrFamily nlmHeader) == 10
{-# LINE 125 "src/System/Linux/RTNetlink/Address.hsc" #-}
findAttributeGet getInet6Address [1] nlmAttrs
{-# LINE 126 "src/System/Linux/RTNetlink/Address.hsc" #-}
data AnyInterface = AnyInterface
deriving (Show, Eq)
instance Message AnyInterface where
type MessageHeader AnyInterface = IfAddrMsg
messageAttrs AnyInterface = mempty
instance Request AnyInterface where
requestNLFlags = dumpMany
newtype IfIndex = IfIndex {ifIndex :: Int}
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
instance Message IfIndex where
type MessageHeader IfIndex = IfAddrMsg
messageHeaderParts (IfIndex ix) = [IfAddrMsgIndex $ fromIntegral ix]
instance Reply IfIndex where
type ReplyHeader IfIndex = IfAddrMsg
fromNLMessage = Just . IfIndex . fromIntegral . addrIndex . nlmHeader
newtype IfPrefix = IfPrefix Word8
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
instance Message IfPrefix where
type MessageHeader IfPrefix = IfAddrMsg
messageHeaderParts (IfPrefix p) = [IfAddrMsgPrefix p]
instance Reply IfPrefix where
type ReplyHeader IfPrefix = IfAddrMsg
fromNLMessage = Just . fromIntegral . addrPrefix . nlmHeader
data Precedence = Primary | Secondary
deriving (Show, Eq)
instance Reply Precedence where
type ReplyHeader Precedence = IfAddrMsg
fromNLMessage m = Just $
if (addrFlags . nlmHeader) m .&. 1 == 0
{-# LINE 170 "src/System/Linux/RTNetlink/Address.hsc" #-}
then Primary
else Secondary
data DuplicateAddressDetection = DadEnabled | DadDisabled
deriving (Show, Eq)
instance Reply DuplicateAddressDetection where
type ReplyHeader DuplicateAddressDetection = IfAddrMsg
fromNLMessage m = Just $
if (addrFlags . nlmHeader) m .&. 2 == 0
{-# LINE 183 "src/System/Linux/RTNetlink/Address.hsc" #-}
then DadEnabled
else DadDisabled
instance Message DuplicateAddressDetection where
type MessageHeader DuplicateAddressDetection = IfAddrMsg
messageHeaderParts d =
[ IfAddrMsgFlags $ ChangeFlags
{ cfFlags = if d == DadEnabled then 0 else 2
{-# LINE 190 "src/System/Linux/RTNetlink/Address.hsc" #-}
, cfMask = 2
{-# LINE 191 "src/System/Linux/RTNetlink/Address.hsc" #-}
}
]
messageAttrs d = AttributeList [ word32AttrPart 8 f m ]
{-# LINE 194 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
f = if d == DadEnabled then 0 else 2
{-# LINE 196 "src/System/Linux/RTNetlink/Address.hsc" #-}
m = 2
{-# LINE 197 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance (Create c, MessageHeader c ~ IfAddrMsg)
=> Create (c, DuplicateAddressDetection)
instance (Create c, MessageHeader c ~ IfAddrMsg)
=> Create (DuplicateAddressDetection, c)
data DuplicateAddressDetectionFlags = DuplicateAddressDetectionFlags
{ dadOptimistic :: Bool
, dadTentative :: Bool
, dadFailed :: Bool
} deriving (Show, Eq)
instance Reply DuplicateAddressDetectionFlags where
type ReplyHeader DuplicateAddressDetectionFlags = IfAddrMsg
fromNLMessage m = Just $ DuplicateAddressDetectionFlags
{ dadOptimistic = flags .&. 4 /= 0
{-# LINE 219 "src/System/Linux/RTNetlink/Address.hsc" #-}
, dadTentative = flags .&. 64 /= 0
{-# LINE 220 "src/System/Linux/RTNetlink/Address.hsc" #-}
, dadFailed = flags .&. 8 /= 0
{-# LINE 221 "src/System/Linux/RTNetlink/Address.hsc" #-}
} where flags = addrFlags $ nlmHeader m
data Mip6Homing = Home | NotHome deriving (Show, Eq)
instance Reply Mip6Homing where
type ReplyHeader Mip6Homing = IfAddrMsg
fromNLMessage m = Just $
if (addrFlags . nlmHeader) m .&. 16 == 0
{-# LINE 230 "src/System/Linux/RTNetlink/Address.hsc" #-}
then Home
else NotHome
instance Message Mip6Homing where
type MessageHeader Mip6Homing = IfAddrMsg
messageHeaderParts h =
[ IfAddrMsgFlags $ ChangeFlags
{ cfFlags = if h == NotHome then 0 else 16
{-# LINE 237 "src/System/Linux/RTNetlink/Address.hsc" #-}
, cfMask = 16
{-# LINE 238 "src/System/Linux/RTNetlink/Address.hsc" #-}
}
]
messageAttrs h = AttributeList [ word32AttrPart 8 f m ]
{-# LINE 241 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
f = if h == Home then 16 else 0
{-# LINE 243 "src/System/Linux/RTNetlink/Address.hsc" #-}
m = 16
{-# LINE 244 "src/System/Linux/RTNetlink/Address.hsc" #-}
data Preference = Prefered | Deprecated deriving (Show, Eq)
instance Reply Preference where
type ReplyHeader Preference = IfAddrMsg
fromNLMessage m = Just $
if (addrFlags . nlmHeader) m .&. 32 == 0
{-# LINE 252 "src/System/Linux/RTNetlink/Address.hsc" #-}
then Prefered
else Deprecated
data Permanence = Permanent | Dynamic deriving (Show, Eq)
instance Reply Permanence where
type ReplyHeader Permanence = IfAddrMsg
fromNLMessage m = Just $
if (addrFlags . nlmHeader) m .&. 128 == 0
{-# LINE 262 "src/System/Linux/RTNetlink/Address.hsc" #-}
then Dynamic
else Permanent
data PrefixRoute = PREnabled | PRDisabled
deriving (Show, Eq)
instance Reply PrefixRoute where
type ReplyHeader PrefixRoute = IfAddrMsg
fromNLMessage m = Just . fromMaybe PREnabled $ do
f <- findAttributeGet getWord32host [8] $ nlmAttrs m
{-# LINE 273 "src/System/Linux/RTNetlink/Address.hsc" #-}
return $ if f .&. 512 == (0::Word32)
{-# LINE 274 "src/System/Linux/RTNetlink/Address.hsc" #-}
then PREnabled
else PRDisabled
instance Message PrefixRoute where
type MessageHeader PrefixRoute = IfAddrMsg
messageAttrs h = AttributeList [ word32AttrPart 8 f m ]
{-# LINE 279 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
f = if h == PREnabled then 0 else 512
{-# LINE 281 "src/System/Linux/RTNetlink/Address.hsc" #-}
m = 512
{-# LINE 282 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, PrefixRoute)
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (PrefixRoute, c)
data MulticastAutoJoin = AutoJoin | NoAutoJoin
deriving (Show, Eq)
instance Reply MulticastAutoJoin where
type ReplyHeader MulticastAutoJoin = IfAddrMsg
fromNLMessage m = Just . fromMaybe NoAutoJoin $ do
f <- findAttributeGet getWord32host [8] $ nlmAttrs m
{-# LINE 293 "src/System/Linux/RTNetlink/Address.hsc" #-}
return $ if f .&. 1024 == (0::Word32)
{-# LINE 294 "src/System/Linux/RTNetlink/Address.hsc" #-}
then NoAutoJoin
else AutoJoin
instance Message MulticastAutoJoin where
type MessageHeader MulticastAutoJoin = IfAddrMsg
messageAttrs h = AttributeList [ word32AttrPart 8 f m ]
{-# LINE 299 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
f = if h == NoAutoJoin then 0 else 1024
{-# LINE 301 "src/System/Linux/RTNetlink/Address.hsc" #-}
m = 1024
{-# LINE 302 "src/System/Linux/RTNetlink/Address.hsc" #-}
data IfSeconds = IfSeconds Word32 | IfForever deriving (Show, Eq)
instance Ord IfSeconds where
IfSeconds s `compare` IfSeconds t = s `compare` t
IfForever `compare` _ = GT
_ `compare` IfForever = LT
instance Serialize IfSeconds where
put (IfSeconds s) = putWord32host s
put IfForever = putWord32host oneBits
get = getWord32host >>= \s ->
return $ if s == oneBits then IfForever else IfSeconds s
data IfLifetime = IfLifetime
{ ifPrefered :: IfSeconds
, ifValid :: IfSeconds
} deriving (Show, Eq)
instance Reply IfLifetime where
type ReplyHeader IfLifetime = IfAddrMsg
fromNLMessage = Just . fromMaybe (IfLifetime IfForever IfForever)
. findAttributeGet getLifetime [6] . nlmAttrs
{-# LINE 325 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
secsFromWord32 s = if s == oneBits then IfForever else IfSeconds s
getLifetime = IfLifetime
<$> get
<*> get
<* getWord32host
<* getWord32host
instance Message IfLifetime where
type MessageHeader IfLifetime = IfAddrMsg
messageAttrs l = AttributeList [Attribute 6 cacheinfo]
{-# LINE 335 "src/System/Linux/RTNetlink/Address.hsc" #-}
where
cacheinfo = runPut $ do
when (ifPrefered l > ifValid l) . throw $
userError "prefered lifetime must not be greater than valid lifetime"
put $ ifPrefered l
put $ ifValid l
putWord32host 0
putWord32host 0
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfLifetime)
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfLifetime, c)
data IfScope
= IfUniverse
| IfUserScope Word8
| IfSite
| IfLink
| IfHost
| IfNowhere
deriving (Show, Eq)
instance Reply IfScope where
type ReplyHeader IfScope = IfAddrMsg
fromNLMessage = Just . toScope . addrScope . nlmHeader
where
toScope 0 = IfUniverse
{-# LINE 367 "src/System/Linux/RTNetlink/Address.hsc" #-}
toScope 200 = IfSite
{-# LINE 368 "src/System/Linux/RTNetlink/Address.hsc" #-}
toScope 253 = IfLink
{-# LINE 369 "src/System/Linux/RTNetlink/Address.hsc" #-}
toScope 254 = IfHost
{-# LINE 370 "src/System/Linux/RTNetlink/Address.hsc" #-}
toScope 255 = IfNowhere
{-# LINE 371 "src/System/Linux/RTNetlink/Address.hsc" #-}
toScope n = IfUserScope n
instance Message IfScope where
type MessageHeader IfScope = IfAddrMsg
messageHeaderParts = (:[]) . IfAddrMsgScope . fromScope
where
fromScope IfUniverse = 0
{-# LINE 377 "src/System/Linux/RTNetlink/Address.hsc" #-}
fromScope (IfUserScope n) = n
fromScope IfSite = 200
{-# LINE 379 "src/System/Linux/RTNetlink/Address.hsc" #-}
fromScope IfLink = 253
{-# LINE 380 "src/System/Linux/RTNetlink/Address.hsc" #-}
fromScope IfHost = 254
{-# LINE 381 "src/System/Linux/RTNetlink/Address.hsc" #-}
fromScope IfNowhere = 255
{-# LINE 382 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfScope)
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfScope, c)
newtype IfLabel = IfLabel S.ByteString
deriving (Show, Eq, IsString)
instance Reply IfLabel where
type ReplyHeader IfLabel = IfAddrMsg
fromNLMessage NLMessage {..} = IfLabel
<$> findAttributeCString [3] nlmAttrs
{-# LINE 393 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance Message IfLabel where
type MessageHeader IfLabel = IfAddrMsg
messageAttrs (IfLabel bs) = AttributeList
[ cStringAttr 3 $ S.take 16 bs ]
{-# LINE 397 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfLabel)
instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfLabel, c)
data IfInetAddress = IfInetAddress
{ ifInetAddress :: InetAddress
, ifInetPrefix :: IfPrefix
, ifInetIfIndex :: IfIndex
} deriving (Show, Eq)
instance Message IfInetAddress where
type MessageHeader IfInetAddress = IfAddrMsg
messageAttrs IfInetAddress {..} = messageAttrs ifInetAddress
messageHeaderParts IfInetAddress {..} =
[ IfAddrMsgFamily 2
{-# LINE 411 "src/System/Linux/RTNetlink/Address.hsc" #-}
, IfAddrMsgPrefix $ fromIntegral ifInetPrefix
, IfAddrMsgIndex . fromIntegral $ ifIndex ifInetIfIndex
]
instance Create IfInetAddress
instance Destroy IfInetAddress
instance Reply IfInetAddress where
type ReplyHeader IfInetAddress = IfAddrMsg
fromNLMessage m = do
guard $ (addrFamily . nlmHeader) m == 2
{-# LINE 420 "src/System/Linux/RTNetlink/Address.hsc" #-}
IfInetAddress <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m
data IfInet6Address = IfInet6Address
{ ifInet6Address :: Inet6Address
, ifInet6Prefix :: IfPrefix
, ifInet6IfIndex :: IfIndex
} deriving (Show, Eq)
instance Message IfInet6Address where
type MessageHeader IfInet6Address = IfAddrMsg
messageAttrs IfInet6Address {..} = messageAttrs ifInet6Address
messageHeaderParts IfInet6Address {..} =
[ IfAddrMsgFamily 10
{-# LINE 433 "src/System/Linux/RTNetlink/Address.hsc" #-}
, IfAddrMsgPrefix $ fromIntegral ifInet6Prefix
, IfAddrMsgIndex . fromIntegral $ ifIndex ifInet6IfIndex
]
instance Create IfInet6Address
instance Destroy IfInet6Address
instance Reply IfInet6Address where
type ReplyHeader IfInet6Address = IfAddrMsg
fromNLMessage m = do
guard $ (addrFamily . nlmHeader) m == 10
{-# LINE 442 "src/System/Linux/RTNetlink/Address.hsc" #-}
IfInet6Address <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m
data IfAddrMsg = IfAddrMsg
{ addrFamily :: Word8
, addrPrefix :: Word8
, addrFlags :: Word8
, addrScope :: Word8
, addrIndex :: Word32
} deriving (Show, Eq)
instance Sized IfAddrMsg where
size = const 8
{-# LINE 455 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance Serialize IfAddrMsg where
put IfAddrMsg {..} = do
putWord8 addrFamily
putWord8 addrPrefix
putWord8 addrFlags
putWord8 addrScope
putWord32host addrIndex
get = IfAddrMsg
<$> getWord8
<*> getWord8
<*> getWord8
<*> getWord8
<*> getWord32host
instance Header IfAddrMsg where
type HeaderPart IfAddrMsg = IfAddrMsgPart
fromHeaderParts = toHeader . foldr modify (0,0,mempty,0,0)
where
toHeader (a,b,c,d,e) = IfAddrMsg a b (cfFlags c) d e
modify (IfAddrMsgFamily a) (_,b,c,d,e) = (a, b, c, d, e)
modify (IfAddrMsgPrefix b) (a,_,c,d,e) = (a, b, c, d, e)
modify (IfAddrMsgFlags f) (a,b,c,d,e) = (a, b, f<>c, d, e)
modify (IfAddrMsgScope d) (a,b,c,_,e) = (a, b, c, d, e)
modify (IfAddrMsgIndex e) (a,b,c,d,_) = (a, b, c, d, e)
emptyHeader = IfAddrMsg 0 0 0 0 0
instance CreateMessageHeader IfAddrMsg where
createTypeNumber = const 20
{-# LINE 481 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance DestroyMessageHeader IfAddrMsg where
destroyTypeNumber = const 21
{-# LINE 483 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance RequestMessageHeader IfAddrMsg where
requestTypeNumber = const 22
{-# LINE 485 "src/System/Linux/RTNetlink/Address.hsc" #-}
instance ReplyMessageHeader IfAddrMsg where
replyTypeNumbers = const [20]
{-# LINE 487 "src/System/Linux/RTNetlink/Address.hsc" #-}
data IfAddrMsgPart
= IfAddrMsgFamily Word8
| IfAddrMsgPrefix Word8
| IfAddrMsgFlags (ChangeFlags Word8)
| IfAddrMsgScope Word8
| IfAddrMsgIndex Word32
deriving (Show, Eq)