diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/d-bus.cabal b/d-bus.cabal --- a/d-bus.cabal +++ b/d-bus.cabal @@ -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 diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -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 () diff --git a/src/DBus/Auth.hs b/src/DBus/Auth.hs --- a/src/DBus/Auth.hs +++ b/src/DBus/Auth.hs @@ -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 diff --git a/src/DBus/Error.hs b/src/DBus/Error.hs --- a/src/DBus/Error.hs +++ b/src/DBus/Error.hs @@ -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" diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs --- a/src/DBus/Introspect.hs +++ b/src/DBus/Introspect.hs @@ -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 = [] diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -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 diff --git a/src/DBus/Message.hs b/src/DBus/Message.hs --- a/src/DBus/Message.hs +++ b/src/DBus/Message.hs @@ -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 diff --git a/src/DBus/MessageBus.hs b/src/DBus/MessageBus.hs --- a/src/DBus/MessageBus.hs +++ b/src/DBus/MessageBus.hs @@ -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 diff --git a/src/DBus/Method.hs b/src/DBus/Method.hs --- a/src/DBus/Method.hs +++ b/src/DBus/Method.hs @@ -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 diff --git a/src/DBus/Object.hs b/src/DBus/Object.hs --- a/src/DBus/Object.hs +++ b/src/DBus/Object.hs @@ -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) diff --git a/src/DBus/Property.hs b/src/DBus/Property.hs --- a/src/DBus/Property.hs +++ b/src/DBus/Property.hs @@ -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 diff --git a/src/DBus/Representable.hs b/src/DBus/Representable.hs --- a/src/DBus/Representable.hs +++ b/src/DBus/Representable.hs @@ -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) diff --git a/src/DBus/Scaffold.hs b/src/DBus/Scaffold.hs --- a/src/DBus/Scaffold.hs +++ b/src/DBus/Scaffold.hs @@ -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)) diff --git a/src/DBus/Signal.hs b/src/DBus/Signal.hs --- a/src/DBus/Signal.hs +++ b/src/DBus/Signal.hs @@ -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 diff --git a/src/DBus/Signature.hs b/src/DBus/Signature.hs --- a/src/DBus/Signature.hs +++ b/src/DBus/Signature.hs @@ -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 diff --git a/src/DBus/TH.hs b/src/DBus/TH.hs --- a/src/DBus/TH.hs +++ b/src/DBus/TH.hs @@ -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 diff --git a/src/DBus/Transport.hs b/src/DBus/Transport.hs --- a/src/DBus/Transport.hs +++ b/src/DBus/Transport.hs @@ -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 diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -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 diff --git a/src/DBus/Wire.hs b/src/DBus/Wire.hs --- a/src/DBus/Wire.hs +++ b/src/DBus/Wire.hs @@ -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