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.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 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 ++ [")"]
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)
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 String.IsString Signature where
fromString = mkSignature_ . TL.pack
instance Builtin ObjectPath where { builtinDBusType _ = DBusObjectPath }; instance Variable ObjectPath where { toVariant = Variant ; fromVariant (Variant x) = cast x };
newtype ObjectPath = ObjectPath
{ strObjectPath :: Text
}
deriving (Eq, Ord, Typeable)
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 = Variant ; fromVariant (Variant x) = cast x };
data Array
= VariantArray Type [Variant]
| ByteArray ByteString
deriving (Eq, Typeable)
instance Builtin Array where
builtinDBusType = DBusArray . arrayType
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
vs = [show x | (Variant x) <- arrayItems array]
valueString = intercalate ", " vs
arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems DBusByte vs = do
bytes <- mapM fromVariant vs
Just . ByteArray . ByteString.pack $ bytes
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 = 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 = 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 = 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 (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)