d-bus 0.1.6 → 0.1.7
raw patch · 20 files changed
+443/−369 lines, 20 files
Files
- LICENSE +1/−1
- d-bus.cabal +3/−1
- src/DBus.hs +16/−14
- src/DBus/Auth.hs +17/−12
- src/DBus/Error.hs +14/−4
- src/DBus/Introspect.hs +13/−13
- src/DBus/MainLoop.hs +90/−76
- src/DBus/Message.hs +71/−48
- src/DBus/MessageBus.hs +16/−14
- src/DBus/Method.hs +7/−4
- src/DBus/Object.hs +7/−17
- src/DBus/Property.hs +5/−7
- src/DBus/Representable.hs +19/−18
- src/DBus/Scaffold.hs +13/−24
- src/DBus/Signal.hs +16/−13
- src/DBus/Signature.hs +22/−17
- src/DBus/TH.hs +17/−14
- src/DBus/Transport.hs +11/−14
- src/DBus/Types.hs +60/−39
- src/DBus/Wire.hs +25/−19
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013 dbus-magic+Copyright (c) 2013-2017 Philipp Balzarek Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
d-bus.cabal view
@@ -1,5 +1,5 @@ name: d-bus-version: 0.1.6+version: 0.1.7 synopsis: Permissively licensed D-Bus client library description: This library uses modern extensions to the Haskell type system (including GADTs, DataKinds and TypeFamilies) and the@@ -66,7 +66,9 @@ c-sources: src/cbits/credentials.c cpp-options: -DSEND_CREDENTIALS }+ ghc-options: -Wall default-language: Haskell2010+ default-extensions: DataKinds , DeriveDataTypeable , FlexibleContexts
src/DBus.hs view
@@ -11,6 +11,7 @@ , SignalHandler , checkAlive , waitFor+ , close -- * Message handling , objectRoot , ignore@@ -102,26 +103,27 @@ -- * Scaffolding , module DBus.Scaffold -- * Re-exports- , def+ , SingI (..) ) where import qualified Data.ByteString as BS -import DBus.Auth-import DBus.Introspect-import DBus.MainLoop-import DBus.Message-import DBus.MessageBus-import DBus.Object-import DBus.Property-import DBus.Method-import DBus.Signal-import DBus.TH-import DBus.Types-import DBus.Scaffold-import Data.Default (def)+import DBus.Auth+import DBus.Introspect+import DBus.MainLoop+import DBus.Message+import DBus.MessageBus+import DBus.Method+import DBus.Property+import DBus.Scaffold+import DBus.Signal+import DBus.TH+import DBus.Types+import Data.Default (def)+import Data.Singletons -- | Ignore all incoming messages/signals+ignore :: Monad m => a -> b -> c -> m () ignore _ _ _ = return ()
src/DBus/Auth.hs view
@@ -7,7 +7,6 @@ module DBus.Auth where -import Control.Applicative import Control.Monad.Except import Control.Monad.Free import qualified Data.Attoparsec.ByteString as AP@@ -32,21 +31,24 @@ | SMData BS.ByteString deriving (Show) +space :: AP.Parser BS.ByteString -> AP.Parser BS.ByteString space x = (AP8.char8 ' ' >> x) `mplus` (return "") + parseHexString :: AP.Parser BS.ByteString parseHexString = space $ (BS.pack <$> AP.many' parseHexChar) parseHexChar :: AP.Parser Word8 parseHexChar = do- hi <- fromHex <$> AP.satisfy isHexDigit- lo <- fromHex <$> AP.satisfy isHexDigit+ hi <- fromHex =<< AP.satisfy isHexDigit+ lo <- fromHex =<< AP.satisfy isHexDigit return $ (hi `shiftL` 4) .|. lo where isHexDigit w = (w >= 48 && w <= 57) || (w >= 97 && w <= 102)- fromHex w | w >= 48 && w <= 57 = fromIntegral (w - 48)- | w >= 97 = fromIntegral (w - 87)+ fromHex w | w >= 48 && w <= 57 = return $ fromIntegral (w - 48)+ | w >= 97 = return $ fromIntegral (w - 87)+ fromHex w = fail $ "Not a hex character: " <> show w @@ -63,9 +65,9 @@ -> AP.Parser t -> AP.Parser a parseLine command cons args = do- AP.string command+ _ <- AP.string command res <- args- AP.string "\r"+ _ <- AP.string "\r" return $ cons res parseWords :: AP.Parser [BS.ByteString]@@ -99,10 +101,12 @@ deriving (Show) +serializeLine :: BS.ByteString -> BS.Builder -> BS.Builder serializeLine command rest = BS.byteString command <> BS.char8 ' ' <> rest <> BS.byteString "\r\n" +serializeCMessage :: ClientMessage -> BS.Builder serializeCMessage (CMAuth mechanism response) = serializeLine "AUTH" $ if BS.null mechanism then mempty@@ -154,7 +158,7 @@ -> SASL b -> m (Either String b) runSasl snd' rcv' (SASL s) = do- let snd = snd' . serializeCMessage+ let sd = snd' . serializeCMessage rcv = do bs <- rcv' case AP.parseOnly parseServerLine bs of@@ -164,17 +168,18 @@ ++ ": " ++ show e Right r -> return r return ()- res <- go snd rcv (runExceptT s)+ res <- go sd rcv (runExceptT s) case res of Left e -> do- snd (CMCancel)+ _ <- sd CMCancel return $ Left e Right r -> return $ Right r where go _ _ (Pure x) = return x- go snd rcv (Free (Send x f)) = snd x >> go snd rcv f- go snd rcv (Free (Recv f )) = rcv >>= go snd rcv . f+ go sd rcv (Free (Send x f)) = sd x >> go sd rcv f+ go sd rcv (Free (Recv f )) = rcv >>= go sd rcv . f +sasl :: SASL ServerMessage sasl = do saslSend (CMAuth "" "") saslRecv
src/DBus/Error.hs view
@@ -3,10 +3,11 @@ module DBus.Error where -import Control.Exception as Ex-import Data.Typeable (Typeable)+import Control.Exception as Ex+import Data.Text (Text)+import Data.Typeable (Typeable) -import DBus.Types+import DBus.Types data DBusError = CouldNotConnect String | DBusParseError String@@ -15,13 +16,22 @@ instance Ex.Exception DBusError +errorFailed :: Text -> MsgError errorFailed msg = (MsgError "org.freedesktop.DBus.Error.Failed" (Just msg) []) --- noSuchInterface, noSuchProperty, propertyNotReadable, propertyNotReadable+noSuchInterface :: MsgError noSuchInterface = errorFailed "No such interface"++noSuchProperty :: MsgError noSuchProperty = errorFailed "No such property"++propertyNotReadable :: MsgError propertyNotReadable = errorFailed "Property is not readable"++propertyNotWriteable :: MsgError propertyNotWriteable = errorFailed "Property is not writeable"++argTypeMismatch :: MsgError argTypeMismatch = errorFailed "Argument type mismatch"
src/DBus/Introspect.hs view
@@ -10,7 +10,6 @@ import Blaze.ByteString.Builder import Control.Applicative ((<$>)) import Control.Exception (SomeException)-import Control.Monad import qualified Data.ByteString as BS import Data.Conduit (($$), ($=)) import Data.Conduit.List (consume, sourceList)@@ -25,7 +24,6 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy as LText import Data.Typeable (Typeable) import Data.XML.Pickle hiding (Result) import Data.XML.Types@@ -33,8 +31,6 @@ import Text.XML.Stream.Render import Text.XML.Unresolved (toEvents, fromEvents) -import DBus.Object-import DBus.Representable import DBus.Signature import DBus.Types import DBus.Method@@ -99,8 +95,8 @@ } deriving (Eq, Show, Data, Typeable) xpAnnotation :: PU [Node] Annotation-xpAnnotation = xpWrap (\(name, content) -> Annotation name content)- (\(Annotation name content) -> (name, content)) $+xpAnnotation = xpWrap (\(name, content') -> Annotation name content')+ (\(Annotation name content') -> (name, content')) $ xpElemAttrs "annotation" (xp2Tuple (xpAttribute "name" xpText) (xpAttribute "value" xpText))@@ -112,6 +108,7 @@ xpDirection :: PU Text IDirection xpDirection = xpPartial directionFromText directionToText +xpPropertyAccess :: PU Text PropertyAccess xpPropertyAccess = xpPartial propertyAccessFromText propertyAccessToText xpArgument :: PU [Node] IArgument@@ -201,9 +198,9 @@ doc = Document prologue (pickle (xpRoot . xpUnliftElems $ xpNode) node) [] introspectMethods :: [Method] -> [IMethod]-introspectMethods = map introspectMethod+introspectMethods = map introspectMethod' where- introspectMethod m = IMethod (methodName m) (toArgs m) []+ introspectMethod' m = IMethod (methodName m) (toArgs m) [] toArgs m@(Method _ _ argDs resDs) = let (args, res) = methodSignature m (ts, rs) = argDescriptions argDs resDs@@ -383,9 +380,11 @@ hasInterface :: Text -> Map Text Interface -> Bool hasInterface iname o = isJust $ Map.lookup iname o +uncurry3 :: (t3 -> t2 -> t1 -> t) -> (t3, t2, t1) -> t uncurry3 f (x, y, z) = f x y z -introspectObjects path recursive objs@(Objects os) =+introspectObjects :: ObjectPath -> Bool -> Objects -> INode+introspectObjects path recursive (Objects os) = case Map.updateLookupWithKey (\_ _ -> Nothing) path os of (Nothing, _) -> let oss = Map.mapKeys (fromMaybe "" . stripObjectPrefix path) os@@ -401,17 +400,18 @@ introspect :: ObjectPath -> Bool -> Objects -> Text-introspect path recursive object = Text.decodeUtf8 . nodeToXml- $ introspectObjects path recursive object+introspect path recursive object' = Text.decodeUtf8 . nodeToXml+ $ introspectObjects path recursive object' introspectMethod :: ObjectPath -> Bool -> Objects -> Method-introspectMethod path recursive object =- Method (repMethod $ (return (introspect path recursive object) :: IO Text))+introspectMethod path recursive object' =+ Method (repMethod $ (return (introspect path recursive object') :: IO Text)) "Introspect" Done ("xml_data" :> Done) +introspectableInterface :: ObjectPath -> Bool -> Objects -> Interface introspectableInterface path recursive o = Interface{ interfaceMethods = [introspectMethod path recursive o] , interfaceSignals = []
src/DBus/MainLoop.hs view
@@ -10,43 +10,28 @@ module DBus.MainLoop where -import Control.Applicative import Control.Concurrent import Control.Concurrent.Async-import Control.Concurrent.MVar import Control.Concurrent.STM-import qualified Control.Exception as Ex+import qualified Control.Exception as Ex import Control.Monad-import Control.Monad.Catch (MonadThrow, throwM)-import Control.Monad.Fix (mfix)+import Control.Monad.Catch (throwM)+import Control.Monad.Fix (mfix) import Control.Monad.Trans-import Data.Binary.Get as B-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS-import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Text as CT-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Singletons-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Typeable (Typeable)-import Data.Word-import Foreign.C-import Network.Socket+import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Network.Socket (Socket, socketToHandle)+import Network.Socket.ByteString (send) import System.Environment import System.IO import System.Log.Logger-import System.Mem.Weak -import Data.Attoparsec.ByteString as AP-import Data.List (intercalate)-import Data.Monoid-import Numeric- import DBus.Auth import DBus.Error import DBus.Message@@ -54,9 +39,7 @@ import DBus.Object import DBus.Transport import DBus.Types-import DBus.Wire import DBus.Signal-import DBus.Property import DBus.Introspect handleMessage :: (MessageHeader -> [SomeDBusValue] -> IO ())@@ -79,7 +62,7 @@ handleCall header body MessageTypeMethodReturn -> handleReturn True MessageTypeError -> handleError- MessageTypeSignal -> handleSignal+ MessageTypeSignal -> handleSignal' _ -> return () where handleReturn nonError = case hFReplySerial $ fields header of@@ -95,9 +78,9 @@ else Left body handleError = case hFReplySerial $ fields header of Nothing -> return () -- TODO: handle non-response errors- Just s -> handleReturn False- handleSignal = do- handleSignals header body+ Just _ -> handleReturn False+ handleSignal' = do+ _ <- handleSignals header body sSlots <- atomically $ readTVar signalSlots let fs = fields header case () of@@ -108,10 +91,10 @@ -> case (iface, member) of ( "org.freedesktop.DBus.Properties" ,"PropertiesChanged")- | [DBV pi, DBV uds, DBV invs] <- body- , Just propIface <- fromRep =<< castDBV pi :: Maybe Text+ | [DBV pi', DBV uds, DBV invs] <- body+ , Just propIface <- fromRep =<< castDBV pi' :: Maybe Text , Just updates <- fromRep =<< castDBV uds- :: Maybe (Map Text (DBusValue TypeVariant))+ :: Maybe (Map Text (DBusValue 'TypeVariant)) , Just ivs <- (fromRep =<< castDBV invs :: Maybe [Text]) -> handlePropertyUpdates path propIface updates ivs _ -> case filter (match4 ( Match iface@@ -158,7 +141,7 @@ logDebug $ "Recevied property updates " ++ show updates ++ " and invalidated propertied " ++ show ivs forM_ hs $ \h -> forkIO $ h v- variantToDBV :: DBusValue TypeVariant -> SomeDBusValue+ variantToDBV :: DBusValue 'TypeVariant -> SomeDBusValue variantToDBV (DBVVariant v) = DBV v -- | Create a message handler that dispatches matches to the methods in a root@@ -173,7 +156,7 @@ = Ex.handle (\e -> hPutStrLn stderr (show ( e:: Ex.SomeException))) $ do let errToErrMessage s e = errorMessage s (Just ser) sender (errorName e) (errorText e) (errorBody e)- mkReturnMethod s args = methodReturn s ser sender args+ mkReturnMethod s args' = methodReturn s ser sender args' (ret, sigs) <- case callAtPath o path iface member args of Left e -> return (Left e, []) Right f -> do@@ -188,27 +171,25 @@ `Text.append` Text.pack (show e)) []) , []) Right r -> return r- serial <- atomically $ dBusCreateSerial conn+ serial' <- atomically $ dBusCreateSerial conn forM_ sigs $ flip emitSignal' conn logDebug $ "method call returned " ++ show ret case ret of- Left err -> sendBS conn $ errToErrMessage serial err- Right r -> sendBS conn $ mkReturnMethod serial r+ Left err -> sendBS conn $ errToErrMessage serial' err+ Right r -> sendBS conn $ mkReturnMethod serial' r logDebug "done"-- where notUnit (DBV DBVUnit) = False- notUnit _ = True objectRoot _ _ _ _ = return () -- | Check whether connection is alive checkAlive :: DBusConnection -> IO Bool-checkAlive conn = atomically $ readTVar (connectionAliveRef conn)+checkAlive conn = atomically $ readTVar (dBusConnectionAliveRef conn) -- | Wait until connection is closed. The intended use is to keep alive servers waitFor :: DBusConnection -> IO () waitFor conn = atomically $ do- alive <- readTVar (connectionAliveRef conn)+ alive <- readTVar (dBusConnectionAliveRef conn) when alive retry+ void $ readTVar (dBusGcRef conn) -- avoid closing the connection prematurely -- | Which Bus to connect to data ConnectionType = System -- ^ The well-known system bus. First@@ -248,7 +229,7 @@ -- -- * A 'MethodCallHandler' that is invoked when a method call is received. ----- * A SignalHandler that is invoked when a Mesage is received:+-- * A SignalHandler that is invoked when a Signak is received: connectBusWithAuth :: ConnectionType -- ^ Bus to connect to -> SASL BS.ByteString -- ^ The authentication mechanism -> MethodCallHandler -- ^ Handler for incoming method calls@@ -258,11 +239,10 @@ addressString <- case transport of Session -> getEnv "DBUS_SESSION_BUS_ADDRESS" System -> do- fromEnv <- Ex.try $ getEnv "DBUS_SYSTEM_BUS_ADDRESS"+ fromEnv <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS" case fromEnv of- Left (e :: Ex.SomeException) ->- return "unix:path=/var/run/dbus/system_bus_socket"- Right addr -> return addr+ Nothing -> return "unix:path=/var/run/dbus/system_bus_socket"+ Just addr -> return addr Address addr -> return addr debugM "DBus" $ "connecting to " ++ addressString mbS <- connectString addressString@@ -270,10 +250,10 @@ Nothing -> throwM (CouldNotConnect "All addresses failed to connect") Just s -> return s- sendCredentials s+ _ <- sendCredentials s h <- socketToHandle s ReadWriteMode debugM "DBus" $ "Running SASL"- runSasl (\bs -> do+ _ <- runSasl (\bs -> do debugM "DBus.Sasl" $ "C: " ++ show (BS.toLazyByteString bs) BS.hPutBuilder h bs) (do@@ -283,31 +263,48 @@ auth serialCounter <- newTVarIO 1 let getSerial = do- s <- readTVar serialCounter- writeTVar serialCounter (s+1)- return s+ s' <- readTVar serialCounter+ writeTVar serialCounter (s'+1)+ return s' lock <- newTMVarIO $ BS.hPutBuilder h answerSlots <- newTVarIO (Map.empty :: AnswerSlots) signalSlots <- newTVarIO ([] :: SignalSlots) propertySlots <- newTVarIO (Map.empty :: PropertySlots) aliveRef <- newTVarIO True- weakAliveRef <- mkWeakPtr aliveRef Nothing+ -- True and fake GC refs, see the explanation below.+ gcRef' <- newTVarIO ()+ fakeGcRef <- newTVarIO () let kill = do- mbRef <- deRefWeak weakAliveRef- case mbRef of- Nothing -> return ()- Just ref -> atomically $ writeTVar ref False+ atomically $ writeTVar aliveRef False hClose h- slots <- atomically $ do sls <- readTVar answerSlots- writeTVar answerSlots Map.empty- return sls- atomically $ writeTVar signalSlots []- atomically $ forM_ (Map.elems slots) $ \s -> s . Left $- [DBV $ DBVString "Connection Closed"]- mfix $ \conn' -> do+ atomically $ do+ sls <- readTVar answerSlots+ writeTVar answerSlots Map.empty+ writeTVar signalSlots []+ writeTVar propertySlots Map.empty+ forM_ (Map.elems sls) $ \s' ->+ s' . Left $ [DBV $ DBVString "Connection Closed"]+ -- In order not to retain a reference to gcRef in the connection thread,+ -- the DBusConnection in the connection thread (forked below) needs to+ -- contain a "fake" TVar (), different from the one to which the+ -- finalizer is attached.+ --+ -- Originally, I tried to overwrite the gcRef after that thread+ -- is forked and set it to fakeGcRef. However, that didn't work:+ --+ -- * We can't force evaluation of the DBusConnection in the forked+ -- thread; it makes the mfix diverge due to the lack of laziness.+ -- * OTOH, if we don't force the DBusConnection, the update thunk+ -- continues to hold the reference to the original DBusConnection, and,+ -- therefore, to the "true" gcRef.+ --+ -- Hence, we do it the other way around: initialize the connection with+ -- the fakeGcRef and later overwrite it with the true one.+ -- Note that we update gcRef *outside* of the mfix block.+ conn <- mfix $ \conn' -> do debugM "DBus" $ "Forking"- handlerThread <- forkIO $ Ex.catch (do- CB.sourceHandle h+ handlerThread <- forkIO $+ (CB.sourceHandle h C.$= parseMessages C.$$ (C.awaitForever $ liftIO . handleMessage (handleCalls conn')@@ -315,22 +312,33 @@ answerSlots signalSlots propertySlots- ))- (\e -> print (e :: Ex.SomeException) >> kill >> Ex.throwIO e)- addFinalizer aliveRef $ killThread handlerThread+ )+ ) `Ex.finally` kill+ addTVarFinalizer gcRef' $ killThread handlerThread let conn = DBusConnection { dBusCreateSerial = getSerial , dBusAnswerSlots = answerSlots- , dbusSignalSlots = signalSlots- , dbusPropertySlots = propertySlots+ , dBusSignalSlots = signalSlots+ , dBusPropertySlots = propertySlots , dBusWriteLock = lock , dBusConnectionName = ""- , connectionAliveRef = aliveRef+ , dBusConnectionAliveRef = aliveRef+ , dBusGcRef = fakeGcRef+ , dBusKillConnection =+ -- | Killing the handlerThread closes the+ -- connection and all handlers+ killThread handlerThread+ } debugM "DBus" $ "hello" connName <- hello conn debugM "DBus" $ "Done" return conn{dBusConnectionName = connName}+ return conn{dBusGcRef = gcRef'} + where+ addTVarFinalizer :: TVar a -> IO () -> IO ()+ addTVarFinalizer tvar fin = void $ mkWeakTVar tvar fin+ -- | Create a simple server that exports @Objects@ and ignores all incoming signals. -- -- Use the default @EXTERNAL@ authentication mechanism (see 'makeServerWithAuth').@@ -355,3 +363,9 @@ #else sendCredentials s = send s "\0" #endif++-- | Close the connection and finalize all handlers.+--+-- This is automatically done when the connection is garbage collected, but+close :: DBusConnection -> IO ()+close = dBusKillConnection
src/DBus/Message.hs view
@@ -9,13 +9,14 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+ module DBus.Message where -import Control.Applicative import Control.Concurrent.STM import Control.Monad import Control.Monad.Reader-import qualified Data.Attoparsec.ByteString.Char8 as AP8 import qualified Data.Binary.Get as B import Data.Bits import qualified Data.ByteString as BS@@ -24,16 +25,14 @@ import qualified Data.Conduit as C import qualified Data.Map as Map import Data.Maybe-import Data.Monoid import Data.Singletons import Data.Singletons.Decide import qualified Data.Text as Text import Data.Word import System.Mem.Weak-import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Catch (MonadThrow) import Data.Singletons.Prelude.List -import DBus.Error import DBus.Representable import DBus.TH import DBus.Types@@ -48,7 +47,7 @@ deriving (Eq, Show) instance Representable MessageType where- type RepType MessageType = 'DBusSimpleType TypeByte+ type RepType MessageType = 'DBusSimpleType 'TypeByte toRep MessageTypeInvalid = DBVByte $ 0 toRep MessageTypeMethodCall = DBVByte $ 1 toRep MessageTypeMethodReturn = DBVByte $ 2@@ -70,19 +69,20 @@ deriving (Show, Eq) instance Representable Flags where- type RepType Flags = 'DBusSimpleType TypeByte+ type RepType Flags = 'DBusSimpleType 'TypeByte toRep (Flags xs) = DBVByte $ foldr (.|.) 0 (map toFlag xs) where toFlag NoReplyExpected = 0x1 toFlag NoAutoStart = 0x2 fromRep (DBVByte x) = Just . Flags $ fromFlags x +fromFlags :: (Num a, Bits a, Ord a) => a -> [Flag] fromFlags x | x .&. 0x1 > 0 = NoReplyExpected : fromFlags (x `xor` 0x1) | x .&. 0x2 > 0 = NoAutoStart : fromFlags (x `xor` 0x2) | otherwise = [] instance Representable Signature where- type RepType Signature = 'DBusSimpleType TypeSignature+ type RepType Signature = 'DBusSimpleType 'TypeSignature toRep (Signature ts) = DBVSignature ts fromRep (DBVSignature ts) = Just $ Signature ts @@ -131,7 +131,7 @@ fromField (HeaderFieldSender x) hf = hf{hFSender = Just x} fromField (HeaderFieldMessageSignature x) hf = hf{hFMessageSignature = Just x} fromField (HeaderFieldUnixFDs x) hf = hf{hFUnixfds = Just x}- fromFields _ hf = hf+ fromField _ hf = hf data HeaderField = HeaderFieldInvalid | HeaderFieldPath ObjectPath@@ -148,7 +148,7 @@ makeRepresentable ''HeaderField instance Representable Endian where- type RepType Endian = 'DBusSimpleType TypeByte+ type RepType Endian = 'DBusSimpleType 'TypeByte toRep Little = DBVByte $ fromIntegral $ ord 'l' toRep Big = DBVByte $ fromIntegral $ ord 'b' fromRep (DBVByte x) = case chr (fromIntegral x) of@@ -176,7 +176,7 @@ -> [SomeDBusValue] -> [Flag] -> BS.Builder-methodCall sid dest path interface member args flags =+methodCall sid dest path interface member args flags' = let hFields = emptyHeaderFields{ hFPath = Just path , hFInterface = Just interface , hFMember = Just member@@ -185,7 +185,7 @@ header = MessageHeader { endianessFlag = Little , messageType = MessageTypeMethodCall- , flags = Flags flags+ , flags = Flags flags' , version = 1 , messageLength = 0 , serial = sid@@ -194,7 +194,7 @@ in serializeMessage header args mkSignal :: SingI ts => Word32 -> [Flag] -> Signal ts -> BS.Builder-mkSignal sid flags sig =+mkSignal sid flags' sig = let hFields = emptyHeaderFields { hFPath = Just $ signalPath sig , hFInterface = Just $ signalInterface sig , hFMember = Just $ signalMember sig@@ -202,7 +202,7 @@ header = MessageHeader { endianessFlag = Little , messageType = MessageTypeSignal- , flags = Flags flags+ , flags = Flags flags' , version = 1 , messageLength = 0 , serial = sid@@ -257,11 +257,12 @@ text args) -serializeMessage head args =+serializeMessage :: MessageHeader -> [SomeDBusValue] -> BS.Builder+serializeMessage head' args = let vs = putValues args sig = Signature $ map (\(DBV v) -> typeOf v) args- header len = head { messageLength = len- , fields = (fields head){hFMessageSignature = Just sig}+ header len = head' { messageLength = len+ , fields = (fields head'){hFMessageSignature = Just sig} } in runDBusPut Little $ do l <- sizeOf 0 1 vs@@ -269,12 +270,13 @@ alignPut 8 vs +getMessage :: B.Get (MessageHeader, [SomeDBusValue]) getMessage = do mbEndian <- fromRep <$> (B.lookAhead $ runReaderT getDBV Little)- endian <- case mbEndian of+ endian' <- case mbEndian of Nothing -> fail "could not read endiannes flag" Just e -> return e- flip runReaderT endian $ do+ flip runReaderT endian' $ do mbHeader <- fromRep <$> getDBV header <- case mbHeader of Nothing -> fail "Header has wrong type"@@ -290,6 +292,7 @@ C.ConduitM BS.ByteString (MessageHeader, [SomeDBusValue]) m b parseMessages = forever $ C.yield =<< sinkGet getMessage +sendBS :: DBusConnection -> BS.Builder -> IO () sendBS conn bs = do write <- atomically . takeTMVar $ dBusWriteLock conn write bs@@ -307,16 +310,16 @@ -> [Flag] -- ^ Method call flags -> DBusConnection -- ^ Connection to send the call over -> IO (STM (Either [SomeDBusValue] [SomeDBusValue] ))-callMethod' dest path interface member args flags conn = do- serial <- atomically $ dBusCreateSerial conn+callMethod' dest path interface member args flags' conn = do+ serial' <- atomically $ dBusCreateSerial conn ref <- newEmptyTMVarIO rSlot <- newTVarIO ()- mkWeak rSlot (connectionAliveRef conn) Nothing- _ <- mkWeakTVar rSlot (finalizeSlot serial)+ _ <- mkWeak rSlot (dBusGcRef conn) Nothing+ _ <- mkWeakTVar rSlot (finalizeSlot serial') slot <- atomically $ do- modifyTVar (dBusAnswerSlots conn) (Map.insert serial $ putTMVar ref)+ modifyTVar (dBusAnswerSlots conn) (Map.insert serial' $ putTMVar ref) return ref- let bs = methodCall serial dest path interface member args flags+ let bs = methodCall serial' dest path interface member args flags' sendBS conn bs return $ readTMVar slot <* readTVar rSlot where@@ -330,34 +333,45 @@ flsng = sFlattenRepType sng in withSingI flsng $ argsToValues $ SDBA (flattenRep arg) --- | Try to convert the response to a method call top Haskell types+-- | Try to convert the response to a method call to a Haskell type fromResponse :: Representable a => Either [SomeDBusValue] [SomeDBusValue] -> Either MethodError a-fromResponse (Left e) = Left $ MethodErrorMessage e-fromResponse (Right rvs) =+fromResponse x =+ case fromResponse' x of+ Left e -> Left e+ Right r -> maybe (Left $ MethodSignatureMissmatch [DBV r]) Right $ fromRep r++-- | Try to convert the response to a method call+fromResponse' :: forall (a :: DBusType) .+ SingI a =>+ Either [SomeDBusValue] [SomeDBusValue]+ -> Either MethodError (DBusValue a)+fromResponse' (Left e) = Left $ MethodErrorMessage e+fromResponse' (Right rvs) = case listToSomeArguments rvs of- sr@(SDBA (r :: DBusArguments ats)) ->+ SDBA (r :: DBusArguments ats) -> maybe (Left $ MethodSignatureMissmatch rvs) Right -- Use fix to access the return type (We only care about the type)- $ fix $ \(_ :: Maybe ret) ->- case sing :: Sing (RepType ret) of+ $ fix $ \(_ :: Maybe (DBusValue ret)) ->+ case sing :: Sing ret of STypeStruct ts -> case (r, sing :: Sing ats) of (ArgsNil, SNil) -> Nothing (ArgsCons r' ArgsNil, SCons a SNil) ->- case a %~ (sing :: Sing (RepType ret)) of- Proved Refl -> fromRep r'+ case a %~ (sing :: Sing ret) of+ Proved Refl -> Just r' Disproved _ -> Nothing _ -> withSingI ts- $ fromRep . DBVStruct =<< maybeArgsToStruct r+ $ DBVStruct <$> maybeArgsToStruct r STypeUnit -> case r of- ArgsNil -> fromRep DBVUnit+ ArgsNil -> Just DBVUnit _ -> Nothing _ -> case (sing :: Sing ats, r) of (SCons at SNil, ArgsCons r' ArgsNil) ->- case at %~ (sing :: Sing (RepType ret)) of- Proved Refl -> fromRep r'+ case at %~ (sing :: Sing ret) of+ Proved Refl -> Just r' Disproved _ -> Nothing+ _ -> error "fromResponse': impossible case" -- | Synchronously call a method. --@@ -397,32 +411,41 @@ -> [Flag] -- ^ Method call flags -> DBusConnection -- ^ Connection to send the call over -> IO (Either MethodError ret)-callMethod dest path interface member (arg :: args) flags conn = do+callMethod dest path interface member (arg :: args) flags' conn = do let sng = sing :: Sing (RepType args) flsng = sFlattenRepType sng args' = withSingI flsng $ argsToValues $ SDBA (flattenRep arg)- ret <- callMethod' dest path interface member args' flags conn+ ret <- callMethod' dest path interface member args' flags' conn fromResponse <$> atomically ret -callAsync :: (Representable args, Representable ret) =>- MethodDescription (FlattenRepType (RepType args))- (FlattenRepType (RepType ret))+callAsync :: forall ret args retList argList.+ ( Representable args+ , Representable ret+ , RepType args ~ FromTypeList argList+ , RepType ret ~ FromTypeList retList+ ) =>+ MethodDescription argList+ retList -> Text.Text -> args -> [Flag] -> DBusConnection -> IO (STM (Either MethodError ret))-callAsync md dest args flags con = do+callAsync md dest args flags' con = do res <- callMethod' dest (methodObjectPath md) (methodInterface md)- (methodMember md) (toArgs args) flags con+ (methodMember md) (toArgs args) flags' con return $ fromResponse <$> res -call :: (Representable ret, Representable args) =>- MethodDescription (FlattenRepType (RepType args))- (FlattenRepType (RepType ret))+call :: ( Representable ret+ , Representable args+ , RepType args ~ FromTypeList argList+ , RepType ret ~ FromTypeList retList+ ) =>+ MethodDescription argList+ retList -> Text.Text -> args -> [Flag] -> DBusConnection -> IO (Either MethodError ret)-call md dest args flags con = atomically =<< callAsync md dest args flags con+call md dest args flags' con = atomically =<< callAsync md dest args flags' con
src/DBus/MessageBus.hs view
@@ -3,13 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} module DBus.MessageBus where -import qualified Control.Exception as Ex-import Control.Monad.Catch (MonadThrow, throwM)+import qualified Control.Exception as Ex+import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class-import Control.Monad.Trans (MonadIO)+import Control.Monad.Trans (MonadIO) import Data.Default+import Data.Monoid import Data.Singletons-import qualified Data.Text as Text+import qualified Data.Text as Text import Data.Word import DBus.Message@@ -48,12 +49,12 @@ def = RequestNameFlag False False False fromRequestNameFlags :: RequestNameFlag -> Word32-fromRequestNameFlags flags = sum [ fromFlag allowReplacement 0x01- , fromFlag replaceExisting 0x02- , fromFlag doNotQueue 0x04- ]+fromRequestNameFlags flags' = sum [ fromFlag allowReplacement 0x01+ , fromFlag replaceExisting 0x02+ , fromFlag doNotQueue 0x04+ ] where- fromFlag x n = if x flags then n else 0+ fromFlag x n = if x flags' then n else 0 data RequestNameReply = PrimaryOwner | InQueue@@ -65,8 +66,8 @@ -> RequestNameFlag -> DBusConnection -> m RequestNameReply-requestName name flags con = do- reply <- messageBusMethod "RequestName" (name, fromRequestNameFlags flags)+requestName name flags' con = do+ reply <- messageBusMethod "RequestName" (name, fromRequestNameFlags flags') con case reply :: Word32 of 1 -> return PrimaryOwner@@ -119,9 +120,10 @@ -> m StartServiceResult startServiceByName name con = do res <- messageBusMethod "StartServiceByName" (name, 0 :: Word32) con- return $ case (res :: Word32) of- 1 -> StartServiceSuccess- 2 -> StartServiceAlreadyRunning+ case (res :: Word32) of+ 1 -> return StartServiceSuccess+ 2 -> return StartServiceAlreadyRunning+ _ -> throwM $ MarshalError $ "StartServiceByName returned" <> show res getNameOwner :: (MonadIO m, MonadThrow m) => Text.Text
src/DBus/Method.hs view
@@ -5,15 +5,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ module DBus.Method where -import Control.Applicative import Control.Monad import Control.Monad.Trans import qualified Data.List as List import Data.Singletons import Data.Singletons.Prelude.List-import Data.Text (Text) import qualified Data.Text as Text import DBus.Types@@ -68,7 +68,7 @@ type RepMethodValue (a -> b) = RepMethodValue b repMethod f = MAsk $ \x -> case fromRep x of Nothing -> error "marshalling error" -- TODO- Just x -> repMethod $ f x+ Just x' -> repMethod $ f x' runMethodW :: SingI at => MethodWrapper at rt@@ -81,7 +81,7 @@ -> MethodWrapper at rt -> Maybe (MethodHandlerT IO (DBusArguments rt)) runMethodW' SNil [] (MReturn f) = Just f-runMethodW' (SCons t ts) (arg:args) (MAsk f) = (runMethodW' ts args . f )+runMethodW' (SCons _ ts) (arg:args) (MAsk f) = (runMethodW' ts args . f ) =<< dbusValue arg runMethodW' _ _ _ = Nothing @@ -103,6 +103,9 @@ methodName :: Method -> Text.Text methodName (Method _ n _ _) = n +argDescriptions :: ArgumentDescription a+ -> ArgumentDescription b+ -> ([Text.Text], [Text.Text]) argDescriptions args ress = (adToList args, adToList ress) instance Show Method where
src/DBus/Object.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -15,31 +14,21 @@ module DBus.Object where import Control.Applicative ((<$>))-import Control.Concurrent.STM-import qualified Control.Exception as Ex import Control.Monad import Control.Monad (liftM)-import Control.Monad.Except-import Control.Monad.Trans-import Data.List (intercalate, find)+import Data.List (find) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Singletons.TH-import Data.String import Data.Text (Text) import qualified Data.Text as Text-import Unsafe.Coerce (unsafeCoerce) import DBus.Types-import DBus.Representable import DBus.Error import DBus.Property-import DBus.Signal import DBus.Method +findProperty :: Object -> Text -> Text -> Either MsgError SomeProperty findProperty (Object o) ifaceName prop = case Map.lookup ifaceName o of Nothing -> Left noSuchInterface@@ -48,11 +37,12 @@ Nothing -> Left noSuchProperty Just p -> Right p +getAllProperties :: Interface -> MethodHandlerT IO SomeDBusArguments getAllProperties iface = liftM (SDBA . singletonArg . toRep . mconcat) . forM (interfaceProperties iface) $ \(SomeProperty p) -> case propertyGet p of- Nothing -> return (Map.empty :: Map Text (DBusValue TypeVariant))+ Nothing -> return (Map.empty :: Map Text (DBusValue 'TypeVariant)) Just g -> flip catchMethodError (\_ -> return Map.empty) $ do res <- g return $ Map.singleton (propertyName p) (DBVVariant res)@@ -70,7 +60,7 @@ case propertyGet prop of Nothing -> Left propertyNotReadable Just rd -> Right $ SDBA . singletonArg . DBVVariant <$> rd)-handleProperty o path "Set" [mbIface , mbProp, mbVal]+handleProperty o _ "Set" [mbIface , mbProp, mbVal] | Just ifaceName <- fromRep =<< dbusValue mbIface , Just propName <- fromRep =<< dbusValue mbProp = findProperty o ifaceName propName@@ -82,7 +72,7 @@ invalidated <- wt v when invalidated $ propertyChanged prop v return (SDBA ArgsNil))-handleProperty (Object o) path "GetAll" [mbIface]+handleProperty (Object o) _ "GetAll" [mbIface] | Just ifaceName <- fromRep =<< dbusValue mbIface = case Map.lookup ifaceName o of Just iface -> Right $ getAllProperties iface@@ -100,7 +90,7 @@ -> Text.Text -> [SomeDBusValue] -> Either MsgError (MethodHandlerT IO SomeDBusArguments)-callAtPath (Objects root) path interface member args = case Map.lookup path root of+callAtPath (Objects root') path interface member args = case Map.lookup path root' of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just . Text.pack $ "No such object " ++ show path)
src/DBus/Property.hs view
@@ -3,16 +3,13 @@ module DBus.Property where -import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad import Control.Monad.Reader-import Control.Monad.Trans import Control.Monad.Writer import qualified Data.Foldable as Foldable-import Data.Map (Map) import qualified Data.Map as Map import Data.Singletons import Data.Text (Text)@@ -90,7 +87,7 @@ -> IO () manageStmProperty prop get con = do let sendSig v = emitPropertyChanged prop v con- forkIO $ onEdge sendSig+ _ <- forkIO $ onEdge sendSig return () where onEdge f = do@@ -105,6 +102,7 @@ go f x' -- | Interface for D-BUs properties+propertiesInterfaceName :: Text propertiesInterfaceName = "org.freedesktop.DBus.Properties" -- | Create a propertyChangedSignal for a property@@ -135,7 +133,7 @@ , signalMember = "PropertiesChanged" , signalBody = flattenRep $ toRep ( iface- , Map.empty :: Map.Map Text (DBusValue (TypeVariant))+ , Map.empty :: Map.Map Text (DBusValue 'TypeVariant) , [name] ) }@@ -194,7 +192,7 @@ ++ "." ++ Text.unpack (rpName rp) Just v -> f' (Just v) slot = Map.singleton (rpObject rp, rpInterface rp, rpName rp) [f]- atomically $ modifyTVar' (dbusPropertySlots con) (Map.unionWith (++) slot)+ atomically $ modifyTVar' (dBusPropertySlots con) (Map.unionWith (++) slot) addMatch mr con propertyToTVar :: Representable a =>@@ -212,7 +210,7 @@ Nothing -> do eniv <- getProperty rp con case eniv of- Left e -> return () -- @TODO+ Left _e -> return () -- @TODO Right nv -> atomically $ writeTVar tv nv Just v -> atomically $ writeTVar tv v ) con
src/DBus/Representable.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module DBus.Representable where @@ -35,71 +35,72 @@ frts = sFlattenRepType rts in case (rts, frts) of (STypeUnit, SNil) -> ArgsNil- (STypeStruct ts, ts') -> case toRep x of DBVStruct str -> structToArgs str+ (STypeStruct _, _) -> case toRep x of DBVStruct str -> structToArgs str (t, SCons t' SNil) -> case t %~ t' of Proved Refl -> ArgsCons (toRep x) ArgsNil- Disproved _ -> error "flattenRep: this shouldn't happen"+ Disproved _ -> error "flattenRep: impossible case"+ _ -> error "flattenRep: impossible case" -- class Representable; see DBus.Types forM [2..20] makeRepresentableTuple instance Representable () where- type RepType () = TypeUnit+ type RepType () = 'TypeUnit toRep _ = DBVUnit fromRep DBVUnit = Just () instance Representable Word8 where- type RepType Word8 = 'DBusSimpleType TypeByte+ type RepType Word8 = 'DBusSimpleType 'TypeByte toRep x = DBVByte x fromRep (DBVByte x) = Just x instance Representable Bool where- type RepType Bool = 'DBusSimpleType TypeBoolean+ type RepType Bool = 'DBusSimpleType 'TypeBoolean toRep x = DBVBool x fromRep (DBVBool x) = Just x instance Representable Int16 where- type RepType Int16 = 'DBusSimpleType TypeInt16+ type RepType Int16 = 'DBusSimpleType 'TypeInt16 toRep x = DBVInt16 x fromRep (DBVInt16 x) = Just x instance Representable Word16 where- type RepType Word16 = 'DBusSimpleType TypeUInt16+ type RepType Word16 = 'DBusSimpleType 'TypeUInt16 toRep x = DBVUInt16 x fromRep (DBVUInt16 x) = Just x instance Representable Int32 where- type RepType Int32 = 'DBusSimpleType TypeInt32+ type RepType Int32 = 'DBusSimpleType 'TypeInt32 toRep x = DBVInt32 x fromRep (DBVInt32 x) = Just x instance Representable Word32 where- type RepType Word32 = 'DBusSimpleType TypeUInt32+ type RepType Word32 = 'DBusSimpleType 'TypeUInt32 toRep x = DBVUInt32 x fromRep (DBVUInt32 x) = Just x instance Representable Int64 where- type RepType Int64 = 'DBusSimpleType TypeInt64+ type RepType Int64 = 'DBusSimpleType 'TypeInt64 toRep x = DBVInt64 x fromRep (DBVInt64 x) = Just x instance Representable Word64 where- type RepType Word64 = 'DBusSimpleType TypeUInt64+ type RepType Word64 = 'DBusSimpleType 'TypeUInt64 toRep x = DBVUInt64 x fromRep (DBVUInt64 x) = Just x instance Representable Double where- type RepType Double = 'DBusSimpleType TypeDouble+ type RepType Double = 'DBusSimpleType 'TypeDouble toRep x = DBVDouble x fromRep (DBVDouble x) = Just x instance Representable Text.Text where- type RepType Text.Text = 'DBusSimpleType TypeString+ type RepType Text.Text = 'DBusSimpleType 'TypeString toRep x = DBVString x fromRep (DBVString x) = Just x instance Representable ObjectPath where- type RepType ObjectPath = 'DBusSimpleType TypeObjectPath+ type RepType ObjectPath = 'DBusSimpleType 'TypeObjectPath toRep x = DBVObjectPath x fromRep (DBVObjectPath x) = Just x @@ -110,13 +111,13 @@ instance ( Representable a , SingI (RepType a)) => Representable [a] where- type RepType [a] = TypeArray (RepType a)+ type RepType [a] = 'TypeArray (RepType a) toRep xs = DBVArray $ map toRep xs fromRep (DBVArray xs) = mapM fromRep xs fromRep (DBVByteArray bs) = fromRep . DBVArray . map DBVByte $ BS.unpack bs instance Representable BS.ByteString where- type RepType BS.ByteString = TypeArray ('DBusSimpleType TypeByte)+ type RepType BS.ByteString = 'TypeArray ('DBusSimpleType 'TypeByte) toRep bs = DBVByteArray bs fromRep (DBVByteArray bs) = Just bs fromRep (DBVArray bs) = BS.pack <$> mapM fromRep bs@@ -130,7 +131,7 @@ , SingI r , Representable v ) => Representable (Map.Map k v) where- type RepType (Map.Map k v) = TypeDict (FromSimpleType (RepType k)) (RepType v)+ type RepType (Map.Map k v) = 'TypeDict (FromSimpleType (RepType k)) (RepType v) toRep m = DBVDict $ map (\(l,r) -> (toRep l, toRep r)) (Map.toList m) fromRep (DBVDict xs) = Map.fromList <$> sequence (map (\(l,r) -> (,) <$> fromRep l <*> fromRep r) xs)
src/DBus/Scaffold.hs view
@@ -11,9 +11,7 @@ , def ) where -import Control.Applicative import Control.Monad-import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char import Data.Default@@ -24,14 +22,10 @@ import Data.Text (Text) import qualified Data.Text as Text import Language.Haskell.TH-import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax import DBus.Introspect-import DBus.Message-import DBus.Representable import DBus.Types-import DBus.Property data DBusEndpointOptions = DBusEndpointOptions { methodNames :: SomeMethodDescription -> Maybe String@@ -39,8 +33,8 @@ , signalNames :: String -> String } -defaultDbusEndpointOptions :: DBusEndpointOptions-defaultDbusEndpointOptions =+defaultDBusEndpointOptions :: DBusEndpointOptions+defaultDBusEndpointOptions = DBusEndpointOptions { methodNames = \(SMD md) -> filterInterfaces (methodInterface md) . downcase . Text.unpack $ methodMember md@@ -59,16 +53,13 @@ downcase (x:xs) = toLower x : xs instance Default DBusEndpointOptions where- def = defaultDbusEndpointOptions+ def = defaultDBusEndpointOptions makeDbusEndpoints :: DBusEndpointOptions -> ObjectPath -> FilePath -> Q [Dec]-makeDbusEndpoints conf root xmlFile = do -- @TODO: root+makeDbusEndpoints conf _root xmlFile = do -- @TODO: root node <- readIntrospectXml xmlFile let methods = nodeMethodDescriptions node propDs = nodePropertyDescriptions node- sigDs = nodeSignals node- downcase [] = []- downcase (x:xs) = toLower x : xs mfs <- fmap catMaybes . forM methods $ \smd -> case methodNames conf smd of Nothing -> return Nothing@@ -79,8 +70,6 @@ -- sigs <- forM sigDs $ \(ssd@(SSD sd)) -> -- liftSignalDescription () ssd return . concat $ mfs ++ props -- ++ sigs- where- for = flip fmap liftObjectPath :: ObjectPath -> ExpQ liftObjectPath op = [| objectPath $( liftText $ objectPathToText op) |]@@ -151,6 +140,7 @@ nodePropertyDescriptions node = mapIInterfaces interfacPropertyDescriptions (fromMaybe "" $ nodeName node) node+liftText :: Text -> ExpQ liftText t = [|Text.pack $(liftString (Text.unpack t))|] @@ -163,22 +153,23 @@ tupleType :: [TypeQ] -> TypeQ tupleType xs = foldl (\ts t -> appT ts t) (tupleT (length xs)) xs +promoteSimpleType :: Show a => a -> TypeQ promoteSimpleType t = promotedT (mkName (show t)) promoteDBusType :: DBusType -> TypeQ promoteDBusType (DBusSimpleType t) = [t|'DBusSimpleType $(promoteSimpleType t)|]-promoteDBusType (TypeArray t) = [t| TypeArray $(promoteDBusType t)|]+promoteDBusType (TypeArray t) = [t| 'TypeArray $(promoteDBusType t)|] promoteDBusType (TypeStruct ts) = let ts' = promotedListT $ promoteDBusType <$> ts- in [t| TypeStruct $ts'|]+ in [t| 'TypeStruct $ts'|] promoteDBusType (TypeDict k v) =- [t| TypeDict $(promoteSimpleType k)+ [t| 'TypeDict $(promoteSimpleType k) $(promoteDBusType v) |] promoteDBusType (TypeDictEntry k v) =- [t| TypeDictEntry $(promoteSimpleType k)+ [t| 'TypeDictEntry $(promoteSimpleType k) $(promoteDBusType v) |]-promoteDBusType TypeVariant = [t| TypeVariant |]-promoteDBusType TypeUnit = [t| TypeUnit |]+promoteDBusType TypeVariant = [t| 'TypeVariant |]+promoteDBusType TypeUnit = [t| 'TypeUnit |] readIntrospectXml :: FilePath -> Q INode readIntrospectXml interfaceFile = do@@ -215,7 +206,6 @@ -> PropertyDescription -> Q [Dec] propertyFromDescription nameGen mbEntity pd = do- entName <- newName "entity" let rp ent = [|RP{ rpEntity = $ent , rpObject = objectPath $(liftText $ pdObjectPath pd) , rpInterface = $(liftText $ pdInterface pd)@@ -223,7 +213,6 @@ } |] name = mkName $ nameGen pd entN = (mkName "entity")- typeName = mkName "t" arg = case mbEntity of Nothing -> [[t|Text|]]@@ -273,7 +262,7 @@ liftSignalDescription :: String -> SomeSignalDescription -> Q [Dec]-liftSignalDescription nameString ssigDesc@(SSD (sigDesc :: SignalDescription a))+liftSignalDescription nameString (SSD (sigDesc :: SignalDescription a)) = do let name = mkName nameString ts = fromSing (sing :: (Sing a))
src/DBus/Signal.hs view
@@ -2,17 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module DBus.Signal where -import Control.Applicative import Control.Concurrent.STM import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.Trans import Control.Monad.Writer import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map import Data.Maybe-import Data.Monoid import Data.Singletons import Data.Singletons.Decide import Data.Singletons.Prelude.List@@ -92,7 +88,7 @@ fromMessageType MessageTypeMethodReturn = "method_return" fromMessageType MessageTypeSignal = "signal" fromMessageType MessageTypeError = "error"- ft = TB.fromText+ fromMessageType _ = "fromMessageType: Invalid and Other not handled" num i = TB.fromText . Text.pack $ show i -- | Match a Signal against a rule. The argN, argNPath and arg0namespace@@ -141,7 +137,7 @@ -> DBusConnection -> IO () addSignalHandler ms rules m dbc = do- atomically $ modifyTVar (dbusSignalSlots dbc) ((fromSlot ms, m):)+ atomically $ modifyTVar (dBusSignalSlots dbc) ((fromSlot ms, m):) let rule = rules <> matchSignalToMatchRule ms addMatch rule dbc where@@ -154,7 +150,7 @@ castSignalBody :: SingI a => SomeSignal -> Maybe (DBusValue a) castSignalBody (SomeSignal s) = case (signalBody s) of- sr@(r :: DBusArguments ats) ->+ (r :: DBusArguments ats) -> -- Use fix to access the return type (We only care about the type) fix $ \(_ :: Maybe (DBusValue ret)) -> case sing :: Sing ret of@@ -173,6 +169,7 @@ case at %~ (sing :: Sing ret) of Proved Refl -> Just r' Disproved _ -> Nothing+ _ -> error "castSignalBody: impossible case" -- | Add a match rule (computed from the SignalDescription) and install a@@ -206,9 +203,9 @@ -> DBusConnection -> IO (TChan SomeSignal) signalChan match dbc = do- signalChan <- newTChanIO- addSignalHandler match mempty (atomically . writeTChan signalChan) dbc- return signalChan+ sChan <- newTChanIO+ addSignalHandler match mempty (atomically . writeTChan sChan) dbc+ return sChan signalChan' :: Representable a => SignalDescription (FlattenRepType (RepType a))@@ -217,10 +214,15 @@ -> DBusConnection -> IO (TChan a) signalChan' desc sender rules con = do- signalChan <- newTChanIO- handleSignal desc sender rules (atomically . writeTChan signalChan) con- return signalChan+ sChan <- newTChanIO+ handleSignal desc sender rules (atomically . writeTChan sChan) con+ return sChan +createSignal ::+ Representable a+ => SignalDescription (FlattenRepType (RepType a))+ -> a+ -> Signal (FlattenRepType (RepType a)) createSignal desc x = Signal{ signalPath = signalDPath desc , signalInterface = signalDInterface desc , signalMember = signalDMember desc@@ -243,6 +245,7 @@ signal' :: Monad m => SomeSignal -> MethodHandlerT m () signal' sig = MHT $ tell [sig] +emitSignal' :: SomeSignal -> DBusConnection -> IO () emitSignal' (SomeSignal s) con = do sid <- atomically $ dBusCreateSerial con logDebug $ "Emitting signal (ID = " ++ show sid ++ "): " ++ show s
src/DBus/Signature.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module DBus.Signature where -import Control.Applicative ((<$>))-import Control.Monad-import qualified Data.Attoparsec.ByteString as AP+import Control.Applicative ((<$>))+import qualified Data.Attoparsec.ByteString as AP import qualified Data.Attoparsec.ByteString.Char8 as AP-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Builder as BS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Builder as BS import Data.Char-import qualified Data.IntMap as IMap+import qualified Data.IntMap as IMap import Data.Monoid-import qualified Data.Text as Text+import qualified Data.Text as Text import DBus.Types @@ -46,8 +45,14 @@ <> BS.char8 (stToSignature kt) <> toSignature' vt <> BS.char8 '}'+toSignature' (TypeDictEntry kt vt) = BS.string8 "e{"+ <> BS.char8 (stToSignature kt)+ <> toSignature' vt+ <> BS.char8 '}' toSignature' TypeVariant = BS.char8 'v'+toSignature' TypeUnit = "" +simpleTypeMap :: IMap.IntMap DBusSimpleType simpleTypeMap = IMap.fromList[ (ord 'y', TypeByte ) , (ord 'b', TypeBoolean ) , (ord 'n', TypeInt16 )@@ -63,33 +68,37 @@ , (ord 'g', TypeSignature ) ] +simpleType :: AP.Parser DBusSimpleType simpleType = do c <- AP.anyWord8 case IMap.lookup (fromIntegral c) simpleTypeMap of Nothing -> fail "not a simple type" Just t -> return t +dictEntrySignature :: AP.Parser DBusType dictEntrySignature = do- AP.char8 '{'+ _ <- AP.char8 '{' kt <- simpleType vt <- signature- AP.string "}"+ _ <- AP.string "}" return $ TypeDictEntry kt vt +arraySignature :: AP.Parser DBusType arraySignature = do- AP.char8 'a'+ _ <- AP.char8 'a' ((do TypeDictEntry kt vt <- dictEntrySignature return $ TypeDict kt vt) <> (TypeArray <$> signature)) -+structSignature :: AP.Parser DBusType structSignature = do- AP.char '('+ _ <- AP.char '(' TypeStruct <$> AP.manyTill signature (AP.char ')') +signature :: AP.Parser DBusType signature = AP.choice [ AP.char 'v' >> return TypeVariant , arraySignature , structSignature@@ -115,7 +124,3 @@ parseSigs s = case eitherParseSigs s of Left _ -> Nothing Right r -> Just r----- fromSignature (v:vs) = TypeVariant :--- fromSignature "v" = Just TypeVariant
src/DBus/TH.hs view
@@ -19,7 +19,7 @@ litStruct xs = foldr cons (sing $ last xs) $ init xs where sing nm = (appE (conE 'StructSingleton) nm)- cons nm xs = (appE (appE (conE 'StructCons) nm) xs)+ cons nm xs' = (appE (appE (conE 'StructCons) nm) xs') litStructPat :: [PatQ] -> PatQ litStructPat xs = foldr cons (sing $ last xs) $ init xs@@ -35,12 +35,14 @@ , match (conP 'Just [varP x]) (normalB $ caseMaybes xs e) [] ] +fromTyVarBndr :: TyVarBndr -> Type fromTyVarBndr (PlainTV n) = VarT n-fromTyVarBndr (KindedTV n k) = VarT n+fromTyVarBndr (KindedTV n _) = VarT n fromConstr :: Con -> (Name, [Type]) fromConstr (NormalC n stps) = (n, map snd stps) fromConstr (RecC n vstps) = (n, map (\(_,_,t) -> t) vstps)+fromConstr _ = error "fromConstr only handles NormalC and RecC" tyVarName :: TyVarBndr -> Name tyVarName (PlainTV n) = n@@ -83,18 +85,20 @@ -- -- * For constructors with multiple members, the translated members are stored in a -- @Struct@+makeRepresentable :: Name -> Q [Dec] makeRepresentable name = do TyConI t <- reify name- let (numTyParams, tyVarNames, cons) = case t of+ let (_numTyParams, tyVarNames, cons) = case t of #if MIN_VERSION_template_haskell(2,11,0) NewtypeD _ _ tvs _ c _ -> (length tvs, tyVarName <$> tvs, [c])- DataD _ _ tvs _ cs _ -> (length tvs, tyVarName <$> tvs, cs)+ DataD _ _ tvs _ cs' _ -> (length tvs, tyVarName <$> tvs, cs') #else NewtypeD _ _ tvs c _ -> (length tvs, tyVarName <$> tvs, [c]) DataD _ _ tvs cs _ -> (length tvs, tyVarName <$> tvs, cs) #endif- ctx1 = mapM (classP ''SingI . (:[]) . appT (conT ''RepType)) (varT <$> (relevantTyVars cons))- ctx2 = mapM (classP ''Representable . (:[])) (varT <$> relevantTyVars cons)+ _ -> error "makeReprsentable only handles Data and Newtype declarations"+ ctx1 = mapM (appT (conT ''SingI) . appT (conT ''RepType)) (varT <$> (relevantTyVars cons))+ ctx2 = mapM (appT (conT ''Representable)) (varT <$> relevantTyVars cons) ctx = liftM2 (++) ctx1 ctx2 fullType = (foldl appT (conT name) (varT <$> tyVarNames)) iHead = appT (conT ''Representable) fullType@@ -103,9 +107,9 @@ True -> enumerate $ map fst cs False -> case map fromConstr cons of [] -> fail "Can't make representation of empty data type"- cs | (all (null . snd) cs) -> enumerate $ map fst cs+ cs' | (all (null . snd) cs) -> enumerate $ map fst cs' [(conName, fields)] -> oneCon conName fields- cs -> multiCon cs+ cs' -> multiCon cs' inst <- instanceD ctx iHead [ tySynInstD ''RepType $ tySynEqn [fullType] repType , funD 'toRep toClauses@@ -113,6 +117,7 @@ ] return [inst] where+ oneCon conName fieldTypes = do (repType , (toPat, toBD)@@ -122,7 +127,7 @@ , [clause [fromPat] (normalB fromBD) []] ) enumerate conNames- = return ( [t| 'DBusSimpleType TypeByte |]+ = return ( [t| 'DBusSimpleType 'TypeByte |] , for (zip conNames [0..]) $ \(cn, i) -> (clause [conP cn []] (normalB . appE (conE 'DBVByte) . litE $ integerL i) [])@@ -157,13 +162,12 @@ , clause [fromPat] (normalB fromBD) [] ) - return ( [t| TypeStruct '[ 'DBusSimpleType TypeByte, TypeVariant] |]+ return ( [t| 'TypeStruct '[ 'DBusSimpleType 'TypeByte, 'TypeVariant] |] , map fst clauses , map snd clauses ) singleConstructor conName [] = do- var <- newName "x"- return $ ( [t| 'DBusSimpleType TypeByte |]+ return $ ( [t| 'DBusSimpleType 'TypeByte |] , ( conP conName [] , [| DBVByte 0|] )@@ -209,13 +213,12 @@ makeRepresentableTuple :: Int -> Q Dec makeRepresentableTuple num = do let names = take num $ map (varT . mkName . (:[])) ['a' .. 'z']- ctx = sequence $ classP ''Representable . (:[]) <$> names+ ctx = sequence $ appT (conT ''Representable) <$> names tp = (foldl appT (tupleT num) names) iHead = appT (conT ''Representable) (foldl appT (tupleT num) names) tpList = foldr (appT . appT promotedConsT) promotedNilT (appT (conT ''RepType) <$> names)- repTp = appT (promotedT 'TypeStruct) tpList varNames <- replicateM num (newName "x") tmpNames <- replicateM num (newName "mbx") instanceD ctx iHead
src/DBus/Transport.hs view
@@ -4,26 +4,20 @@ module DBus.Transport where import Control.Applicative ((<$>))-import Control.Concurrent+ import qualified Control.Exception as Ex import Control.Monad import Data.Attoparsec.ByteString as AP import Data.Attoparsec.ByteString.Char8 as AP8 import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy.Builder as BS-import qualified Data.Conduit as C import Data.List as List import qualified Data.Text as Text-import Data.Text as Text import Data.Text.Encoding as Text import Data.Word import Network import Network.Socket-import System.IO -import System.Environment- import DBus.Auth import DBus.Error @@ -56,12 +50,12 @@ withProtocol nameParser f = do name <- nameParser ((fmap Just $ do- AP8.char8 ':'+ _ <- AP8.char8 ':' pairs <- parsePair `AP.sepBy` (AP8.char8 ',') mbGuid <- case List.lookup "guid" pairs of Nothing -> return Nothing Just g -> case AP.parseOnly parseHexString g of- Left e -> fail "could not parse GUID"+ Left _ -> fail "could not parse GUID" Right r -> return $ Just r ret <- f (name, List.filter ((/= "guid").fst) pairs) return (mbGuid, ret)@@ -70,7 +64,7 @@ parsePair :: AP.Parser (BS.ByteString, BS.ByteString) parsePair = do key <- AP8.takeWhile1 (\c -> AP8.isAlpha_ascii c || (c >= '0' && c <= '9'))- AP8.char8 '='+ _ <- AP8.char8 '=' value <- BS.pack <$> AP.many1' valueChar return (key, value) where@@ -78,6 +72,7 @@ , AP8.char '%' >> parseHexChar ] +parseUnix :: Parser (Maybe (Maybe BS8.ByteString, TransportType)) parseUnix = withProtocol (AP.string "unix") $ \ (_, pairs) -> TransportUnix <$> case pairs of [("path", p)] -> return $ UDSPath p@@ -105,6 +100,7 @@ withProtocol (AP.takeWhile1 $ AP.inClass "a-zA-Z0-9-") $ \(name, pairs) -> return $ OtherTransport name pairs +parseMaybe :: MonadPlus m => Maybe a -> m a parseMaybe Nothing = mzero parseMaybe (Just x) = return x @@ -139,7 +135,7 @@ connect s $ addrAddress ai return s )- (\(e :: Ex.SomeException) ->+ (\(_ :: Ex.SomeException) -> Ex.throwIO $ CouldNotConnect "Could not connect") _ -> Ex.throwIO $ CouldNotConnect "Host not found"@@ -167,6 +163,7 @@ ++ show e) return s +connectTransport :: TransportType -> IO Socket connectTransport (TransportTCP tcp) = connectTcp tcp connectTransport (TransportUnix unix) = connectUnix unix connectTransport (OtherTransport name _) = Ex.throwIO . CouldNotConnect $@@ -176,12 +173,12 @@ connectString :: String -> IO (Maybe Socket) connectString s = case AP.parseOnly parseTransports (Text.encodeUtf8 . Text.pack $ s) of- Left e -> return $ Nothing+ Left _ -> return $ Nothing Right transports -> go transports where go ((_, t) : ts) = do mbS <- Ex.try $ connectTransport t case mbS of- Left (e :: DBusError) -> go ts- Right s -> return $ Just s+ Left (_ :: DBusError) -> go ts+ Right s' -> return $ Just s' go [] = return Nothing
src/DBus/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-}@@ -7,17 +8,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+ module DBus.Types where import Control.Applicative-import Control.Applicative ((<$>), (<*>))-import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad import Control.Monad.Catch import Control.Monad.Except-import Control.Monad.Trans import Control.Monad.Writer.Strict import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS@@ -60,10 +60,12 @@ type InterfaceName = Text type MemberName = Text +opNode :: ObjectPath -> ObjectPath opNode op = ObjectPath { opAbsolute = False , opParts = take 1 . reverse $ opParts op } +opPath :: ObjectPath -> ObjectPath opPath op = ObjectPath { opAbsolute = opAbsolute op , opParts = case opParts op of [] -> []@@ -75,12 +77,14 @@ deriving (Show, Eq) -- | Parse an object path. Contrary to the standard, empty path parts are ignored+objectPath :: Text -> ObjectPath objectPath txt = case Text.uncons txt of Just ('/', rest) -> ObjectPath True $ filter (not. Text.null) $ Text.splitOn "/" rest Just _ -> ObjectPath False $ filter (not. Text.null) $ Text.splitOn "/" txt Nothing -> ObjectPath False []-objectPathToText (ObjectPath abs parts) = (if abs then "/" else "")+objectPathToText :: ObjectPath -> Text+objectPathToText (ObjectPath abso parts) = (if abso then "/" else "") `Text.append` Text.intercalate "/" parts instance Show ObjectPath where@@ -99,9 +103,11 @@ Nothing -> False Just _ -> True +isRoot :: ObjectPath -> Bool isRoot (ObjectPath True p) = null p isRoot _ = False +isEmpty :: ObjectPath -> Bool isEmpty (ObjectPath False p) = null p isEmpty _ = False @@ -185,6 +191,7 @@ flattenRepType t@(TypeVariant) = [t] |] + -- | A Transformer for (IO) actions that might want to send a signal. newtype MethodHandlerT m a = MHT { unMHT :: ExceptT MsgError (WriterT [SomeSignal] m) a}@@ -218,7 +225,7 @@ mplus (MHT m) (MHT n) = MHT . ExceptT $ do res <- runExceptT m case res of- Left e -> runExceptT n+ Left _e -> runExceptT n Right r -> return $ Right r runMethodHandlerT :: MethodHandlerT m a -> m (Either MsgError a, [SomeSignal])@@ -287,11 +294,11 @@ type family ArgParity (x :: [DBusType]) :: Parity where ArgParity '[] = 'Null- ArgParity (x ': xs) = Arg (ArgParity xs)+ ArgParity (x ': xs) = 'Arg (ArgParity xs) infixr 0 :> data ArgumentDescription parity where- (:>) :: Text -> ArgumentDescription n -> ArgumentDescription (Arg n)+ (:>) :: Text -> ArgumentDescription n -> ArgumentDescription ('Arg n) Done :: ArgumentDescription 'Null deriving (Typeable) @@ -322,8 +329,8 @@ where argsToValues' :: Sing ts -> DBusArguments ts -> [SomeDBusValue] argsToValues' (SNil) ArgsNil = []- argsToValues' (SCons t ts) (ArgsCons a as) =- withSingI t $ (DBV a) : argsToValues' ts as+ argsToValues' (SCons t ts) (ArgsCons a' as) =+ withSingI t $ (DBV a') : argsToValues' ts as argsToStruct :: DBusArguments (t ': ts) -> DBusStruct (t ': ts) argsToStruct (ArgsCons x ArgsNil) = StructSingleton x@@ -342,7 +349,7 @@ sings = sing :: Sing ss in case singt of SNil -> Nothing- SCons t' ts' -> case singt %~ sings of+ SCons _ ts' -> case singt %~ sings of Proved Refl -> withSingI ts' (Just $ argsToStruct args) Disproved _ -> Nothing @@ -371,6 +378,7 @@ StructSingleton x == StructSingleton y = x == y StructCons x xs == StructCons y ys = x == y && xs == ys+ _ == _ = False -- Why do we need this? data SomeDBusStruct where SDBS :: SingI ts => DBusStruct ts -> SomeDBusStruct@@ -383,28 +391,29 @@ withSingI t $ "StructSingleton (" ++ show x ++ ")" showStruct (SCons t ts ) (StructCons x xs) = withSingI t $ "StructCons (" ++ show x ++ ") (" ++ showStruct ts xs ++ ")"+showStruct _ _ = error "showStruct: Impossible arguments. This is a bug" data DBusValue :: DBusType -> * where- DBVByte :: Word8 -> DBusValue ('DBusSimpleType TypeByte)- DBVBool :: Bool -> DBusValue ('DBusSimpleType TypeBoolean)- DBVInt16 :: Int16 -> DBusValue ('DBusSimpleType TypeInt16)- DBVUInt16 :: Word16 -> DBusValue ('DBusSimpleType TypeUInt16)- DBVInt32 :: Int32 -> DBusValue ('DBusSimpleType TypeInt32)- DBVUInt32 :: Word32 -> DBusValue ('DBusSimpleType TypeUInt32)- DBVInt64 :: Int64 -> DBusValue ('DBusSimpleType TypeInt64)- DBVUInt64 :: Word64 -> DBusValue ('DBusSimpleType TypeUInt64)- DBVDouble :: Double -> DBusValue ('DBusSimpleType TypeDouble)- DBVUnixFD :: Word32 -> DBusValue ('DBusSimpleType TypeUnixFD)- DBVString :: Text -> DBusValue ('DBusSimpleType TypeString)- DBVObjectPath :: ObjectPath -> DBusValue ('DBusSimpleType TypeObjectPath)- DBVSignature :: [DBusType] -> DBusValue ('DBusSimpleType TypeSignature)- DBVVariant :: (SingI t ) => DBusValue t -> DBusValue TypeVariant- DBVArray :: [DBusValue a] -> DBusValue (TypeArray a)- DBVByteArray :: BS.ByteString -> DBusValue (TypeArray ('DBusSimpleType TypeByte))- DBVStruct :: DBusStruct ts -> DBusValue (TypeStruct ts)+ DBVByte :: Word8 -> DBusValue ('DBusSimpleType 'TypeByte)+ DBVBool :: Bool -> DBusValue ('DBusSimpleType 'TypeBoolean)+ DBVInt16 :: Int16 -> DBusValue ('DBusSimpleType 'TypeInt16)+ DBVUInt16 :: Word16 -> DBusValue ('DBusSimpleType 'TypeUInt16)+ DBVInt32 :: Int32 -> DBusValue ('DBusSimpleType 'TypeInt32)+ DBVUInt32 :: Word32 -> DBusValue ('DBusSimpleType 'TypeUInt32)+ DBVInt64 :: Int64 -> DBusValue ('DBusSimpleType 'TypeInt64)+ DBVUInt64 :: Word64 -> DBusValue ('DBusSimpleType 'TypeUInt64)+ DBVDouble :: Double -> DBusValue ('DBusSimpleType 'TypeDouble)+ DBVUnixFD :: Word32 -> DBusValue ('DBusSimpleType 'TypeUnixFD)+ DBVString :: Text -> DBusValue ('DBusSimpleType 'TypeString)+ DBVObjectPath :: ObjectPath -> DBusValue ('DBusSimpleType 'TypeObjectPath)+ DBVSignature :: [DBusType] -> DBusValue ('DBusSimpleType 'TypeSignature)+ DBVVariant :: (SingI t ) => DBusValue t -> DBusValue 'TypeVariant+ DBVArray :: [DBusValue a] -> DBusValue ('TypeArray a)+ DBVByteArray :: BS.ByteString -> DBusValue ('TypeArray ('DBusSimpleType 'TypeByte))+ DBVStruct :: DBusStruct ts -> DBusValue ('TypeStruct ts) DBVDict :: [(DBusValue ('DBusSimpleType k) ,DBusValue v)]- -> DBusValue (TypeDict k v)- DBVUnit :: DBusValue TypeUnit -- How to get rid of this?+ -> DBusValue ('TypeDict k v)+ DBVUnit :: DBusValue 'TypeUnit -- How to get rid of this? -- Unit isn't an actual DBus type and is included only for use with methods -- that don't return a value. @@ -437,7 +446,6 @@ DBVUnit == DBVUnit = True DBVArray x == DBVByteArray y = BS.pack (map (\(DBVByte w) -> w) x) == y DBVByteArray x == DBVArray y = BS.pack (map (\(DBVByte w) -> w) y) == x- _ == _ = False castDBV :: (SingI s, SingI t) => DBusValue s -> Maybe (DBusValue t) castDBV (v :: DBusValue s)@@ -461,7 +469,7 @@ dbusSValue (DBV v) = castDBV v -- | Extract a DBusValue from a Variant iff the type matches or return nothing-fromVariant :: SingI t => DBusValue TypeVariant -> Maybe (DBusValue t)+fromVariant :: SingI t => DBusValue 'TypeVariant -> Maybe (DBusValue t) fromVariant (DBVVariant v) = castDBV v instance SingI t => Show (DBusValue t) where@@ -486,18 +494,18 @@ else "" - show y@(DBVByteArray x) = "DBVByteArray " ++ show x- show y@(DBVStruct x :: DBusValue t) = case (sing :: Sing t) of+ show (DBVByteArray x) = "DBVByteArray " ++ show x+ show (DBVStruct x :: DBusValue t) = case (sing :: Sing t) of STypeStruct ts -> withSingI ts $ "DBVStruct (" ++ show x ++ ")"- show y@(DBVVariant x ) = "DBVVariant (" ++ show x ++ ")"+ show (DBVVariant x ) = "DBVVariant (" ++ show x ++ ")" show y@(DBVDict x :: DBusValue t ) = case (sing :: Sing t) of STypeDict kt vt -> withSingI kt $ withSingI vt $ "DBDict (" ++ show x ++ ")" ++ if null x then " :: " ++ show (typeOf y) else ""- show y@(DBVUnit ) = "DBVUnit"+ show (DBVUnit ) = "DBVUnit" typeOf :: SingI t => DBusValue t -> DBusType typeOf (_ :: DBusValue a) = fromSing (sing :: SDBusType a)@@ -559,6 +567,12 @@ fromRep :: DBusValue (RepType a) -> Maybe a +type family FromTypeList t where+ FromTypeList '[] = 'TypeUnit+ FromTypeList '[t] = t+ FromTypeList ts = 'TypeStruct ts++ ------------------------------------------------ -- Objects ------------------------------------------------@@ -637,6 +651,7 @@ mempty = Object Map.empty mappend (Object o1) (Object o2) = Object $ Map.unionWith (<>) o1 o2 +object :: Text -> Interface -> Object object interfaceName iface = Object $ Map.singleton interfaceName iface @@ -646,7 +661,8 @@ mempty = Objects Map.empty mappend (Objects o1) (Objects o2) = Objects $ Map.unionWith (<>) o1 o2 -root path object = Objects $ Map.singleton path object+root :: ObjectPath -> Object -> Objects+root path obj = Objects $ Map.singleton path obj -------------------------------------------------- -- Connection and Message@@ -687,6 +703,7 @@ , matchSender :: Maybe Text } deriving (Show, Eq, Ord) +anySignal :: MatchSignal anySignal = MatchSignal Nothing Nothing Nothing Nothing type SignalSlots = [ (( Match Text@@ -708,11 +725,15 @@ DBusConnection { dBusCreateSerial :: STM Serial , dBusAnswerSlots :: TVar AnswerSlots- , dbusSignalSlots :: TVar SignalSlots- , dbusPropertySlots :: TVar PropertySlots+ , dBusSignalSlots :: TVar SignalSlots+ , dBusPropertySlots :: TVar PropertySlots , dBusWriteLock :: TMVar (BS.Builder -> IO ()) , dBusConnectionName :: Text- , connectionAliveRef :: TVar Bool+ , dBusConnectionAliveRef :: TVar Bool+ , dBusGcRef :: !(TVar ())+ -- ^ A dummy TVar to which we attach a finalizer.+ -- When this TVar is garbage-collected, the connection is closed.+ , dBusKillConnection :: IO () } data MethodDescription args rets where
src/DBus/Wire.hs view
@@ -6,23 +6,22 @@ module DBus.Wire where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>)) import Control.Monad-import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.RWS import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans-import qualified Data.Binary.Get as B-import qualified Data.Binary.IEEE754 as B-import qualified Data.ByteString as BS+import qualified Data.Binary.Get as B+import qualified Data.Binary.IEEE754 as B+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS-import qualified Data.Conduit as C+import qualified Data.Conduit as C+import Data.Functor.Identity (Identity(..)) import Data.Int import Data.Singletons import Data.Singletons.Prelude.List-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import Data.Word import DBus.Types@@ -54,7 +53,7 @@ alignment (TypeArray _) = 4 alignment (TypeStruct _) = 8 alignment (TypeDict _ _) = 8-+alignment _ = error "alignment not defined for Unit and DictEntry" data Endian = Little | Big deriving (Show, Eq, Enum, Bounded)@@ -75,10 +74,10 @@ putSize i = modify (+i) alignPut :: Int -> DBusPut ()-alignPut bytes = do+alignPut bs = do s <- get- let align = ((-s) `mod` bytes)- replicateM align . tell $ BS.word8 0+ let align = ((-s) `mod` bs)+ replicateM_ align . tell $ BS.word8 0 putSize align sizeOf :: Int -> Int -> DBusPut a -> DBusPut Int@@ -90,14 +89,14 @@ let start = ((here `aligning` offsetA) + offset) `aligning` al return $ (fst (execRWS x s start)) - start where- aligning x al = x + ((-x) `mod` al)+ aligning x' al = x' + ((-x') `mod` al) bytes :: (a -> BS.Builder) -> (a -> BS.Builder) -> Int -> a -> DBusPut ()-bytes l b bytes x = alignPut bytes >> endian l b x >> putSize bytes+bytes l b bs x = alignPut bs >> endian l b x >> putSize bs putWord8 :: Word8 -> DBusPut () putWord8 x = (tell $ BS.word8 x) >> putSize 1@@ -141,6 +140,7 @@ putObjectPath :: ObjectPath -> DBusPut () putObjectPath o = putText $ objectPathToText o +putSignatures :: [DBusType] -> RWST Endian BS.Builder Int Identity () putSignatures s = do let bs = toSignatures s len = BS.length bs@@ -149,6 +149,7 @@ putByteString bs putWord8 0 +putDBV :: SingI t => DBusValue t -> DBusPut () putDBV = putDBV' sing putDBV' :: Sing t -> DBusValue t -> DBusPut ()@@ -173,7 +174,6 @@ let al = alignment $ fromSing t size <- sizeOf 4 al content putWord32 $ fromIntegral size- s <- get alignPut al content putDBV' _ (DBVByteArray x) = do@@ -191,10 +191,12 @@ putWord32 . fromIntegral =<< sizeOf 4 8 content alignPut 8 content+putDBV' _ DBVUnit = error "putDBV' not defined for Unit" putStruct :: Sing a -> DBusStruct a -> DBusPut () putStruct (SCons t SNil) (StructSingleton v) = putDBV' t v putStruct (SCons t ts) (StructCons v vs ) = putDBV' t v >> putStruct ts vs+putStruct _ _ = error "putStruct: impossible case" runDBusPut :: Num s => r -> RWS r b s a -> b runDBusPut e x = snd $ evalRWS x e 0@@ -217,9 +219,9 @@ Big -> lift $ b alignGet :: Int -> DBusGet ()-alignGet bytes = do+alignGet bs = do s <- fromIntegral <$> lift B.bytesRead- let align = ((-s) `mod` bytes)+ let align = ((-s) `mod` bs) lift $ B.skip align getting :: B.Get a -> B.Get a -> Int -> DBusGet a@@ -263,6 +265,7 @@ getBool :: DBusGet Bool getBool = toEnum' <$> getWord32 +getSignatures :: ReaderT Endian B.Get [DBusType] getSignatures = do len <- getWord8 bs <- lift $ B.getByteString (fromIntegral len)@@ -271,6 +274,7 @@ Nothing -> fail $ "could not parse signature" ++ show bs Just s -> return s +getByteString :: MonadTrans t => Int -> t B.Get BS.ByteString getByteString = lift . B.getByteString getDBV :: SingI t => DBusGet (DBusValue t)@@ -315,10 +319,12 @@ len <- getWord32 alignGet 8 DBVDict <$> getManyPairs (fromIntegral len) (SDBusSimpleType k) v+getDBV' _ = error "getDBV not defined for DictEntry and Unit" getStruct :: Sing ts -> DBusGet (DBusStruct ts) getStruct (SCons t SNil) = StructSingleton <$> getDBV' t getStruct (SCons t ts) = StructCons <$> getDBV' t <*> getStruct ts+getStruct SNil = error "getStruct: Empty struct is impossible" getMany :: Int64 -> Sing t -> DBusGet [DBusValue t] getMany len t = do