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.0.1.1 +version: 0.0.3 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 @@ -33,18 +33,19 @@ , DBus.Wire build-depends: base >= 4 && <5 , async >= 2.0 - , attoparsec >= 0.11 + , attoparsec >= 0.12 , binary >= 0.7 , blaze-builder >= 0.3 , bytestring >= 0.10 - , conduit >= 1.0 + , conduit >= 1.1 + , conduit-extra >= 1.1 , containers >= 0.5 , data-binary-ieee754 >= 0.4 , data-default >= 0.5 , free >= 4.2 , mtl >= 2.1 , network >= 2.4 - , singletons >= 0.9 + , singletons >= 1.0 , stm >= 2.4 , template-haskell >= 2.8 , text >= 1.1 @@ -53,6 +54,7 @@ , xml-picklers >= 0.3 , xml-types >= 0.3 , hslogger >= 1.2 + , exceptions >= 0.6 if os(freebsd) { c-sources: src/cbits/credentials.c cpp-options: -DSEND_CREDENTIALS diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -32,7 +32,9 @@ , DBusType(..) , Signature(..) , typeOf --- ** ObjectPath +-- ** Objects + , Object(..) + , Interface(..) , ObjectPath , objectPath , objectPathToText @@ -43,9 +45,11 @@ -- * Methods , Method(..) , MethodWrapper(..) + , MethodDescription(..) , repMethod , callMethod , callMethod' + , MsgError(..) -- * Introspection , addIntrospectable -- * Message Bus diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -16,6 +16,7 @@ import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad +import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Fix (mfix) import Control.Monad.Trans import Data.Binary.Get as B @@ -38,7 +39,7 @@ import System.Log.Logger import System.Mem.Weak -import Data.Attoparsec as AP +import Data.Attoparsec.ByteString as AP import Data.List (intercalate) import Data.Monoid import Numeric @@ -99,7 +100,7 @@ case ret of Left e -> return $ Left (MsgError "org.freedesktop.DBus.Error.Failed" - (Just $ "Method threw exception " + (Just $ "Method threw exception: " `Text.append` Text.pack (show e)) []) Right r -> return $ r let bs = either (errToErrMessage serial) (mkReturnMethod serial) ret @@ -120,13 +121,13 @@ when alive retry -- | Which Bus to connect to -data ConnectionType = Session -- ^ The well-known system bus. First +data ConnectionType = System -- ^ The well-known system bus. First -- the environmental variable - -- DBUS_SESSION_BUS_ADDRESS is checked and if it + -- DBUS_SYSTEM_BUS_ADDRESS is checked and if it -- doesn't exist the address -- /unix:path=\/var\/run\/dbus\/system_bus_socket/ -- is used - | System -- ^ The well-known system bus. Refers to the + | Session -- ^ The well-known session bus. Refers to the -- address stored in the environmental variable -- DBUS_SESSION_BUS_ADDRESS | Address String -- ^ The bus at the give addresss @@ -159,7 +160,7 @@ debugM "DBus" $ "connecting to " ++ addressString mbS <- connectString addressString s <- case mbS of - Nothing -> C.monadThrow (CouldNotConnect + Nothing -> throwM (CouldNotConnect "All addresses failed to connect") Just s -> return s sendCredentials s diff --git a/src/DBus/Message.hs b/src/DBus/Message.hs --- a/src/DBus/Message.hs +++ b/src/DBus/Message.hs @@ -13,7 +13,7 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Reader -import qualified Data.Attoparsec.Char8 as AP8 +import qualified Data.Attoparsec.ByteString.Char8 as AP8 import qualified Data.Binary.Get as B import Data.Bits import qualified Data.ByteString as BS @@ -27,6 +27,7 @@ import qualified Data.Text as Text import Data.Word import System.Mem.Weak +import Control.Monad.Catch (MonadThrow, throwM) import DBus.Error import DBus.Representable @@ -262,7 +263,7 @@ getDBVByType t return (header, args) -parseMessages :: C.MonadThrow m => +parseMessages :: MonadThrow m => C.ConduitM BS.ByteString (MessageHeader, [SomeDBusValue]) m b parseMessages = forever $ C.yield =<< sinkGet getMessage @@ -306,7 +307,7 @@ -- | Synchronously call a method. Returned errors are thrown as 'MethodError's. -- If the returned value's type doesn't match the expected type a -- 'MethodSignatureMissmatch' is thrown. -callMethod' :: (SingI (RepType a), Representable a, C.MonadThrow m, MonadIO m) => +callMethod' :: (SingI (RepType a), Representable a, MonadThrow m, MonadIO m) => Text.Text -- ^ Entity to send the message to -> ObjectPath -- ^ Object -> Text.Text -- ^ Interface @@ -319,7 +320,7 @@ ret <- liftIO . getAnswer $ callMethod dest path interface member args flags conn case ret of - Left e -> C.monadThrow $ MethodErrorMessage e + Left e -> throwM $ MethodErrorMessage e Right r -> case fromRep =<< dbusValue r of - Nothing -> C.monadThrow $ MethodSignatureMissmatch r + Nothing -> throwM $ MethodSignatureMissmatch r Just x -> return x diff --git a/src/DBus/MessageBus.hs b/src/DBus/MessageBus.hs --- a/src/DBus/MessageBus.hs +++ b/src/DBus/MessageBus.hs @@ -7,7 +7,7 @@ import DBus.Message import DBus.Object import DBus.Types -import Data.Conduit (MonadThrow, monadThrow) +import Control.Monad.Catch (MonadThrow, throwM) import Data.Default import Data.Singletons import qualified Data.Text as Text @@ -66,7 +66,7 @@ 2 -> return InQueue 3 -> return Exists 4 -> return AlreadyOwner - e -> monadThrow . MarshalError $ "Not a ReqeustName reply: " ++ show e + e -> throwM . MarshalError $ "Not a ReqeustName reply: " ++ show e data ReleaseNameReply = Released | NonExistent @@ -82,7 +82,7 @@ 1 -> return Released 2 -> return NonExistent 3 -> return NotOwner - e -> monadThrow . MarshalError $ "Not a ReleaseName reply: " ++ show e + e -> throwM . MarshalError $ "Not a ReleaseName reply: " ++ show e listQueuedOwners :: (MonadIO m, MonadThrow m) => Text.Text diff --git a/src/DBus/Object.hs b/src/DBus/Object.hs --- a/src/DBus/Object.hs +++ b/src/DBus/Object.hs @@ -18,15 +18,15 @@ import Data.List (intercalate, find) import Data.Maybe import Data.Singletons -import Data.Singletons.List +import Data.Singletons.Prelude.List import Data.Singletons.TH import qualified Data.Text as Text import DBus.Types class IsMethod f where - type ArgTypes f - type ResultType f + type ArgTypes f :: [DBusType] + type ResultType f :: DBusType toMethod :: f -> MethodWrapper (ArgTypes f) (ResultType f) instance SingI t => IsMethod (IO (DBusValue t)) where diff --git a/src/DBus/Signal.hs b/src/DBus/Signal.hs --- a/src/DBus/Signal.hs +++ b/src/DBus/Signal.hs @@ -3,7 +3,7 @@ import Control.Applicative import Control.Monad.Trans -import Data.Conduit (MonadThrow) +import Control.Monad.Catch (MonadThrow) import qualified Data.List as List import Data.Maybe import Data.Monoid diff --git a/src/DBus/TH.hs b/src/DBus/TH.hs --- a/src/DBus/TH.hs +++ b/src/DBus/TH.hs @@ -74,7 +74,7 @@ [(conName, fields)] -> oneCon conName fields cs -> multiCon cs inst <- instanceD ctx iHead - [ tySynInstD ''RepType [fullType] repType + [ tySynInstD ''RepType $ tySynEqn [fullType] repType , funD 'toRep toClauses , funD 'fromRep fromClauses ] @@ -182,7 +182,8 @@ varNames <- replicateM num (newName "x") tmpNames <- replicateM num (newName "mbx") instanceD ctx iHead - [ tySynInstD ''RepType [tp] (appT (promotedT 'TypeStruct) tpList) + [ tySynInstD ''RepType $ tySynEqn [tp] + (appT (promotedT 'TypeStruct) tpList) , funD ('toRep) $ let pats = [tupP (map varP varNames)] bs = normalB (appE (conE 'DBVStruct) diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -28,9 +28,9 @@ import Data.List (intercalate) import qualified Data.Map as Map import Data.Singletons (withSingI) -import Data.Singletons.Bool -import Data.Singletons.List -import Data.Singletons.TH +import Data.Singletons.Prelude.Bool +import Data.Singletons.Prelude.List +import Data.Singletons.TH hiding (Error) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.Word @@ -140,7 +140,7 @@ infixr 0 :-> data MethodDescription parity where (:->) :: Text.Text -> MethodDescription n -> MethodDescription (Arg n) - Result :: Text.Text -> MethodDescription Null + Result :: Text.Text -> MethodDescription 'Null genSingletons [''DBusSimpleType, ''DBusType, ''Parity] singEqInstances [''DBusSimpleType, ''DBusType, ''Parity] diff --git a/src/DBus/Wire.hs b/src/DBus/Wire.hs --- a/src/DBus/Wire.hs +++ b/src/DBus/Wire.hs @@ -8,6 +8,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad +import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.RWS import Control.Monad.Reader import Control.Monad.State @@ -16,13 +17,13 @@ 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 Data.Int import Data.Singletons -import Data.Singletons.List +import Data.Singletons.Prelude.List import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word -import qualified Data.Conduit as C import DBus.Types import DBus.Signature @@ -355,9 +356,9 @@ GT -> mzero -sinkGet :: C.MonadThrow m => B.Get b -> C.ConduitM BS.ByteString o m b +sinkGet :: MonadThrow m => B.Get b -> C.ConduitM BS.ByteString o m b sinkGet f = sink (B.runGetIncremental f) where sink (B.Done bs _ v) = C.leftover bs >> return v - sink (B.Fail u o e) = C.monadThrow $ DBusParseError e + sink (B.Fail u o e) = throwM $ DBusParseError e sink (B.Partial next) = C.await >>= sink . next