module DBus.Types (
Type (..)
, typeCode
, Variant
, Variable (..)
, variantType
, Signature
, signatureTypes
, strSignature
, mkSignature
, mkSignature_
, ObjectPath
, strObjectPath
, mkObjectPath
, mkObjectPath_
, Array
, arrayType
, arrayItems
, toArray
, fromArray
, arrayFromItems
, arrayToBytes
, arrayFromBytes
, Dictionary
, dictionaryItems
, dictionaryKeyType
, dictionaryValueType
, toDictionary
, fromDictionary
, dictionaryFromItems
, dictionaryToArray
, arrayToDictionary
, Structure (..)
, BusName
, strBusName
, mkBusName
, mkBusName_
, InterfaceName
, strInterfaceName
, mkInterfaceName
, mkInterfaceName_
, ErrorName
, strErrorName
, mkErrorName
, mkErrorName_
, MemberName
, strMemberName
, mkMemberName
, mkMemberName_
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import qualified Data.Text as T
import Data.Ord (comparing)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)
import DBus.Util (mkUnsafe)
import qualified Data.String as String
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.ByteString as StrictByteString
import Data.List (intercalate)
import Control.Monad (unless)
import Control.Arrow ((***))
import qualified Data.Map as Map
import Control.Monad (forM)
data Type
= DBusBoolean
| DBusByte
| DBusInt16
| DBusInt32
| DBusInt64
| DBusWord16
| DBusWord32
| DBusWord64
| DBusDouble
| DBusString
| DBusSignature
| DBusObjectPath
| DBusVariant
| DBusArray Type
| DBusDictionary Type Type
| DBusStructure [Type]
deriving (Show, Eq)
isAtomicType :: Type -> Bool
isAtomicType DBusBoolean = True
isAtomicType DBusByte = True
isAtomicType DBusInt16 = True
isAtomicType DBusInt32 = True
isAtomicType DBusInt64 = True
isAtomicType DBusWord16 = True
isAtomicType DBusWord32 = True
isAtomicType DBusWord64 = True
isAtomicType DBusDouble = True
isAtomicType DBusString = True
isAtomicType DBusSignature = True
isAtomicType DBusObjectPath = True
isAtomicType _ = False
typeCode :: Type -> Text
typeCode DBusBoolean = "b"
typeCode DBusByte = "y"
typeCode DBusInt16 = "n"
typeCode DBusInt32 = "i"
typeCode DBusInt64 = "x"
typeCode DBusWord16 = "q"
typeCode DBusWord32 = "u"
typeCode DBusWord64 = "t"
typeCode DBusDouble = "d"
typeCode DBusString = "s"
typeCode DBusSignature = "g"
typeCode DBusObjectPath = "o"
typeCode DBusVariant = "v"
typeCode (DBusArray t) = TL.cons 'a' $ typeCode t
typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]
typeCode (DBusStructure ts) = TL.concat $
["("] ++ map typeCode ts ++ [")"]
data Variant
= VarBoxBool Bool
| VarBoxWord8 Word8
| VarBoxInt16 Int16
| VarBoxInt32 Int32
| VarBoxInt64 Int64
| VarBoxWord16 Word16
| VarBoxWord32 Word32
| VarBoxWord64 Word64
| VarBoxDouble Double
| VarBoxString Text
| VarBoxSignature Signature
| VarBoxObjectPath ObjectPath
| VarBoxVariant Variant
| VarBoxArray Array
| VarBoxDictionary Dictionary
| VarBoxStructure Structure
deriving (Eq)
class Variable a where
toVariant :: a -> Variant
fromVariant :: Variant -> Maybe a
instance Show Variant where
showsPrec d var = showParen (d > 10) full where
full = s "Variant " . shows code . s " " . valueStr
code = typeCode $ variantType var
s = showString
valueStr = showsPrecVar 11 var
showsPrecVar :: Int -> Variant -> ShowS
showsPrecVar d var = case var of
(VarBoxBool x) -> showsPrec d x
(VarBoxWord8 x) -> showsPrec d x
(VarBoxInt16 x) -> showsPrec d x
(VarBoxInt32 x) -> showsPrec d x
(VarBoxInt64 x) -> showsPrec d x
(VarBoxWord16 x) -> showsPrec d x
(VarBoxWord32 x) -> showsPrec d x
(VarBoxWord64 x) -> showsPrec d x
(VarBoxDouble x) -> showsPrec d x
(VarBoxString x) -> showsPrec d x
(VarBoxSignature x) -> showsPrec d x
(VarBoxObjectPath x) -> showsPrec d x
(VarBoxVariant x) -> showsPrec d x
(VarBoxArray x) -> showsPrec d x
(VarBoxDictionary x) -> showsPrec d x
(VarBoxStructure x) -> showsPrec d x
variantType :: Variant -> Type
variantType var = case var of
(VarBoxBool _) -> DBusBoolean
(VarBoxWord8 _) -> DBusByte
(VarBoxInt16 _) -> DBusInt16
(VarBoxInt32 _) -> DBusInt32
(VarBoxInt64 _) -> DBusInt64
(VarBoxWord16 _) -> DBusWord16
(VarBoxWord32 _) -> DBusWord32
(VarBoxWord64 _) -> DBusWord64
(VarBoxDouble _) -> DBusDouble
(VarBoxString _) -> DBusString
(VarBoxSignature _) -> DBusSignature
(VarBoxObjectPath _) -> DBusObjectPath
(VarBoxVariant _) -> DBusVariant
(VarBoxArray x) -> DBusArray (arrayType x)
(VarBoxDictionary x) -> let
keyT = dictionaryKeyType x
valueT = dictionaryValueType x
in DBusDictionary keyT valueT
(VarBoxStructure x) -> let
Structure items = x
in DBusStructure (map variantType items)
instance Variable Variant where { toVariant = VarBoxVariant ; fromVariant (VarBoxVariant x) = Just x ; fromVariant _ = Nothing }
instance Variable Bool where { toVariant = VarBoxBool ; fromVariant (VarBoxBool x) = Just x ; fromVariant _ = Nothing }
instance Variable Word8 where { toVariant = VarBoxWord8 ; fromVariant (VarBoxWord8 x) = Just x ; fromVariant _ = Nothing }
instance Variable Int16 where { toVariant = VarBoxInt16 ; fromVariant (VarBoxInt16 x) = Just x ; fromVariant _ = Nothing }
instance Variable Int32 where { toVariant = VarBoxInt32 ; fromVariant (VarBoxInt32 x) = Just x ; fromVariant _ = Nothing }
instance Variable Int64 where { toVariant = VarBoxInt64 ; fromVariant (VarBoxInt64 x) = Just x ; fromVariant _ = Nothing }
instance Variable Word16 where { toVariant = VarBoxWord16 ; fromVariant (VarBoxWord16 x) = Just x ; fromVariant _ = Nothing }
instance Variable Word32 where { toVariant = VarBoxWord32 ; fromVariant (VarBoxWord32 x) = Just x ; fromVariant _ = Nothing }
instance Variable Word64 where { toVariant = VarBoxWord64 ; fromVariant (VarBoxWord64 x) = Just x ; fromVariant _ = Nothing }
instance Variable Double where { toVariant = VarBoxDouble ; fromVariant (VarBoxDouble x) = Just x ; fromVariant _ = Nothing }
instance Variable TL.Text where
toVariant = VarBoxString
fromVariant (VarBoxString x) = Just x
fromVariant _ = Nothing
instance Variable T.Text where
toVariant = toVariant . TL.fromChunks . (:[])
fromVariant = fmap (T.concat . TL.toChunks) . fromVariant
instance Variable String where
toVariant = toVariant . TL.pack
fromVariant = fmap TL.unpack . fromVariant
instance Variable Signature where { toVariant = VarBoxSignature ; fromVariant (VarBoxSignature x) = Just x ; fromVariant _ = Nothing }
data Signature = Signature { signatureTypes :: [Type] }
deriving (Eq)
instance Show Signature where
showsPrec d x = showParen (d > 10) $
showString "Signature " . shows (strSignature x)
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts
instance Ord Signature where
compare = comparing strSignature
mkSignature :: Text -> Maybe Signature
mkSignature text = parsed where
just t = Just $ Signature [t]
fast = case TL.head text of
'b' -> just DBusBoolean
'y' -> just DBusByte
'n' -> just DBusInt16
'i' -> just DBusInt32
'x' -> just DBusInt64
'q' -> just DBusWord16
'u' -> just DBusWord32
't' -> just DBusWord64
'd' -> just DBusDouble
's' -> just DBusString
'g' -> just DBusSignature
'o' -> just DBusObjectPath
'v' -> just DBusVariant
_ -> Nothing
slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text
sigParser = do
types <- P.many parseType
P.eof
return $ Signature types
parseType = parseAtom <|> parseContainer
parseContainer =
parseArray
<|> parseStruct
<|> (P.char 'v' >> return DBusVariant)
parseArray = do
P.char 'a'
parseDict <|> fmap DBusArray parseType
parseDict = do
P.char '{'
keyType <- parseAtom
valueType <- parseType
P.char '}'
return $ DBusDictionary keyType valueType
parseStruct = do
P.char '('
types <- P.many parseType
P.char ')'
return $ DBusStructure types
parseAtom =
(P.char 'b' >> return DBusBoolean)
<|> (P.char 'y' >> return DBusByte)
<|> (P.char 'n' >> return DBusInt16)
<|> (P.char 'i' >> return DBusInt32)
<|> (P.char 'x' >> return DBusInt64)
<|> (P.char 'q' >> return DBusWord16)
<|> (P.char 'u' >> return DBusWord32)
<|> (P.char 't' >> return DBusWord64)
<|> (P.char 'd' >> return DBusDouble)
<|> (P.char 's' >> return DBusString)
<|> (P.char 'g' >> return DBusSignature)
<|> (P.char 'o' >> return DBusObjectPath)
parsed = case TL.length text of
0 -> Just $ Signature []
1 -> fast
_ -> slow
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature
instance String.IsString Signature where
fromString = mkSignature_ . TL.pack
instance Variable ObjectPath where { toVariant = VarBoxObjectPath ; fromVariant (VarBoxObjectPath x) = Just x ; fromVariant _ = Nothing }
newtype ObjectPath = ObjectPath
{ strObjectPath :: Text
}
deriving (Eq, Ord)
instance Show ObjectPath where
showsPrec d (ObjectPath x) = showParen (d > 10) $
showString "ObjectPath " . shows x
instance String.IsString ObjectPath where
fromString = mkObjectPath_ . TL.pack
mkObjectPath :: Text -> Maybe ObjectPath
mkObjectPath s = parseMaybe path' (TL.unpack s) where
c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char
path' = path >> P.eof >> return (ObjectPath s)
mkObjectPath_ :: Text -> ObjectPath
mkObjectPath_ = mkUnsafe "object path" mkObjectPath
instance Variable Array where { toVariant = VarBoxArray ; fromVariant (VarBoxArray x) = Just x ; fromVariant _ = Nothing }
data Array
= VariantArray Type [Variant]
| ByteArray ByteString
deriving (Eq)
arrayType :: Array -> Type
arrayType (VariantArray t _) = t
arrayType (ByteArray _) = DBusByte
arrayItems :: Array -> [Variant]
arrayItems (VariantArray _ xs) = xs
arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs
instance Show Array where
showsPrec d array = showParen (d > 10) $
s "Array " . showSig . s " [" . s valueString . s "]" where
s = showString
showSig = shows . typeCode . arrayType $ array
showVar var = showsPrecVar 0 var ""
valueString = intercalate ", " $ map showVar $ arrayItems array
arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)
arrayFromItems t vs = do
mkSignature (typeCode t)
if all (\x -> variantType x == t) vs
then Just $ VariantArray t vs
else Nothing
toArray :: Variable a => Type -> [a] -> Maybe Array
toArray t = arrayFromItems t . map toVariant
fromArray :: Variable a => Array -> Maybe [a]
fromArray = mapM fromVariant . arrayItems
arrayToBytes :: Array -> Maybe ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _ = Nothing
arrayFromBytes :: ByteString -> Array
arrayFromBytes = ByteArray
instance Variable ByteString where
toVariant = toVariant . arrayFromBytes
fromVariant x = fromVariant x >>= arrayToBytes
instance Variable StrictByteString.ByteString where
toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]
fromVariant x = do
chunks <- ByteString.toChunks `fmap` fromVariant x
return $ StrictByteString.concat chunks
instance Variable Dictionary where { toVariant = VarBoxDictionary ; fromVariant (VarBoxDictionary x) = Just x ; fromVariant _ = Nothing }
data Dictionary = Dictionary
{ dictionaryKeyType :: Type
, dictionaryValueType :: Type
, dictionaryItems :: [(Variant, Variant)]
}
deriving (Eq)
instance Show Dictionary where
showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $
s "Dictionary " . showSig . s " {" . s valueString . s "}" where
s = showString
showSig = shows $ TL.append (typeCode kt) (typeCode vt)
valueString = intercalate ", " $ map showPair pairs
showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""
dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary
dictionaryFromItems kt vt pairs = do
unless (isAtomicType kt) Nothing
mkSignature (typeCode kt)
mkSignature (typeCode vt)
let sameType (k, v) = variantType k == kt &&
variantType v == vt
if all sameType pairs
then Just $ Dictionary kt vt pairs
else Nothing
toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b
-> Maybe Dictionary
toDictionary kt vt = dictionaryFromItems kt vt . pairs where
pairs = map (toVariant *** toVariant) . Map.toList
fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary
-> Maybe (Map.Map a b)
fromDictionary (Dictionary _ _ vs) = do
pairs <- forM vs $ \(k, v) -> do
k' <- fromVariant k
v' <- fromVariant v
return (k', v')
return $ Map.fromList pairs
dictionaryToArray :: Dictionary -> Array
dictionaryToArray (Dictionary kt vt items) = array where
Just array = toArray itemType structs
itemType = DBusStructure [kt, vt]
structs = [Structure [k, v] | (k, v) <- items]
arrayToDictionary :: Array -> Maybe Dictionary
arrayToDictionary array = do
let toPair x = do
struct <- fromVariant x
case struct of
Structure [k, v] -> Just (k, v)
_ -> Nothing
(kt, vt) <- case arrayType array of
DBusStructure [kt, vt] -> Just (kt, vt)
_ -> Nothing
pairs <- mapM toPair $ arrayItems array
dictionaryFromItems kt vt pairs
instance Variable Structure where { toVariant = VarBoxStructure ; fromVariant (VarBoxStructure x) = Just x ; fromVariant _ = Nothing }
data Structure = Structure [Variant]
deriving (Show, Eq)
newtype BusName = BusName {strBusName :: Text} deriving (Eq, Ord); instance Show BusName where { showsPrec d (BusName x) = showParen (d > 10) $ showString "BusName " . shows x }; instance String.IsString BusName where { fromString = mkBusName_ . TL.pack }; instance Variable BusName where { toVariant = toVariant . strBusName ; fromVariant = (mkBusName =<<) . fromVariant }; mkBusName_ :: Text -> BusName; mkBusName_ = mkUnsafe "bus name" mkBusName
mkBusName :: Text -> Maybe BusName
mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"
c' = c ++ ['0'..'9']
parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)
unique = P.char ':' >> elems c'
wellKnown = elems c
elems start = elem' start >> P.many1 (P.char '.' >> elem' start)
elem' start = P.oneOf start >> P.many (P.oneOf c')
newtype InterfaceName = InterfaceName {strInterfaceName :: Text} deriving (Eq, Ord); instance Show InterfaceName where { showsPrec d (InterfaceName x) = showParen (d > 10) $ showString "InterfaceName " . shows x }; instance String.IsString InterfaceName where { fromString = mkInterfaceName_ . TL.pack }; instance Variable InterfaceName where { toVariant = toVariant . strInterfaceName ; fromVariant = (mkInterfaceName =<<) . fromVariant }; mkInterfaceName_ :: Text -> InterfaceName; mkInterfaceName_ = mkUnsafe "interface name" mkInterfaceName
mkInterfaceName :: Text -> Maybe InterfaceName
mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
c' = c ++ ['0'..'9']
element = P.oneOf c >> P.many (P.oneOf c')
name = element >> P.many1 (P.char '.' >> element)
parser = name >> P.eof >> return (InterfaceName s)
newtype ErrorName = ErrorName {strErrorName :: Text} deriving (Eq, Ord); instance Show ErrorName where { showsPrec d (ErrorName x) = showParen (d > 10) $ showString "ErrorName " . shows x }; instance String.IsString ErrorName where { fromString = mkErrorName_ . TL.pack }; instance Variable ErrorName where { toVariant = toVariant . strErrorName ; fromVariant = (mkErrorName =<<) . fromVariant }; mkErrorName_ :: Text -> ErrorName; mkErrorName_ = mkUnsafe "error name" mkErrorName
mkErrorName :: Text -> Maybe ErrorName
mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName
newtype MemberName = MemberName {strMemberName :: Text} deriving (Eq, Ord); instance Show MemberName where { showsPrec d (MemberName x) = showParen (d > 10) $ showString "MemberName " . shows x }; instance String.IsString MemberName where { fromString = mkMemberName_ . TL.pack }; instance Variable MemberName where { toVariant = toVariant . strMemberName ; fromVariant = (mkMemberName =<<) . fromVariant }; mkMemberName_ :: Text -> MemberName; mkMemberName_ = mkUnsafe "member name" mkMemberName
mkMemberName :: Text -> Maybe MemberName
mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
c' = c ++ ['0'..'9']
name = P.oneOf c >> P.many (P.oneOf c')
parser = name >> P.eof >> return (MemberName s)