{-# LINE 1 "src/System/Linux/RTNetlink/Message.hsc" #-}
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module System.Linux.RTNetlink.Message where
import Control.Applicative ((<$>), (<*>), (<|>))
import Control.Monad (guard)
import Data.Int (Int32)
import Data.List (nub)
import Data.Monoid (mempty, (<>))
import Data.Serialize
import Data.Word (Word16, Word32)
import qualified Data.ByteString as S
import qualified Foreign.C.Error as C
import System.Linux.RTNetlink.Packet
type SequenceNumber = Word32
sequenceNumber :: S.ByteString -> SequenceNumber
sequenceNumber = either (const 0) nlMsgSeqNum . decode
type TypeNumber = Word16
type NLFlags = Word16
data NLMessage header = NLMessage
{ nlmHeader :: header
, nlmAttrs :: AttributeList
, nlmType :: TypeNumber
, nlmFlags :: NLFlags
, nlmSeqNum :: SequenceNumber
} deriving (Show, Eq)
instance Sized header => Sized (NLMessage header) where
size NLMessage {..} = size nlmAttrs + size nlmHeader + 16
{-# LINE 65 "src/System/Linux/RTNetlink/Message.hsc" #-}
instance (Sized header, Serialize header) => Serialize (NLMessage header) where
put m@(NLMessage {..}) = do
put $ NLMsgHdr (size m) nlmType nlmFlags nlmSeqNum 0
put $ nlmHeader
put $ nlmAttrs
get = do
NLMsgHdr {..} <- get
header <- get
attributes <- get
return $ NLMessage header attributes nlMsgType nlMsgFlags nlMsgSeqNum
data NLMsgErr = NLMsgErr
{ nleError :: Int32
, nleHeader :: NLMsgHdr
} deriving (Show, Eq)
instance Sized NLMsgErr where
size = const 20
{-# LINE 85 "src/System/Linux/RTNetlink/Message.hsc" #-}
instance Serialize NLMsgErr where
put NLMsgErr {..} = putInt32host nleError >> put nleHeader
get = NLMsgErr <$> getInt32le <*> get
instance Header NLMsgErr where
type HeaderPart NLMsgErr = NLMsgErrPart
fromHeaderParts = foldr modify emptyHeader
where
modify (NLMsgErrError e) h = h {nleError = e}
modify (NLMsgErrHeader g) h = h {nleHeader = g}
emptyHeader = NLMsgErr 0 $ NLMsgHdr 0 0 0 0 0
instance ReplyMessageHeader NLMsgErr where
replyTypeNumbers _ = [2]
{-# LINE 97 "src/System/Linux/RTNetlink/Message.hsc" #-}
data NLMsgErrPart
= NLMsgErrError Int32
| NLMsgErrHeader NLMsgHdr
deriving (Show, Eq)
class (Show h, Eq h, Sized h, Serialize h) => Header h where
type HeaderPart h
fromHeaderParts :: [HeaderPart h] -> h
emptyHeader :: h
instance Header () where
type HeaderPart () = ()
fromHeaderParts = mempty
emptyHeader = ()
class Header h => CreateMessageHeader h where
createTypeNumber :: h -> TypeNumber
class Header h => DestroyMessageHeader h where
destroyTypeNumber :: h -> TypeNumber
class Header h => ChangeMessageHeader h where
changeTypeNumber :: h -> TypeNumber
class Header h => RequestMessageHeader h where
requestTypeNumber :: h -> TypeNumber
class Header h => ReplyMessageHeader h where
replyTypeNumbers :: h -> [TypeNumber]
instance ReplyMessageHeader () where
replyTypeNumbers () = []
class Header (MessageHeader m) => Message m where
type MessageHeader m
messageHeaderParts :: m -> [HeaderPart (MessageHeader m)]
messageHeaderParts = mempty
messageAttrs :: m -> AttributeList
messageAttrs = mempty
{-# MINIMAL #-}
instance (Message m, Message n, MessageHeader m ~ MessageHeader n)
=> Message (m,n) where
type MessageHeader (m,n) = MessageHeader m
messageHeaderParts (m,n) = messageHeaderParts m <> messageHeaderParts n
messageAttrs (m,n) = messageAttrs m <> messageAttrs n
messageHeader :: Message m => m -> MessageHeader m
messageHeader = fromHeaderParts . messageHeaderParts
toNLMessage :: Message m => m -> (MessageHeader m -> TypeNumber)
-> NLFlags -> SequenceNumber -> NLMessage (MessageHeader m)
toNLMessage m typeNumber = NLMessage header (messageAttrs m) (typeNumber header)
where header = messageHeader m
class (Message c, CreateMessageHeader (MessageHeader c)) => Create c
instance {-# Overlappable #-} (Create c, Create d,
MessageHeader c ~ MessageHeader d) => Create (c,d)
createNLMessage :: Create c => c -> SequenceNumber -> NLMessage (MessageHeader c)
createNLMessage c = toNLMessage c createTypeNumber flags
where flags = 1541
{-# LINE 187 "src/System/Linux/RTNetlink/Message.hsc" #-}
class (Message d, DestroyMessageHeader (MessageHeader d)) => Destroy d
instance (Destroy d, Destroy e, MessageHeader d ~ MessageHeader e)
=> Destroy (d,e)
destroyNLMessage :: Destroy d => d -> SequenceNumber -> NLMessage (MessageHeader d)
destroyNLMessage d = toNLMessage d destroyTypeNumber flags
where flags = 5
{-# LINE 197 "src/System/Linux/RTNetlink/Message.hsc" #-}
class (Message id, ChangeMessageHeader (MessageHeader id)) => Change id c where
changeHeaderParts :: id -> c -> [HeaderPart (MessageHeader id)]
changeHeaderParts i _ = messageHeaderParts i
changeAttrs :: id -> c -> AttributeList
changeAttrs i _ = messageAttrs i
{-# MINIMAL #-}
instance (Change id c, Change id d) => Change id (c,d) where
changeHeaderParts id (c,d) =
changeHeaderParts id c <> changeHeaderParts id d
changeAttrs id (c,d) = changeAttrs id c <> changeAttrs id d
instance (Change id1 c, Change id2 c, MessageHeader id1 ~ MessageHeader id2)
=> Change (id1,id2) c where
changeHeaderParts (id1,id2) c =
changeHeaderParts id1 c <> changeHeaderParts id2 c
changeAttrs (id1,id2) c = changeAttrs id1 c <> changeAttrs id2 c
changeNLMessage :: Change id c => id -> c -> SequenceNumber
-> NLMessage (MessageHeader id)
changeNLMessage i c =
NLMessage header (changeAttrs i c) (changeTypeNumber header) flags
where
header = fromHeaderParts $ changeHeaderParts i c
flags = 5
{-# LINE 228 "src/System/Linux/RTNetlink/Message.hsc" #-}
class (Message r, RequestMessageHeader (MessageHeader r)) => Request r where
requestNLFlags :: r -> ChangeFlags NLFlags
{-# MINIMAL requestNLFlags #-}
instance (Request r, Request s, MessageHeader r ~ MessageHeader s)
=> Request (r,s) where
requestNLFlags (r,s) = if rFlags == dumpOne r || sFlags == dumpOne s
then dumpOne r
else rFlags <> sFlags
where
rFlags = requestNLFlags r
sFlags = requestNLFlags s
requestNLMessage :: Request r => r -> SequenceNumber
-> NLMessage (MessageHeader r)
requestNLMessage r = toNLMessage r requestTypeNumber flags
where flags = applyChangeFlags' $ requestNLFlags r
dumpOne :: a -> ChangeFlags NLFlags
dumpOne = const $
ChangeFlags 1 769
{-# LINE 257 "src/System/Linux/RTNetlink/Message.hsc" #-}
dumpMany :: a -> ChangeFlags NLFlags
dumpMany = const $ setChangeFlags 769
{-# LINE 262 "src/System/Linux/RTNetlink/Message.hsc" #-}
class ReplyMessageHeader (ReplyHeader r) => Reply r where
type ReplyHeader r
fromNLMessage :: NLMessage (ReplyHeader r) -> Maybe r
{-# MINIMAL fromNLMessage #-}
instance Reply () where
type ReplyHeader () = ()
fromNLMessage _ = Nothing
instance Reply C.Errno where
type ReplyHeader C.Errno = NLMsgErr
fromNLMessage = Just . C.Errno . abs . fromIntegral . nleError . nlmHeader
instance Reply r => Reply (Maybe r) where
type ReplyHeader (Maybe r) = ReplyHeader r
fromNLMessage m = return $ fromNLMessage m
instance (Reply r, Reply s, ReplyHeader r ~ ReplyHeader s)
=> Reply (Either r s) where
type ReplyHeader (Either r s) = ReplyHeader r
fromNLMessage m = Left <$> fromNLMessage m <|> Right <$> fromNLMessage m
instance (Reply r, Reply s, ReplyHeader r ~ ReplyHeader s) => Reply (r,s) where
type ReplyHeader (r,s) = ReplyHeader r
fromNLMessage m = (,) <$> fromNLMessage m <*> fromNLMessage m
class (Request q, Reply r) => Dump q r
instance Request q => Dump q ()
instance Request q => Dump q C.Errno
instance (Request r, Reply r) => Dump r r
instance Dump q r => Dump q (Maybe r)
instance (Dump q r, Dump q s, ReplyHeader r ~ ReplyHeader s)
=> Dump q (Either r s)
instance (Dump q r1, Dump q r2, ReplyHeader r1 ~ ReplyHeader r2)
=> Dump q (r1,r2)
instance (Dump q1 r, Dump q2 r, MessageHeader q1 ~ MessageHeader q2)
=> Dump (q1,q2) r
instance {-# Overlapping #-} (Dump q1 r1, Dump q2 r2,
MessageHeader q1 ~ MessageHeader q2, ReplyHeader r1 ~ ReplyHeader r2)
=> Dump (q1,q2) (r1,r2)
instance {-# Overlappable #-} (Request q, Reply r,
MessageHeader q ~ ReplyHeader r) => Dump q r
fromNLMessage' :: Reply r => NLMessage (ReplyHeader r) -> Maybe r
fromNLMessage' m = do
r <- fromNLMessage m
guard $ nlmType m `elem` replyTypeNumbers (nlmHeader m)
return r