module Network.DBus.Message
(
MessageType(..)
, MessageFlag(..)
, Header(..)
, Field(..)
, Message(..)
, Serial
, msgMethodCall
, msgMethodReturn
, msgError
, msgSignal
, headerFromMessage
, messageFromHeader
, readHeader
, writeHeader
, readFields
, writeFields
, readBody
, readBodyWith
) where
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import Control.Applicative ((<$>))
import Control.Monad.State
import Network.DBus.Wire
import Network.DBus.Type
import Network.DBus.Signature
data MessageType =
TypeInvalid
| TypeMethodCall
| TypeMethodReturn
| TypeError
| TypeSignal
deriving (Show,Eq,Enum)
data MessageFlag =
FlagNoReplyExpected
| FlagNoAutoStart
deriving (Show,Eq)
type Serial = Word32
data Header = Header
{ headerEndian :: DbusEndian
, headerMessageType :: !MessageType
, headerVersion :: !Int
, headerFlags :: !Int
, headerBodyLength :: !Int
, headerSerial :: !Serial
, headerFieldsLength :: !Int
} deriving (Show,Eq)
type Body = [DbusType]
type Interface = ByteString
type Member = ByteString
type BusName = ByteString
type ErrorName = ByteString
data Field =
FieldPath ObjectPath
| FieldInterface Interface
| FieldMember Member
| FieldErrorName ErrorName
| FieldReplySerial Serial
| FieldDestination BusName
| FieldSender ByteString
| FieldSignature Signature
| FieldUnixFds Word32
deriving (Show,Eq)
fieldVal :: Field -> Int
fieldVal (FieldPath _) = 1
fieldVal (FieldInterface _) = 2
fieldVal (FieldMember _) = 3
fieldVal (FieldErrorName _) = 4
fieldVal (FieldReplySerial _) = 5
fieldVal (FieldDestination _) = 6
fieldVal (FieldSender _) = 7
fieldVal (FieldSignature _) = 8
fieldVal (FieldUnixFds _) = 9
data Message = Message
{ msgEndian :: DbusEndian
, msgType :: !MessageType
, msgVersion :: !Int
, msgFlags :: !Int
, msgSerial :: !Serial
, msgFields :: [Field]
, msgBody :: ByteString
} deriving (Show,Eq)
defaultMessage :: Message
defaultMessage = Message
{ msgEndian = LE
, msgType = TypeInvalid
, msgVersion = 1
, msgFlags = 0
, msgSerial = 0
, msgFields = []
, msgBody = B.empty
}
headerFromMessage :: Message -> Header
headerFromMessage msg = Header
{ headerEndian = msgEndian msg
, headerMessageType = msgType msg
, headerVersion = msgVersion msg
, headerFlags = msgFlags msg
, headerBodyLength = 0
, headerSerial = msgSerial msg
, headerFieldsLength = 0
}
messageFromHeader :: Header -> Message
messageFromHeader hdr = Message
{ msgEndian = headerEndian hdr
, msgType = headerMessageType hdr
, msgVersion = headerVersion hdr
, msgFlags = headerFlags hdr
, msgSerial = headerSerial hdr
, msgFields = []
, msgBody = B.empty
}
msgMethodCall :: BusName -> ObjectPath -> Interface -> Member -> Body -> Message
msgMethodCall destination path interface method body = defaultMessage
{ msgType = TypeMethodCall
, msgFields =
[ FieldPath path
, FieldDestination destination
, FieldInterface interface
, FieldMember method
] ++ if null body then [] else [ FieldSignature $ signatureBody body ]
, msgBody = writeBody body
}
msgSignal :: ObjectPath -> Interface -> Member -> Body -> Message
msgSignal path interface method body = defaultMessage
{ msgType = TypeSignal
, msgFields =
[ FieldPath path
, FieldInterface interface
, FieldMember method
] ++ if null body then [] else [ FieldSignature $ signatureBody body ]
, msgBody = writeBody body
}
msgMethodReturn :: Serial -> Body -> Message
msgMethodReturn replySerial body = defaultMessage
{ msgType = TypeMethodReturn
, msgFields =
[ FieldReplySerial replySerial
] ++ if null body then [] else [ FieldSignature $ signatureBody body ]
, msgBody = writeBody body
}
msgError :: ErrorName -> Serial -> Body -> Message
msgError errorName replySerial body = defaultMessage
{ msgType = TypeError
, msgFields =
[ FieldErrorName errorName
, FieldReplySerial replySerial
] ++ if null body then [] else [ FieldSignature $ signatureBody body ]
, msgBody = writeBody body
}
readHeader :: ByteString -> Header
readHeader b = getWire LE 0 getHeader b
where getHeader = do
e <- getw8
let bswap32 = id
let swapf = if fromIntegral e /= fromEnum 'l' then bswap32 else id
mt <- toEnum . fromIntegral <$> getw8
flags <- fromIntegral <$> getw8
ver <- fromIntegral <$> getw8
blen <- fromIntegral . swapf <$> getw32
serial <- swapf <$> getw32
flen <- fromIntegral . swapf <$> getw32
return $! Header
{ headerEndian = if fromIntegral e /= fromEnum 'l' then BE else LE
, headerMessageType = mt
, headerVersion = ver
, headerFlags = flags
, headerBodyLength = blen
, headerSerial = serial
, headerFieldsLength = flen
}
writeHeader :: Header -> ByteString
writeHeader hdr = putWire [putHeader]
where putHeader = do
putw8 $ fromIntegral $ fromEnum $ if headerEndian hdr == BE then 'b' else 'l'
putw8 $ fromIntegral $ fromEnum $ headerMessageType hdr
putw8 $ fromIntegral $ headerFlags hdr
putw8 $ fromIntegral $ headerVersion hdr
putw32 $ fromIntegral $ headerBodyLength hdr
putw32 $ fromIntegral $ headerSerial hdr
putw32 $ fromIntegral $ headerFieldsLength hdr
readFields :: ByteString -> [Field]
readFields b = getWire LE 16 getFields b
where
getFields :: GetWire [Field]
getFields = isWireEmpty >>= \empty -> if empty then return [] else liftM2 (:) getField getFields
getField :: GetWire Field
getField = do
ty <- fromIntegral <$> getw8
signature <- getVariant
when (getSigVal ty /= signature) $ error "field type invalid"
t <- getFieldVal ty
alignRead 8
return t
getSigVal 1 = SigObjectPath
getSigVal 2 = SigString
getSigVal 3 = SigString
getSigVal 4 = SigString
getSigVal 5 = SigUInt32
getSigVal 6 = SigString
getSigVal 7 = SigString
getSigVal 8 = SigSignature
getSigVal 9 = SigUnixFD
getSigVal n = error ("unknown field: " ++ show n)
getFieldVal :: Int -> GetWire Field
getFieldVal 1 = FieldPath <$> getObjectPath
getFieldVal 2 = FieldInterface <$> getString
getFieldVal 3 = FieldMember <$> getString
getFieldVal 4 = FieldErrorName <$> getString
getFieldVal 5 = FieldReplySerial <$> getw32
getFieldVal 6 = FieldDestination <$> getString
getFieldVal 7 = FieldSender <$> getString
getFieldVal 8 = FieldSignature <$> getSignature
getFieldVal 9 = FieldUnixFds <$> getw32
getFieldVal n = error ("unknown field: " ++ show n)
writeFields :: [Field] -> ByteString
writeFields fields = putWire (putFields fields)
where
putFields :: [Field] -> [PutWire]
putFields l = map putField l
putField f = alignWrite 8 >> putw8 (fromIntegral $ fieldVal f) >> putFieldVal f
putFieldVal :: Field -> PutWire
putFieldVal (FieldPath s) = putVariant SigObjectPath >> putObjectPath s
putFieldVal (FieldInterface s) = putVariant SigString >> putString s
putFieldVal (FieldMember s) = putVariant SigString >> putString s
putFieldVal (FieldErrorName s) = putVariant SigString >> putString s
putFieldVal (FieldReplySerial s) = putVariant SigUInt32 >> putw32 s
putFieldVal (FieldDestination s) = putVariant SigString >> putString s
putFieldVal (FieldSender s) = putVariant SigString >> putString s
putFieldVal (FieldSignature s) = putVariant SigSignature >> putSignature s
putFieldVal (FieldUnixFds _) = putVariant SigUInt32 >> putw32 0
writeBody :: Body -> ByteString
writeBody els = putWire (map putType els)
signatureBody :: Body -> Signature
signatureBody body = map sigType body
readBodyWith :: Message -> Signature -> Body
readBodyWith m sigs = getWire (msgEndian m) 0 (mapM getType sigs) (msgBody m)
readBody :: Message -> Body
readBody m = readBodyWith m (getFieldSig $ msgFields m)
where
getFieldSig fields = case filter isFieldSignature fields of
[FieldSignature s] -> s
_ -> []
isFieldSignature (FieldSignature _) = True
isFieldSignature _ = False