module DBus.Message.Internal where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.Set as S
import Data.Word (Word8, Word32)
import Data.Maybe (fromMaybe)
import qualified DBus.Types as T
import DBus.Util (maybeIndex)
class Message a where
messageTypeCode :: a -> Word8
messageHeaderFields :: a -> [HeaderField]
messageFlags :: a -> S.Set Flag
messageBody :: a -> [T.Variant]
data Flag
= NoReplyExpected
| NoAutoStart
deriving (Show, Eq, Ord)
data HeaderField
= Path T.ObjectPath
| Interface T.InterfaceName
| Member T.MemberName
| ErrorName T.ErrorName
| ReplySerial Serial
| Destination T.BusName
| Sender T.BusName
| Signature T.Signature
deriving (Show, Eq)
newtype Serial = Serial { serialValue :: Word32 }
deriving (Eq, Ord)
instance Show Serial where
show (Serial x) = show x
instance T.Variable Serial where
toVariant (Serial x) = T.toVariant x
fromVariant = fmap Serial . T.fromVariant
firstSerial :: Serial
firstSerial = Serial 1
nextSerial :: Serial -> Serial
nextSerial (Serial x) = Serial (x + 1)
maybe' :: (a -> b) -> Maybe a -> [b]
maybe' f = maybe [] (\x' -> [f x'])
data MethodCall = MethodCall
{ methodCallPath :: T.ObjectPath
, methodCallMember :: T.MemberName
, methodCallInterface :: Maybe T.InterfaceName
, methodCallDestination :: Maybe T.BusName
, methodCallFlags :: S.Set Flag
, methodCallBody :: [T.Variant]
}
deriving (Show, Eq)
instance Message MethodCall where
messageTypeCode _ = 1
messageFlags = methodCallFlags
messageBody = methodCallBody
messageHeaderFields m = concat
[ [ Path $ methodCallPath m
, Member $ methodCallMember m
]
, maybe' Interface . methodCallInterface $ m
, maybe' Destination . methodCallDestination $ m
]
data MethodReturn = MethodReturn
{ methodReturnSerial :: Serial
, methodReturnDestination :: Maybe T.BusName
, methodReturnBody :: [T.Variant]
}
deriving (Show, Eq)
instance Message MethodReturn where
messageTypeCode _ = 2
messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart]
messageBody = methodReturnBody
messageHeaderFields m = concat
[ [ ReplySerial $ methodReturnSerial m
]
, maybe' Destination . methodReturnDestination $ m
]
data Error = Error
{ errorName :: T.ErrorName
, errorSerial :: Serial
, errorDestination :: Maybe T.BusName
, errorBody :: [T.Variant]
}
deriving (Show, Eq)
instance Message Error where
messageTypeCode _ = 3
messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart]
messageBody = errorBody
messageHeaderFields m = concat
[ [ ErrorName $ errorName m
, ReplySerial $ errorSerial m
]
, maybe' Destination . errorDestination $ m
]
errorMessage :: Error -> Text
errorMessage msg = fromMaybe "(no error message)" $ do
field <- maybeIndex (errorBody msg) 0
text <- T.fromVariant field
if TL.null text
then Nothing
else return text
data Signal = Signal
{ signalPath :: T.ObjectPath
, signalMember :: T.MemberName
, signalInterface :: T.InterfaceName
, signalDestination :: Maybe T.BusName
, signalBody :: [T.Variant]
}
deriving (Show, Eq)
instance Message Signal where
messageTypeCode _ = 4
messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart]
messageBody = signalBody
messageHeaderFields m = concat
[ [ Path $ signalPath m
, Member $ signalMember m
, Interface $ signalInterface m
]
, maybe' Destination . signalDestination $ m
]
data Unknown = Unknown
{ unknownType :: Word8
, unknownFlags :: S.Set Flag
, unknownBody :: [T.Variant]
}
deriving (Show, Eq)
data ReceivedMessage
= ReceivedMethodCall Serial (Maybe T.BusName) MethodCall
| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn
| ReceivedError Serial (Maybe T.BusName) Error
| ReceivedSignal Serial (Maybe T.BusName) Signal
| ReceivedUnknown Serial (Maybe T.BusName) Unknown
deriving (Show, Eq)
receivedSerial :: ReceivedMessage -> Serial
receivedSerial (ReceivedMethodCall s _ _) = s
receivedSerial (ReceivedMethodReturn s _ _) = s
receivedSerial (ReceivedError s _ _) = s
receivedSerial (ReceivedSignal s _ _) = s
receivedSerial (ReceivedUnknown s _ _) = s
receivedSender :: ReceivedMessage -> Maybe T.BusName
receivedSender (ReceivedMethodCall _ s _) = s
receivedSender (ReceivedMethodReturn _ s _) = s
receivedSender (ReceivedError _ s _) = s
receivedSender (ReceivedSignal _ s _) = s
receivedSender (ReceivedUnknown _ s _) = s
receivedBody :: ReceivedMessage -> [T.Variant]
receivedBody (ReceivedMethodCall _ _ x) = messageBody x
receivedBody (ReceivedMethodReturn _ _ x) = messageBody x
receivedBody (ReceivedError _ _ x) = messageBody x
receivedBody (ReceivedSignal _ _ x) = messageBody x
receivedBody (ReceivedUnknown _ _ x) = unknownBody x