module DBus.Wire ( Endianness (..)
, alignment
, MarshalM
, Marshal
, marshal
, runMarshal
, MarshalError (..)
, Unmarshal
, unmarshal
, runUnmarshal
, UnmarshalError (..)
, marshalMessage
, unmarshalMessage
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import qualified Control.Monad.State as ST
import qualified Control.Monad.Error as E
import qualified Data.ByteString.Lazy as L
import qualified Data.Binary.Builder as B
import qualified Data.Binary.Get as G
import Data.Binary.Put (runPut)
import qualified Data.Binary.IEEE754 as IEEE
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import qualified DBus.Constants as C
import qualified DBus.Message.Internal as M
import Data.Bits ((.|.), (.&.))
import qualified Data.Set as Set
import Control.Monad (when, unless)
import Data.Maybe (fromJust, listToMaybe, fromMaybe)
import Data.Word (Word8, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import qualified DBus.Types as T
data Endianness = LittleEndian | BigEndian
deriving (Show, Eq)
encodeEndianness :: Endianness -> Word8
encodeEndianness LittleEndian = 108
encodeEndianness BigEndian = 66
decodeEndianness :: Word8 -> Maybe Endianness
decodeEndianness 108 = Just LittleEndian
decodeEndianness 66 = Just BigEndian
decodeEndianness _ = Nothing
alignment :: T.Type -> Word8
alignment T.DBusByte = 1
alignment T.DBusWord16 = 2
alignment T.DBusWord32 = 4
alignment T.DBusWord64 = 8
alignment T.DBusInt16 = 2
alignment T.DBusInt32 = 4
alignment T.DBusInt64 = 8
alignment T.DBusDouble = 8
alignment T.DBusBoolean = 4
alignment T.DBusString = 4
alignment T.DBusObjectPath = 4
alignment T.DBusSignature = 1
alignment (T.DBusArray _) = 4
alignment (T.DBusDictionary _ _) = 4
alignment (T.DBusStructure _) = 8
alignment T.DBusVariant = 1
padding :: Word64 -> Word8 -> Word64
padding current count = required where
count' = fromIntegral count
missing = mod current count'
required = if missing > 0
then count' missing
else 0
data MarshalState = MarshalState Endianness B.Builder !Word64
newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)
deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)
type Marshal = MarshalM ()
runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString
runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of
(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)
(Left x, _) -> Left x
where initialState = MarshalState e B.empty 0
marshal :: T.Variant -> Marshal
marshal v = marshalType (T.variantType v) where
x :: T.Variable a => a
x = fromJust . T.fromVariant $ v
marshalType :: T.Type -> Marshal
marshalType T.DBusByte = append $ L.singleton x
marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x
marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x
marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x
marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)
marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)
marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)
marshalType T.DBusDouble = do
pad 8
(MarshalState e _ _) <- ST.get
let put = case e of
BigEndian -> IEEE.putFloat64be
LittleEndian -> IEEE.putFloat64le
let bytes = runPut $ put x
append bytes
marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0
marshalType T.DBusString = marshalText x
marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x
marshalType T.DBusSignature = marshalSignature x
marshalType (T.DBusArray _) = marshalArray x
marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)
marshalType (T.DBusStructure _) = do
let T.Structure vs = x
pad 8
mapM_ marshal vs
marshalType T.DBusVariant = do
let rawSig = T.typeCode . T.variantType $ x
sig <- case T.mkSignature rawSig of
Just x' -> return x'
Nothing -> E.throwError $ InvalidVariantSignature rawSig
marshalSignature sig
marshal x
append :: L.ByteString -> Marshal
append bytes = do
(MarshalState e builder count) <- ST.get
let builder' = B.append builder $ B.fromLazyByteString bytes
count' = count + (fromIntegral $ L.length bytes)
ST.put $ MarshalState e builder' count'
pad :: Word8 -> Marshal
pad count = do
(MarshalState _ _ existing) <- ST.get
let padding' = fromIntegral $ padding existing count
append $ L.replicate padding' 0
marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal
marshalBuilder size be le x = do
pad size
(MarshalState e builder count) <- ST.get
let builder' = B.append builder $ case e of
BigEndian -> be x
LittleEndian -> le x
let count' = count + (fromIntegral size)
ST.put $ MarshalState e builder' count'
data MarshalError
= MessageTooLong Word64
| ArrayTooLong Word64
| InvalidBodySignature Text
| InvalidVariantSignature Text
| TextContainsNUL Text
deriving (Eq)
instance Show MarshalError where
show (MessageTooLong x) = concat
["Message too long (", show x, " bytes)."]
show (ArrayTooLong x) = concat
["Array too long (", show x, " bytes)."]
show (InvalidBodySignature x) = concat
["Invalid body signature: ", show x]
show (InvalidVariantSignature x) = concat
["Invalid variant signature: ", show x]
show (TextContainsNUL x) = concat
["Text contains NUL: ", show x]
instance E.Error MarshalError
data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64
newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)
deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)
runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a
runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where
state = UnmarshalState e bytes 0
unmarshal :: T.Signature -> Unmarshal [T.Variant]
unmarshal = mapM unmarshalType . T.signatureTypes
unmarshalType :: T.Type -> Unmarshal T.Variant
unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1
unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le
unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le
unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le
unmarshalType T.DBusInt16 = do
x <- unmarshalGet 2 G.getWord16be G.getWord16le
return . T.toVariant $ (fromIntegral x :: Int16)
unmarshalType T.DBusInt32 = do
x <- unmarshalGet 4 G.getWord32be G.getWord32le
return . T.toVariant $ (fromIntegral x :: Int32)
unmarshalType T.DBusInt64 = do
x <- unmarshalGet 8 G.getWord64be G.getWord64le
return . T.toVariant $ (fromIntegral x :: Int64)
unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le
unmarshalType T.DBusBoolean = unmarshalWord32 >>=
fromMaybeU' "boolean" (\x -> case x of
0 -> Just False
1 -> Just True
_ -> Nothing)
unmarshalType T.DBusString = fmap T.toVariant unmarshalText
unmarshalType T.DBusObjectPath = unmarshalText >>=
fromMaybeU' "object path" T.mkObjectPath
unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature
unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t
unmarshalType (T.DBusDictionary kt vt) = do
let pairType = T.DBusStructure [kt, vt]
array <- unmarshalArray pairType
fromMaybeU' "dictionary" T.arrayToDictionary array
unmarshalType (T.DBusStructure ts) = do
skipPadding 8
fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts
unmarshalType T.DBusVariant = do
let getType sig = case T.signatureTypes sig of
[t] -> Just t
_ -> Nothing
t <- fromMaybeU "variant signature" getType =<< unmarshalSignature
T.toVariant `fmap` unmarshalType t
consume :: Word64 -> Unmarshal L.ByteString
consume count = do
(UnmarshalState e bytes offset) <- ST.get
let (x, bytes') = L.splitAt (fromIntegral count) bytes
unless (L.length x == fromIntegral count) $
E.throwError $ UnexpectedEOF offset
ST.put $ UnmarshalState e bytes' (offset + count)
return x
skipPadding :: Word8 -> Unmarshal ()
skipPadding count = do
(UnmarshalState _ _ offset) <- ST.get
bytes <- consume $ padding offset count
unless (L.all (== 0) bytes) $
E.throwError $ InvalidPadding offset
skipTerminator :: Unmarshal ()
skipTerminator = do
(UnmarshalState _ _ offset) <- ST.get
bytes <- consume 1
unless (L.all (== 0) bytes) $
E.throwError $ MissingTerminator offset
fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU label f x = case f x of
Just x' -> return x'
Nothing -> E.throwError . Invalid label . TL.pack . show $ x
fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a
-> Unmarshal T.Variant
fromMaybeU' label f x = do
x' <- fromMaybeU label f x
return $ T.toVariant x'
unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a
unmarshalGet count be le = do
skipPadding count
(UnmarshalState e _ _) <- ST.get
bs <- consume . fromIntegral $ count
let get' = case e of
BigEndian -> be
LittleEndian -> le
return $ G.runGet get' bs
unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a
-> Unmarshal T.Variant
unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le
untilM :: Monad m => m Bool -> m a -> m [a]
untilM test comp = do
done <- test
if done
then return []
else do
x <- comp
xs <- untilM test comp
return $ x:xs
data UnmarshalError
= UnsupportedProtocolVersion Word8
| UnexpectedEOF Word64
| Invalid Text Text
| MissingHeaderField Text
| InvalidHeaderField Text T.Variant
| InvalidPadding Word64
| MissingTerminator Word64
| ArraySizeMismatch
deriving (Eq)
instance Show UnmarshalError where
show (UnsupportedProtocolVersion x) = concat
["Unsupported protocol version: ", show x]
show (UnexpectedEOF pos) = concat
["Unexpected EOF at position ", show pos]
show (Invalid label x) = TL.unpack $ TL.concat
["Invalid ", label, ": ", x]
show (MissingHeaderField x) = concat
["Required field " , show x , " is missing."]
show (InvalidHeaderField x got) = concat
[ "Invalid header field ", show x, ": ", show got]
show (InvalidPadding pos) = concat
["Invalid padding at position ", show pos]
show (MissingTerminator pos) = concat
["Missing NUL terminator at position ", show pos]
show ArraySizeMismatch = "Array size mismatch"
instance E.Error UnmarshalError
marshalWord32 :: Word32 -> Marshal
marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le
unmarshalWord32 :: Unmarshal Word32
unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le
marshalText :: Text -> Marshal
marshalText x = do
let bytes = encodeUtf8 x
when (L.any (== 0) bytes) $
E.throwError $ TextContainsNUL x
marshalWord32 . fromIntegral . L.length $ bytes
append bytes
append (L.singleton 0)
unmarshalText :: Unmarshal Text
unmarshalText = do
byteCount <- unmarshalWord32
bytes <- consume . fromIntegral $ byteCount
skipTerminator
return . decodeUtf8 $ bytes
marshalSignature :: T.Signature -> Marshal
marshalSignature x = do
let bytes = encodeUtf8 . T.strSignature $ x
let size = fromIntegral . L.length $ bytes
append (L.singleton size)
append bytes
append (L.singleton 0)
unmarshalSignature :: Unmarshal T.Signature
unmarshalSignature = do
byteCount <- L.head `fmap` consume 1
sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount
skipTerminator
fromMaybeU "signature" T.mkSignature sigText
marshalArray :: T.Array -> Marshal
marshalArray x = do
(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x
let arrayLen = L.length arrayBytes
when (arrayLen > fromIntegral C.arrayMaximumLength)
(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)
marshalWord32 $ fromIntegral arrayLen
append $ L.replicate arrayPadding 0
append arrayBytes
getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)
getArrayBytes T.DBusByte x = return (0, bytes) where
Just bytes = T.arrayToBytes x
getArrayBytes itemType x = do
let vs = T.arrayItems x
s <- ST.get
(MarshalState _ _ afterLength) <- marshalWord32 0 >> ST.get
(MarshalState e _ afterPadding) <- pad (alignment itemType) >> ST.get
ST.put $ MarshalState e B.empty afterPadding
(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> ST.get
let itemBytes = B.toLazyByteString itemBuilder
paddingSize = fromIntegral $ afterPadding afterLength
ST.put s
return (paddingSize, itemBytes)
unmarshalArray :: T.Type -> Unmarshal T.Array
unmarshalArray T.DBusByte = do
byteCount <- unmarshalWord32
T.arrayFromBytes `fmap` consume (fromIntegral byteCount)
unmarshalArray itemType = do
let getOffset = do
(UnmarshalState _ _ o) <- ST.get
return o
byteCount <- unmarshalWord32
skipPadding (alignment itemType)
start <- getOffset
let end = start + fromIntegral byteCount
vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)
end' <- getOffset
when (end' > end) $
E.throwError ArraySizeMismatch
fromMaybeU "array" (T.arrayFromItems itemType) vs
encodeFlags :: Set.Set M.Flag -> Word8
encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where
flagValue M.NoReplyExpected = 0x1
flagValue M.NoAutoStart = 0x2
decodeFlags :: Word8 -> Set.Set M.Flag
decodeFlags word = Set.fromList flags where
flagSet = [ (0x1, M.NoReplyExpected)
, (0x2, M.NoAutoStart)
]
flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]
encodeField :: M.HeaderField -> T.Structure
encodeField (M.Path x) = encodeField' 1 x
encodeField (M.Interface x) = encodeField' 2 x
encodeField (M.Member x) = encodeField' 3 x
encodeField (M.ErrorName x) = encodeField' 4 x
encodeField (M.ReplySerial x) = encodeField' 5 x
encodeField (M.Destination x) = encodeField' 6 x
encodeField (M.Sender x) = encodeField' 7 x
encodeField (M.Signature x) = encodeField' 8 x
encodeField' :: T.Variable a => Word8 -> a -> T.Structure
encodeField' code x = T.Structure
[ T.toVariant code
, T.toVariant $ T.toVariant x
]
decodeField :: Monad m => T.Structure
-> E.ErrorT UnmarshalError m [M.HeaderField]
decodeField struct = case unpackField struct of
(1, x) -> decodeField' x M.Path "path"
(2, x) -> decodeField' x M.Interface "interface"
(3, x) -> decodeField' x M.Member "member"
(4, x) -> decodeField' x M.ErrorName "error name"
(5, x) -> decodeField' x M.ReplySerial "reply serial"
(6, x) -> decodeField' x M.Destination "destination"
(7, x) -> decodeField' x M.Sender "sender"
(8, x) -> decodeField' x M.Signature "signature"
_ -> return []
decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text
-> E.ErrorT UnmarshalError m [b]
decodeField' x f label = case T.fromVariant x of
Just x' -> return [f x']
Nothing -> E.throwError $ InvalidHeaderField label x
unpackField :: T.Structure -> (Word8, T.Variant)
unpackField struct = (c', v') where
T.Structure [c, v] = struct
c' = fromJust . T.fromVariant $ c
v' = fromJust . T.fromVariant $ v
marshalMessage :: M.Message a => Endianness -> M.Serial -> a
-> Either MarshalError L.ByteString
marshalMessage e serial msg = runMarshal marshaler e where
body = M.messageBody msg
marshaler = do
sig <- checkBodySig body
empty <- ST.get
mapM_ marshal body
(MarshalState _ bodyBytesB _) <- ST.get
ST.put empty
marshalEndianness e
let bodyBytes = B.toLazyByteString bodyBytesB
marshalHeader msg serial sig
$ fromIntegral . L.length $ bodyBytes
pad 8
append bodyBytes
checkMaximumSize
checkBodySig :: [T.Variant] -> MarshalM T.Signature
checkBodySig vs = let
sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs
invalid = E.throwError $ InvalidBodySignature sigStr
in case T.mkSignature sigStr of
Just x -> return x
Nothing -> invalid
marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32
-> Marshal
marshalHeader msg serial bodySig bodyLength = do
let fields = M.Signature bodySig : M.messageHeaderFields msg
marshal . T.toVariant . M.messageTypeCode $ msg
marshal . T.toVariant . encodeFlags . M.messageFlags $ msg
marshal . T.toVariant $ C.protocolVersion
marshalWord32 bodyLength
marshal . T.toVariant $ serial
let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]
marshal . T.toVariant . fromJust . T.toArray fieldType
$ map encodeField fields
marshalEndianness :: Endianness -> Marshal
marshalEndianness = marshal . T.toVariant . encodeEndianness
checkMaximumSize :: Marshal
checkMaximumSize = do
(MarshalState _ _ messageLength) <- ST.get
when (messageLength > fromIntegral C.messageMaximumLength)
(E.throwError $ MessageTooLong $ fromIntegral messageLength)
unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)
-> m (Either UnmarshalError M.ReceivedMessage)
unmarshalMessage getBytes' = E.runErrorT $ do
let getBytes = E.lift . getBytes'
let fixedSig = T.mkSignature' "yyyyuuu"
fixedBytes <- getBytes 16
let messageVersion = L.index fixedBytes 3
when (messageVersion /= C.protocolVersion) $
E.throwError $ UnsupportedProtocolVersion messageVersion
let eByte = L.index fixedBytes 0
endianness <- case decodeEndianness eByte of
Just x' -> return x'
Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte
let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of
Right x' -> return x'
Left e -> E.throwError e
fixed <- unmarshal' fixedSig fixedBytes
let typeCode = fromJust . T.fromVariant $ fixed !! 1
let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2
let bodyLength = fromJust . T.fromVariant $ fixed !! 4
let serial = fromJust . T.fromVariant $ fixed !! 5
let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6
let headerSig = T.mkSignature' "yyyyuua(yv)"
fieldBytes <- getBytes fieldByteCount
let headerBytes = L.append fixedBytes fieldBytes
header <- unmarshal' headerSig headerBytes
let fieldArray = fromJust . T.fromVariant $ header !! 6
let fieldStructures = fromJust . T.fromArray $ fieldArray
fields <- concat `fmap` mapM decodeField fieldStructures
let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8
getBytes . fromIntegral $ bodyPadding
let bodySig = findBodySignature fields
bodyBytes <- getBytes bodyLength
body <- unmarshal' bodySig bodyBytes
y <- case buildReceivedMessage typeCode fields of
Right x -> return x
Left x -> E.throwError $ MissingHeaderField x
return $ y serial flags body
findBodySignature :: [M.HeaderField] -> T.Signature
findBodySignature fields = fromMaybe empty signature where
empty = T.mkSignature' ""
signature = listToMaybe [x | M.Signature x <- fields]
buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text
(M.Serial -> (Set.Set M.Flag) -> [T.Variant]
-> M.ReceivedMessage)
buildReceivedMessage 1 fields = do
path <- require "path" [x | M.Path x <- fields]
member <- require "member name" [x | M.Member x <- fields]
return $ \serial flags body -> let
iface = listToMaybe [x | M.Interface x <- fields]
dest = listToMaybe [x | M.Destination x <- fields]
sender = listToMaybe [x | M.Sender x <- fields]
msg = M.MethodCall path member iface dest flags body
in M.ReceivedMethodCall serial sender msg
buildReceivedMessage 2 fields = do
replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]
return $ \serial _ body -> let
dest = listToMaybe [x | M.Destination x <- fields]
sender = listToMaybe [x | M.Sender x <- fields]
msg = M.MethodReturn replySerial dest body
in M.ReceivedMethodReturn serial sender msg
buildReceivedMessage 3 fields = do
name <- require "error name" [x | M.ErrorName x <- fields]
replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]
return $ \serial _ body -> let
dest = listToMaybe [x | M.Destination x <- fields]
sender = listToMaybe [x | M.Sender x <- fields]
msg = M.Error name replySerial dest body
in M.ReceivedError serial sender msg
buildReceivedMessage 4 fields = do
path <- require "path" [x | M.Path x <- fields]
member <- require "member name" [x | M.Member x <- fields]
iface <- require "interface" [x | M.Interface x <- fields]
return $ \serial _ body -> let
dest = listToMaybe [x | M.Destination x <- fields]
sender = listToMaybe [x | M.Sender x <- fields]
msg = M.Signal path member iface dest body
in M.ReceivedSignal serial sender msg
buildReceivedMessage typeCode fields = return $ \serial flags body -> let
sender = listToMaybe [x | M.Sender x <- fields]
msg = M.Unknown typeCode flags body
in M.ReceivedUnknown serial sender msg
require :: Text -> [a] -> Either Text a
require _ (x:_) = Right x
require label _ = Left label
instance E.Error Text where
strMsg = TL.pack