module Network.DBus.Message (
Message(..),
MessageType(..),
Flag(..),
dbusProtocolVersion,
endiannessValue,
readMessage,
writeMessage,
deserializeMessage,
serializeMessage,
methodCall
) where
import Control.Monad (liftM3, when)
import Data.Bits ((.|.), (.&.))
import Data.Char (ord)
import Data.List (foldl')
import Data.Maybe (fromJust)
import Data.Typeable (cast)
import Data.Word
import System.IO (Handle)
import qualified Control.Monad.State as S
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BS
import Network.DBus.Type
import Network.DBus.Value
data MessageType = MethodCall
| MethodReturn
| Error
| Signal
deriving (Show, Enum, Eq)
endiannessValue :: Endianness -> Word8
endiannessValue e = fromIntegral . ord $ case e of
LittleEndian -> 'l'
BigEndian -> 'B'
data Flag = NoReplyExpected
| NoAutoStart
deriving (Eq, Show)
flagValue :: Flag -> Word8
flagValue f = case f of NoReplyExpected -> 0x1
NoAutoStart -> 0x2
flagsValue :: [Flag] -> Word8
flagsValue = foldl' (.|.) 0 . map flagValue
decodeFlags :: Word8 -> [Flag]
decodeFlags 0 = []
decodeFlags n | n .&. 0x1 /= 0 = NoReplyExpected : decodeFlags (n 0x1)
| n .&. 0x2 /= 0 = NoAutoStart : decodeFlags (n 0x2)
| otherwise = error $ "unrecognised flag value " ++ show n
dbusProtocolVersion :: Word8
dbusProtocolVersion = 1
data Message = Message { mType :: MessageType
, mFlags :: [Flag]
, mSerial :: Word32
, mPath :: Maybe ObjectPath
, mInterface :: Maybe DString
, mMember :: Maybe DString
, mErrorName :: Maybe DString
, mReplySerial :: Maybe Word32
, mDestination :: Maybe DString
, mSender :: Maybe DString
, mBody :: [Variant]
}
deriving (Eq, Show)
nativeEndianness :: Endianness
nativeEndianness = case BS.unpack . runPut $ putWord16host 1 of
[0, 1] -> BigEndian
_ -> LittleEndian
decodeFields :: [(Word8, Variant)] ->
(Maybe ObjectPath, Maybe DString, Maybe DString, Maybe DString,
Maybe Word32, Maybe DString, Maybe DString, Maybe Signature)
decodeFields fs = (path, iface, member, err, rs, dest, sender, sig)
where decode (Variant x) = fromJust . cast $ x
path = decode `fmap` lookup 1 fs
iface = decode `fmap` lookup 2 fs
member = decode `fmap` lookup 3 fs
err = decode `fmap` lookup 4 fs
rs = decode `fmap` lookup 5 fs
dest = decode `fmap` lookup 6 fs
sender = decode `fmap` lookup 7 fs
sig = decode `fmap` lookup 8 fs
parseInit = do
e <- getWord8 >>= \b ->
case toEnum . fromIntegral $ b of
'B' -> return BigEndian
'l' -> return LittleEndian
c -> fail $ "bad endianness " ++ show c
t <- getWord8 >>= return . toEnum . (subtract 1) . fromIntegral
f <- getWord8 >>= return . decodeFlags
v <- getWord8
let getWord32 = case e of BigEndian -> getWord32be
LittleEndian -> getWord32le
(bl, s, fl) <- liftM3 (,,) getWord32 getWord32 getWord32
return (e, t :: MessageType, f :: [Flag], v, bl, s, fl)
deserializeMessage :: BS.ByteString -> (Message, BS.ByteString)
deserializeMessage = runGet $ do
initBuf <- lookAhead $ getLazyByteString 16
(endianness, type_, flags, _version, bodyLength, serial, fieldsLength)
<- parseInit
fieldsBuf <- getLazyByteString . fromIntegral $ fieldsLength
let (path, iface, member, err, rs, dest, sender, sig) =
decodeFields $ runDeserializer endianness
(do S.lift (skip 12)
deserializer :: Deserializer [(Word8, Variant)]) $
initBuf `BS.append` fieldsBuf
bytesCount = 16 + BS.length fieldsBuf
offset = bytesCount `mod` 8
paddingBytes = if offset == 0 then 0 else 8 offset
padding <- getLazyByteString (fromIntegral paddingBytes)
when (not $ BS.all (== 0) padding) $
fail $ "non-null bytes in padding"
body <- case sig of
Nothing -> return []
Just ts ->
runDeserializer endianness (deserializeAs ts) `fmap`
(getLazyByteString . fromIntegral $ bodyLength)
rest <- getRemainingLazyByteString
let msg = Message {
mType = type_,
mFlags = flags,
mSerial = serial,
mPath = path,
mInterface = iface,
mMember = member,
mErrorName = err,
mReplySerial = rs,
mDestination = dest,
mSender = sender,
mBody = body }
return (msg, rest)
readMessage :: Handle -> IO Message
readMessage handle = do
initBuf <- BS.hGet handle 16
let (endianness, type_, flags, _version, bodyLength, serial, fieldsLength)
= runGet parseInit initBuf
fieldsBuf <- BS.hGet handle . fromIntegral $ fieldsLength
let (path, iface, member, err, rs, dest, sender, sig) =
decodeFields $ runDeserializer endianness
(do S.lift (skip 12)
deserializer :: Deserializer [(Word8, Variant)]) $
initBuf `BS.append` fieldsBuf
bytesCount = 16 + BS.length fieldsBuf
offset = bytesCount `mod` 8
paddingBytes = if offset == 0 then 0 else 8 offset
padding <- BS.hGet handle (fromIntegral paddingBytes)
when (not $ BS.all (== 0) padding) $
fail $ "non-null bytes in padding"
body <- case sig of
Nothing -> return []
Just ts -> do
bodyBuf <- BS.hGet handle . fromIntegral $ bodyLength
return $ runDeserializer endianness (deserializeAs ts) bodyBuf
return $ Message {
mType = type_,
mFlags = flags,
mSerial = serial,
mPath = path,
mInterface = iface,
mMember = member,
mErrorName = err,
mReplySerial = rs,
mDestination = dest,
mSender = sender,
mBody = body }
encodeFields :: Message -> [(Word8, Variant)]
encodeFields m = concat [
extract 1 mPath m,
extract 2 mInterface m,
extract 3 mMember m,
extract 4 mErrorName m,
extract 5 mReplySerial m,
extract 6 mDestination m,
extract 7 mSender m,
case mBody m of
[] -> []
xs -> [(8, Variant $ sig xs)]]
where extract n rec = maybe [] (\v -> [(n, Variant v)]) . rec
sig = Signature . map (\(Variant v) -> dtype v)
serializeMessage :: Message -> BS.ByteString
serializeMessage m = runPut $ do
let e = nativeEndianness
putWord8 . fromIntegral . fromEnum . endiannessValue $ e
putWord8 . fromIntegral . (+1) . fromEnum . mType $ m
putWord8 . flagsValue . mFlags $ m
putWord8 dbusProtocolVersion
let fields = runSerializer e $ do
advanceBy 12
serializer . encodeFields $ m
padTo 8
body = runSerializer e $ do
advanceBy $ 12 + fromIntegral (BS.length fields)
mapM_ (\(Variant v) -> serializer v) $ mBody m
let putWord32 = case e of BigEndian -> putWord32be
LittleEndian -> putWord32le
putWord32 . fromIntegral . BS.length $ body
putWord32 . mSerial $ m
putLazyByteString fields
putLazyByteString body
writeMessage :: Handle -> Message -> IO ()
writeMessage handle m = BS.hPutStr handle . serializeMessage $ m
methodCall :: DString -> DString -> DString -> ObjectPath -> [Variant] ->
Message
methodCall interface member destination path body = Message {
mType = MethodCall,
mFlags = [],
mSerial = 1,
mPath = Just path,
mInterface = Just interface,
mMember = Just member,
mErrorName = Nothing,
mReplySerial = Nothing,
mDestination = Just destination,
mSender = Nothing,
mBody = body }