module DBus.Types (
Type (..)
, typeCode
, Variant
, Variable (..)
, variantType
, Signature
, signatureTypes
, strSignature
, mkSignature
, mkSignature'
, ObjectPath
, strObjectPath
, mkObjectPath
, mkObjectPath'
, Array
, arrayType
, arrayItems
, toArray
, fromArray
, arrayFromItems
, 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.Typeable (Typeable, cast)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import qualified Data.Text as T
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)
import DBus.Util (mkUnsafe)
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
class (Show a, Eq a) => Builtin a where
builtinDBusType :: a -> Type
data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a
deriving (Typeable)
class Variable a where
toVariant :: a -> Variant
fromVariant :: Variant -> Maybe a
instance Show Variant where
showsPrec d (Variant x) = showParen (d > 10) $
s "Variant " . shows code . s " " . showsPrec 11 x
where code = typeCode . builtinDBusType $ x
s = showString
instance Eq Variant where
(Variant x) == (Variant y) = cast x == Just y
variantType :: Variant -> Type
variantType (Variant x) = builtinDBusType x
instance Builtin Variant where { builtinDBusType _ = DBusVariant }; instance Variable Variant where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Bool where { builtinDBusType _ = DBusBoolean }; instance Variable Bool where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Word8 where { builtinDBusType _ = DBusByte }; instance Variable Word8 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Int16 where { builtinDBusType _ = DBusInt16 }; instance Variable Int16 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Int32 where { builtinDBusType _ = DBusInt32 }; instance Variable Int32 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Int64 where { builtinDBusType _ = DBusInt64 }; instance Variable Int64 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Word16 where { builtinDBusType _ = DBusWord16 }; instance Variable Word16 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Word32 where { builtinDBusType _ = DBusWord32 }; instance Variable Word32 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Word64 where { builtinDBusType _ = DBusWord64 }; instance Variable Word64 where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin Double where { builtinDBusType _ = DBusDouble }; instance Variable Double where { toVariant = Variant ; fromVariant (Variant x) = cast x };
instance Builtin TL.Text where { builtinDBusType _ = DBusString }; instance Variable TL.Text where { toVariant = Variant ; fromVariant (Variant x) = cast x };
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 Builtin Signature where { builtinDBusType _ = DBusSignature }; instance Variable Signature where { toVariant = Variant ; fromVariant (Variant x) = cast x };
data Signature = Signature { signatureTypes :: [Type] }
deriving (Eq, Typeable)
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 x y = compare (strSignature x) (strSignature y)
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 ++ [")"]
mkSignature :: Text -> Maybe Signature
mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where
sigParser = do
types <- P.many parseType
P.eof
return $ Signature types
parseType = parseAtom <|> parseContainer
parseContainer =
parseArray
<|> parseStruct
<|> (P.char 'v' >> return DBusVariant)
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)
parseArray = do
P.char 'a'
parseDict <|> do
t <- parseType
return $ DBusArray t
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
mkSignature' :: Text -> Signature
mkSignature' = mkUnsafe "signature" mkSignature
instance Builtin ObjectPath where { builtinDBusType _ = DBusObjectPath }; instance Variable ObjectPath where { toVariant = Variant ; fromVariant (Variant x) = cast x };
newtype ObjectPath = ObjectPath
{ strObjectPath :: Text
}
deriving (Show, Eq, Ord, Typeable)
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 = Variant ; fromVariant (Variant x) = cast x };
data Array = Array
{ arrayType :: Type
, arrayItems :: [Variant]
}
deriving (Eq, Typeable)
instance Builtin Array where
builtinDBusType = DBusArray . arrayType
instance Show Array where
showsPrec d (Array t vs) = showParen (d > 10) $
s "Array " . showSig . s " [" . s valueString . s "]" where
s = showString
showSig = shows $ typeCode t
vs' = [show x | (Variant x) <- vs]
valueString = intercalate ", " vs'
arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems t vs = do
mkSignature (typeCode t)
if all (\x -> variantType x == t) vs
then Just $ Array 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
instance Variable Dictionary where { toVariant = Variant ; fromVariant (Variant x) = cast x };
data Dictionary = Dictionary
{ dictionaryKeyType :: Type
, dictionaryValueType :: Type
, dictionaryItems :: [(Variant, Variant)]
}
deriving (Eq, Typeable)
instance Builtin Dictionary where
builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt
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 ((Variant k), (Variant v)) =
show k ++ " -> " ++ show 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 t items) = do
let toPair x = do
struct <- fromVariant x
case struct of
Structure [k, v] -> Just (k, v)
_ -> Nothing
(kt, vt) <- case t of
DBusStructure [kt, vt] -> Just (kt, vt)
_ -> Nothing
pairs <- mapM toPair items
dictionaryFromItems kt vt pairs
instance Variable Structure where { toVariant = Variant ; fromVariant (Variant x) = cast x };
data Structure = Structure [Variant]
deriving (Show, Eq, Typeable)
instance Builtin Structure where
builtinDBusType (Structure vs) = DBusStructure $ map variantType vs
newtype BusName = BusName {strBusName :: Text} deriving (Show, Eq, Ord); 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 (Show, Eq, Ord); 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 (Show, Eq, Ord); 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 (Show, Eq, Ord); 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)