# 1 "hs/DBus/Types/Internal.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 10 "<command-line>"
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 10 "<command-line>" 2
# 1 "hs/DBus/Types/Internal.cpphs"
module DBus.Types.Internal 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 Data.Text.Encoding (decodeUtf8)
import qualified Data.ByteString.Unsafe as B
import qualified Foreign as F
import System.IO.Unsafe (unsafePerformIO)
import Data.Text.Lazy.Encoding (encodeUtf8)
import DBus.Util (mkUnsafe)
import qualified Data.String as String
import Text.ParserCombinators.Parsec ((<|>))
import qualified Text.ParserCombinators.Parsec as P
import DBus.Util (checkLength, parseMaybe)
import Data.List (intercalate)
import Control.Monad (unless)
import Control.Arrow ((***))
import qualified Data.Map as Map
import Control.Monad (forM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BL8
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 t = TL.fromChunks [decodeUtf8 $ typeCodeB t]
typeCodeB :: Type -> B.ByteString
typeCodeB DBusBoolean = "b"
typeCodeB DBusByte = "y"
typeCodeB DBusInt16 = "n"
typeCodeB DBusInt32 = "i"
typeCodeB DBusInt64 = "x"
typeCodeB DBusWord16 = "q"
typeCodeB DBusWord32 = "u"
typeCodeB DBusWord64 = "t"
typeCodeB DBusDouble = "d"
typeCodeB DBusString = "s"
typeCodeB DBusSignature = "g"
typeCodeB DBusObjectPath = "o"
typeCodeB DBusVariant = "v"
typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t
typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"]
typeCodeB (DBusStructure ts) = B.concat $
["("] ++ map typeCodeB 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)
variantSignature :: Variant -> Maybe Signature
variantSignature = mkBytesSignature . typeCodeB . variantType
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)
bytesSignature :: Signature -> B.ByteString
bytesSignature (Signature ts) = B.concat $ map typeCodeB ts
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts
instance Ord Signature where
compare = comparing strSignature
mkBytesSignature :: B.ByteString -> Maybe Signature
mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where
parseAtom c yes no = case c of
0x62 -> yes DBusBoolean
0x79 -> yes DBusByte
0x6E -> yes DBusInt16
0x69 -> yes DBusInt32
0x78 -> yes DBusInt64
0x71 -> yes DBusWord16
0x75 -> yes DBusWord32
0x74 -> yes DBusWord64
0x64 -> yes DBusDouble
0x73 -> yes DBusString
0x67 -> yes DBusSignature
0x6F -> yes DBusObjectPath
_ -> no
fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of
0x76 -> Just (Signature [DBusVariant])
_ -> Nothing
slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature)
slow buf len = loop [] 0 where
loop acc ii | ii >= len = return . Just . Signature $ reverse acc
loop acc ii = do
c <- F.peekElemOff buf ii
let next t = loop (t : acc) (ii + 1)
parseAtom c next $ case c of
0x76 -> next DBusVariant
0x28 -> do
mt <- structure buf len (ii + 1)
case mt of
Just (ii', t) -> loop (t : acc) ii'
Nothing -> return Nothing
0x61 -> do
mt <- array buf len (ii + 1)
case mt of
Just (ii', t) -> loop (t : acc) ii'
Nothing -> return Nothing
_ -> return Nothing
structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
structure buf len = loop [] where
loop _ ii | ii >= len = return Nothing
loop acc ii = do
c <- F.peekElemOff buf ii
let next t = loop (t : acc) (ii + 1)
parseAtom c next $ case c of
0x76 -> next DBusVariant
0x28 -> do
mt <- structure buf len (ii + 1)
case mt of
Just (ii', t) -> loop (t : acc) ii'
Nothing -> return Nothing
0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc))
0x61 -> do
mt <- array buf len (ii + 1)
case mt of
Just (ii', t) -> loop (t : acc) ii'
Nothing -> return Nothing
_ -> return Nothing
array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
array _ len ii | ii >= len = return Nothing
array buf len ii = do
c <- F.peekElemOff buf ii
let next t = return $ Just (ii + 1, DBusArray t)
parseAtom c next $ case c of
0x76 -> next DBusVariant
0x28 -> do
mt <- structure buf len (ii + 1)
case mt of
Just (ii', t) -> return $ Just (ii', DBusArray t)
Nothing -> return Nothing
0x7B -> dict buf len (ii + 1)
0x61 -> do
mt <- array buf len (ii + 1)
case mt of
Just (ii', t) -> return $ Just (ii', DBusArray t)
Nothing -> return Nothing
_ -> return Nothing
dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type))
dict _ len ii | ii + 1 >= len = return Nothing
dict buf len ii = do
c1 <- F.peekElemOff buf ii
c2 <- F.peekElemOff buf (ii + 1)
let mt1 = parseAtom c1 Just Nothing
let next t = return $ Just (ii + 2, t)
mt2 <- parseAtom c2 next $ case c2 of
0x76 -> next DBusVariant
0x28 -> structure buf len (ii + 2)
0x61 -> array buf len (ii + 2)
_ -> return Nothing
case mt2 of
Nothing -> return Nothing
Just (ii', t2) -> if ii' >= len
then return Nothing
else do
c3 <- F.peekElemOff buf ii'
return $ do
if c3 == 0x7D then Just () else Nothing
t1 <- mt1
Just (ii' + 1, DBusDictionary t1 t2)
io (cstr, len) = case len of
0 -> return $ Just $ Signature []
1 -> fmap fast $ F.peek cstr
_ | len <= 255 -> slow (F.castPtr cstr) len
_ -> return Nothing
mkSignature :: Text -> Maybe Signature
mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8
mkSignature_ :: Text -> Signature
mkSignature_ = mkUnsafe "signature" mkSignature
instance String.IsString Signature where
fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack
maybeValidType :: Type -> Maybe ()
maybeValidType t = if B.length (typeCodeB t) > 255
then Nothing
else Just ()
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 BL.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 $ BL.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 . BL.pack) (mapM fromVariant vs)
arrayFromItems t vs = do
maybeValidType 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 BL.ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _ = Nothing
arrayFromBytes :: BL.ByteString -> Array
arrayFromBytes = ByteArray
instance Variable BL.ByteString where
toVariant = toVariant . arrayFromBytes
fromVariant x = fromVariant x >>= arrayToBytes
instance Variable B.ByteString where
toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x]
fromVariant = fmap (B.concat . BL.toChunks) . fromVariant
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
maybeValidType kt
maybeValidType 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)
# 587 "hs/DBus/Types/Internal.cpphs"
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)