d-bus (empty) → 0.0.1
raw patch · 19 files changed
+2967/−0 lines, 19 filesdep +asyncdep +attoparsecdep +basesetup-changed
Dependencies added: async, attoparsec, base, binary, blaze-builder, bytestring, conduit, containers, data-binary-ieee754, data-default, free, hslogger, mtl, network, singletons, stm, template-haskell, text, transformers, xml-conduit, xml-picklers, xml-types
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- d-bus.cabal +77/−0
- src/DBus.hs +78/−0
- src/DBus/Auth.hs +189/−0
- src/DBus/Error.hs +12/−0
- src/DBus/Introspect.hs +242/−0
- src/DBus/MainLoop.hs +228/−0
- src/DBus/Message.hs +325/−0
- src/DBus/MessageBus.hs +144/−0
- src/DBus/Object.hs +147/−0
- src/DBus/Representable.hs +128/−0
- src/DBus/Signal.hs +93/−0
- src/DBus/Signature.hs +121/−0
- src/DBus/TH.hs +197/−0
- src/DBus/Transport.hs +179/−0
- src/DBus/Types.hs +392/−0
- src/DBus/Wire.hs +363/−0
- src/cbits/credentials.c +31/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013 dbus-magic++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ d-bus.cabal view
@@ -0,0 +1,77 @@+name: d-bus+version: 0.0.1+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+ singletons library to embedd the D-Bus type system. D-Bus+ signatures can thus be inferred.+license: BSD3+license-file: LICENSE+author: Philipp Balzarek+maintainer: p.balzarek@googlemail.com+copyright: 2013 Philipp Balzarek+category: Network, Desktop+build-type: Simple+cabal-version: >=1.8++library+ hs-source-dirs: src/+-- ghc-options: -O2+ exposed-modules: DBus+ , DBus.Auth+ , DBus.Error+ , DBus.Introspect+ , DBus.MainLoop+ , DBus.Message+ , DBus.MessageBus+ , DBus.Object+ , DBus.Representable+ , DBus.Signature+ , DBus.Signal+ , DBus.TH+ , DBus.Transport+ , DBus.Types+ , DBus.Wire+ build-depends: base >= 4 && <5+ , async+ , attoparsec+ , binary >= 0.7+ , blaze-builder+ , bytestring+ , conduit >= 1.0+ , containers+ , data-binary-ieee754+ , data-default+ , free+ , mtl+ , network+ , singletons+ , stm+ , template-haskell+ , text+ , transformers+ , xml-conduit+ , xml-picklers+ , xml-types+ , hslogger+ if os(freebsd) {+ c-sources: src/cbits/credentials.c+ cpp-options: -DSEND_CREDENTIALS+ }++-- test-suite tests+-- type: exitcode-stdio-1.0+-- hs-source-dirs: tests+-- main-is: Main.hs+-- build-depends: base >= 4 && < 5+-- , dbus-ext+-- , xml-hamlet+-- , QuickCheck+-- , text+-- , tasty+-- , tasty-th+-- , tasty-quickcheck+-- , singletons+-- , bytestring+-- , binary+-- , mtl
+ src/DBus.hs view
@@ -0,0 +1,78 @@+module DBus+ (+-- * Connection management+ ConnectionType(..)+ , connectBus+ , MethodCallHandler+ , SignalHandler+ , checkAlive+ , waitFor+-- * Message handling+ , objectRoot+-- * Signals+ , MatchRule(..)+ , matchAll+ , matchSignal+ , addMatch+ , removeMatch+-- * Representable Types+ , Representable(..)+ , makeRepresentable+ , makeRepresentableTuple+-- * DBus specific types+-- ** DBus Values+ , DBusValue(..)+ , castDBV+ , DBusStruct(..)+ , SomeDBusValue(..)+ , dbusValue+ , fromVariant+-- ** Signature+ , DBusSimpleType(..)+ , DBusType(..)+ , Signature(..)+ , typeOf+-- ** ObjectPath+ , ObjectPath+ , objectPath+ , objectPathToText+ , stripObjectPrefix+ , isPathPrefix+ , isRoot+ , isEmpty+-- * Methods+ , Method(..)+ , MethodWrapper(..)+ , repMethod+ , callMethod+ , callMethod'+-- * Introspection+ , addIntrospectable+-- * Message Bus+ , requestName+ , RequestNameFlag(..)+ , RequestNameReply(..)+ , releaseName+ , ReleaseNameReply (..)+ , listQueuedOwners+ , listNames+ , listActivatableNames+ , nameHasOwner+ , startServiceByName+ , getNameOwner+ , getConnectionUnixUser+ , getConnectionProcessID+ , getID+ ) where++import DBus.Introspect+import DBus.MainLoop+import DBus.MessageBus+import DBus.Object+import DBus.Types+import DBus.Signal+import DBus.TH+import DBus.Message++-- | Ignore all incoming messages/signals+ignore _ _ _ = return ()
+ src/DBus/Auth.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}++module DBus.Auth where++import Control.Applicative+import Control.Monad.Error+import Control.Monad.Free+import qualified Data.Attoparsec as AP+import qualified Data.Attoparsec.Char8 as AP8+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Builder as BS+import Data.Monoid+import Data.Word+import Numeric+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++type Mechanism = BS.ByteString++type InitialResponse = BS.ByteString++data ServerMessage = SMRejected [BS.ByteString]+ | SMOK BS.ByteString+ | SMError BS.ByteString+ | SMAgreeUnixFD+ | SMData BS.ByteString+ deriving (Show)++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+ 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)++++encodeHexString :: BS.ByteString -> BS.Builder+encodeHexString bs = mconcat . map hexifyChar $ BS.unpack bs+ where+ hexifyChar c = case showHex c "" of+ [x] -> BS.char8 '0' <> BS.char8 x+ [x,y] -> BS.char8 x <> BS.char8 y+ _ -> error "encodeHexString : unexpected number of chars"++parseLine :: BS.ByteString+ -> (t -> a)+ -> AP.Parser t+ -> AP.Parser a+parseLine command cons args = do+ AP.string command+ res <- args+ AP.string "\r"+ return $ cons res++parseWords :: AP.Parser [BS.ByteString]+parseWords = (AP8.char8 ' ' >> (parseWord `AP.sepBy` (AP8.char8 ' ')))+ `mplus` (return [])++parseWord :: AP.Parser BS.ByteString+parseWord = space $ AP8.takeWhile1 wordChar+ where+ wordChar c = c /= ' ' && c /= '\r' && c /= '\n'++restOfLine :: AP.Parser BS.ByteString+restOfLine = space $ AP8.takeWhile (/= '\r')++parseServerLine :: AP.Parser ServerMessage+parseServerLine = AP.choice+ [ parseLine "REJECTED" SMRejected parseWords+ , parseLine "OK" SMOK parseHexString+ , parseLine "ERROR" SMError restOfLine+ , parseLine "AGREE_UNIX_FD" (const SMAgreeUnixFD) (return ())+ , parseLine "DATA" SMData parseHexString+ ]+++data ClientMessage = CMAuth Mechanism InitialResponse+ | CMCancel+ | CMBegin+ | CMData BS.ByteString+ | CMError BS.ByteString+ | CMNegotiateUnixFD+ deriving (Show)+++serializeLine command rest =+ BS.byteString command <> BS.char8 ' ' <> rest <> BS.byteString "\r\n"+++serializeCMessage (CMAuth mechanism response) =+ serializeLine "AUTH" $ if BS.null mechanism+ then mempty+ else BS.byteString mechanism+ <> if BS.null response+ then mempty+ else BS.char8 ' ' <> BS.byteString response+serializeCMessage CMCancel = serializeLine "CANCEL" mempty+serializeCMessage CMBegin = serializeLine "BEGIN" mempty+serializeCMessage (CMData d) = serializeLine "DATA" (encodeHexString d)+serializeCMessage (CMError d) = serializeLine "ERROR" (BS.byteString d)+serializeCMessage CMNegotiateUnixFD =+ serializeLine "AGREE_UNIX_FD" mempty++data SASLF a = Send ClientMessage a+ | Recv (ServerMessage -> a)+ deriving (Functor)++newtype SASL a = SASL {unSASL :: ErrorT String (Free SASLF) a}+ deriving (Functor, Applicative, Monad)++instance MonadError String SASL where+ throwError = SASL . throwError+ catchError (SASL m) f = SASL $ catchError m (unSASL . f)++saslSend :: ClientMessage -> SASL ()+saslSend x = SASL . lift $ Free (Send x (return ()))++saslRecv :: SASL ServerMessage+saslRecv = SASL . lift $ Free (Recv $ return )++expectData :: SASL BS.ByteString+expectData = do+ r <- saslRecv+ case r of+ SMData x -> return x+ e -> throwError $ "Expected DATA but got " ++ show e++expectOK :: SASL BS.ByteString+expectOK = do+ r <- saslRecv+ case r of+ SMOK x -> return x+ e -> throwError $ "Expected OK but got " ++ show e++runSasl :: Monad m =>+ (BS.Builder -> m a)+ -> m BS.ByteString+ -> SASL b+ -> m (Either String b)+runSasl snd' rcv' (SASL s) = do+ let snd = snd' . serializeCMessage+ rcv = do+ bs <- rcv'+ case AP.parseOnly parseServerLine bs of+ Left e -> return .+ SMError . Text.encodeUtf8 . Text.pack $+ "Could not parse server message" ++ show bs+ ++ ": " ++ show e+ Right r -> return r+ return ()+ res <- go snd rcv (runErrorT s)+ case res of+ Left e -> do+ snd (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++sasl = do+ saslSend (CMAuth "" "")+ saslRecv++external :: SASL BS.ByteString+external = do+ saslSend (CMAuth "EXTERNAL" "")+ "" <- expectData+ saslSend (CMData "")+ ok <- expectOK+ saslSend CMBegin+ return ok
+ src/DBus/Error.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Error where++import Control.Exception as Ex+import Data.Typeable (Typeable)++data DBusError = CouldNotConnect String+ | DBusParseError String+ | MarshalError String+ deriving (Show, Eq, Typeable)++instance Ex.Exception DBusError
+ src/DBus/Introspect.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}++module DBus.Introspect where++import Blaze.ByteString.Builder+import Control.Applicative ((<$>))+import Control.Exception (SomeException)+import qualified Data.ByteString as BS+import Data.Conduit (($$), ($=))+import Data.Conduit.List (consume, sourceList)+import Data.Data(Data)+import Data.Functor.Identity+import Data.Maybe+import Data.Monoid (mconcat)+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+import Text.XML.Stream.Parse+import Text.XML.Stream.Render+import Text.XML.Unresolved (toEvents, fromEvents)++import DBus.Object+import DBus.Representable+import DBus.Signature+import DBus.Types++data IDirection = In | Out deriving (Eq, Show, Data, Typeable)++directionFromText :: Text.Text -> Either Text.Text IDirection+directionFromText "in" = Right In+directionFromText "out" = Right Out+directionFromText d = Left $ "Not a direction: " `Text.append` d++directionToText :: IDirection -> Text.Text+directionToText In = "in"+directionToText Out = "out"++data IPropertyAccess = Read+ | Write+ | ReadWrite+ deriving (Eq, Show, Data, Typeable)++propertyAccessFromText :: Text.Text -> Either Text.Text IPropertyAccess+propertyAccessFromText "read" = Right Read+propertyAccessFromText "write" = Right Write+propertyAccessFromText "readwrite" = Right ReadWrite+propertyAccessFromText a = Left $ "Not a property access type: " `Text.append` a++propertyAccessToText :: IPropertyAccess -> Text.Text+propertyAccessToText Read = "read"+propertyAccessToText Write = "write"+propertyAccessToText ReadWrite = "readwrite"++data IArgument = IArgument { iArgumentName :: Text.Text+ , iArgumentType :: DBusType+ , iArgumentDirection :: Maybe IDirection+ } deriving (Eq, Show, Data, Typeable)++data IMethod = IMethod { iMethodName :: Text.Text+ , iMethodArguments :: [IArgument]+ , iMethodAnnotations :: [Annotation]+ } deriving (Eq, Show, Data, Typeable)++data ISignal = ISignal { iSignalName :: Text.Text+ , iSignalArguments :: [IArgument]+ , iSignalAnnotations :: [Annotation]+ } deriving (Eq, Show, Data, Typeable)++data IProperty = IProperty { iPropertyName :: Text.Text+ , iPropertType :: DBusType+ , iPropertyAccess :: IPropertyAccess+ , iPropertyAnnotation :: [Annotation]+ } deriving (Eq, Show, Data, Typeable)++data IInterface = IInterface { iInterfaceName :: Text.Text+ , iInterfaceMethods :: [IMethod]+ , iInterfaceSignals :: [ISignal]+ , iInterfaceProperties :: [IProperty]+ , iInterfaceAnnotations :: [Annotation]+ } deriving (Eq, Show, Data, Typeable)++data INode = INode { nodeName :: Text.Text+ , nodeInterfaces :: [IInterface]+ , nodeSubnodes :: [INode]+ } deriving (Eq, Show, Data, Typeable)++xpAnnotation :: PU [Node] Annotation+xpAnnotation = xpWrap (\(name, content) -> Annotation name content)+ (\(Annotation name content) -> (name, content)) $+ xpElemAttrs "annotation"+ (xp2Tuple (xpAttribute "name" xpText)+ (xpAttribute "value" xpText))++xpSignature :: PU Text.Text DBusType+xpSignature = xpPartial (eitherParseSig . Text.encodeUtf8)+ (Text.decodeUtf8 . toSignature)++xpDirection :: PU Text.Text IDirection+xpDirection = xpPartial directionFromText directionToText++xpPropertyAccess = xpPartial propertyAccessFromText propertyAccessToText++xpArgument :: PU [Node] IArgument+xpArgument = xpWrap (\(name, tp, dir) -> IArgument name tp dir)+ (\(IArgument name tp dir) -> (name, tp, dir)) $+ xpElemAttrs "arg"+ (xp3Tuple (xpAttribute "name" xpText)+ (xpAttribute "type" xpSignature)+ (xpAttribute' "direction" xpDirection)+ )++xpMethod :: PU [Node] IMethod+xpMethod = xpWrap (\(name,(args, anns)) -> IMethod name args anns )+ (\(IMethod name args anns) -> (name,(args, anns)) ) $+ xpElem "method"+ (xpAttribute "name" xpText)+ (xp2Tuple (xpFindMatches xpArgument)+ (xpFindMatches xpAnnotation))++xpSignal :: PU [Node] ISignal+xpSignal = xpWrap (\(name, (args, anns)) -> ISignal name args anns )+ (\(ISignal name args anns) -> (name, (args, anns)) ) $+ xpElem "signal"+ (xpAttribute "name" xpText)+ (xp2Tuple (xpFindMatches xpArgument)+ (xpFindMatches xpAnnotation))++xpProperty :: PU [Node] IProperty+xpProperty = xpWrap (\((name, tp, access), anns)+ -> IProperty name tp access anns)+ (\(IProperty name tp access anns)+ -> ((name, tp, access), anns)) $+ xpElem "property"+ (xp3Tuple (xpAttribute "name" xpText)+ (xpAttribute "type" xpSignature)+ (xpAttribute "access" xpPropertyAccess))+ (xpFindMatches xpAnnotation)+++xpInterface :: PU [Node] IInterface+xpInterface = xpWrap (\(name, (methods, signals, properties, annotations))+ -> IInterface name methods signals properties annotations)+ (\(IInterface name methods signals properties annotations)+ -> (name, (methods, signals, properties, annotations))) $+ xpElem "interface"+ (xpAttribute "name" xpText)+ (xp4Tuple (xpFindMatches xpMethod)+ (xpFindMatches xpSignal)+ (xpFindMatches xpProperty)+ (xpFindMatches xpAnnotation) )++xpNode :: PU [Node] INode+xpNode = xpWrap (\(name, (is, ns)) -> INode name is ns)+ (\(INode name is ns) -> (name, (is, ns))) $+ xpElem "node"+ (xpAttribute "name" xpText)+ (xp2Tuple (xpFindMatches xpInterface)+ (xpFindMatches xpNode))++xmlToNode :: BS.ByteString -> Either Text.Text INode+xmlToNode xml = case sourceList [xml] $= parseBytesPos def $$ fromEvents of+ Left e -> Left (Text.pack $ show (e :: SomeException))+ Right d -> case unpickle (xpRoot . xpUnliftElems $ xpNode) $ documentRoot d of+ Left e -> Left $ Text.pack (ppUnpickleError e)+ Right r -> Right r+++pubID :: ExternalID+pubID = PublicID "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+ "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"++prologue :: Prologue+prologue = Prologue { prologueBefore = []+ , prologueDoctype =+ Just (Doctype {doctypeName = "node"+ , doctypeID =+ Just pubID+ })+ , prologueAfter = []}+++nodeToXml :: INode -> BS.ByteString+nodeToXml node = toByteString . mconcat . runIdentity $+ (sourceList (toEvents doc)+ $= renderBuilder def+ $$ consume)+ where+ doc = Document prologue (pickle (xpRoot . xpUnliftElems $ xpNode) node) []++introspectMethods :: [Method] -> [IMethod]+introspectMethods = map introspectMethod+ where+ introspectMethod m = IMethod (methodName m) (toArgs m) []+ toArgs m@(Method _ _ ds) =+ let (args, res) = methodSignature m+ (ts, r) = argDescriptions ds+ in zipWith (\n t -> IArgument n t (Just In)) ts args+ ++ maybeToList ((\t -> IArgument r t (Just Out)) <$> res )++introspectInterface :: Interface -> IInterface+introspectInterface i = IInterface { iInterfaceName = interfaceName i+ , iInterfaceMethods = introspectMethods+ $ interfaceMethods i+ , iInterfaceSignals = [] -- TODO+ , iInterfaceProperties = [] -- TODO+ , iInterfaceAnnotations = [] -- TODO+ }++introspectObject o = INode { nodeName = objectPathToText $ objectObjectPath o+ , nodeInterfaces = introspectInterface <$>+ objectInterfaces o+ , nodeSubnodes = introspectObject+ <$> objectSubObjects o+ }++introspect :: Object -> IO Text.Text+introspect object = return $ Text.decodeUtf8 . nodeToXml $ introspectObject object++introspectMethod :: Object -> Method+introspectMethod object = Method (repMethod $ introspect object)+ "Introspect"+ (Result "xml_data")++introspectable :: Object -> Interface+introspectable o = Interface{ interfaceName = "org.freedesktop.DBus.Introspectable"+ , interfaceMethods = [introspectMethod o]+ , interfaceAnnotations = []+ }++addIntrospectable :: Object -> Object+addIntrospectable o@(Object nm is sos) =+ let intr = introspectable o+ in Object nm (if intr `elem` is then is else (intr:is))+ (addIntrospectable <$> sos)
+ src/DBus/MainLoop.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}++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 Control.Monad+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.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 qualified Data.Map as Map+import Data.Singletons+import qualified Data.Text as Text+import Data.Typeable (Typeable)+import Data.Word+import Foreign.C+import Network.Socket+import System.Environment+import System.IO+import System.Log.Logger+import System.Mem.Weak++import Data.Attoparsec as AP+import Data.List (intercalate)+import Data.Monoid+import Numeric++import DBus.Auth+import DBus.Error+import DBus.Message+import DBus.MessageBus+import DBus.Object+import DBus.Transport+import DBus.Types+import DBus.Wire++handleMessage handleCall handleSignals answerSlots (header, body) =+ case messageType header of+ MethodCall -> handleCall header body+ MethodReturn -> handleReturn True+ Error -> handleError+ Signal -> handleSignals header body+ _ -> return ()+ where+ handleReturn nonError = case hFReplySerial $ fields header of+ Nothing -> return ()+ Just s -> atomically $ do+ slots <- readTVar answerSlots+ let ret = case body of+ [] -> DBV DBVUnit+ (x:_) -> x+ case Map.lookup s slots of+ Nothing -> return ()+ Just putSlot -> do+ writeTVar answerSlots (Map.delete s slots)+ putSlot $ if nonError+ then Right ret+ else Left body+ handleError = case hFReplySerial $ fields header of+ Nothing -> return () -- TODO: handle non-response errors+ Just s -> handleReturn False++-- | Create a message handler that dispatches matches to the methods in a root+-- object+objectRoot :: Object -> Handler+objectRoot o conn header args | fs <- fields header+ , Just path <- hFPath fs+ , Just iface <- hFInterface fs+ , Just member <- hFMember fs+ , ser <- serial header+ , Just sender <- hFSender fs+ = 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 arg = methodReturn s ser sender (filter notUnit [arg])+ serial <- atomically $ dBusCreateSerial conn+ ret <- case callAtPath o path iface member args of+ Left e -> return $ Left e+ Right f -> do+ ret <- withAsync (Ex.catch (Right <$> f) (return . Left)) waitCatch+ case ret of+ Left e -> return $ Left+ (MsgError "org.freedesktop.DBus.Error.Failed"+ (Just $ "Method threw exception "+ `Text.append` Text.pack (show e)) [])+ Right r -> return $ r+ let bs = either (errToErrMessage serial) (mkReturnMethod serial) ret+ sendBS conn bs+ where notUnit (DBV DBVUnit) = False+ notUnit _ = True+objectRoot _ _ _ _ = return ()+++-- | Check whether connection is alive+checkAlive :: DBusConnection -> IO Bool+checkAlive conn = atomically $ readTVar (connectionAliveRef conn)++-- | Wait until connection is closed+waitFor :: DBusConnection -> IO ()+waitFor conn = atomically $ do+ alive <- readTVar (connectionAliveRef conn)+ when alive retry++-- | Which Bus to connect to+data ConnectionType = Session -- ^ The well-known system bus. First+ -- the environmental variable+ -- DBUS_SESSION_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+ -- address stored in the environmental variable+ -- DBUS_SESSION_BUS_ADDRESS+ | Address String -- ^ The bus at the give addresss++type MethodCallHandler = ( DBusConnection+ -> MessageHeader+ -> [SomeDBusValue]+ -> IO ())++type SignalHandler = ( DBusConnection+ -> MessageHeader+ -> [SomeDBusValue]+ -> IO ())++-- | Create a new connection to a message bus+connectBus :: ConnectionType -- ^ Bus to connect to+ -> MethodCallHandler -- ^ Handler for incoming method calls+ -> SignalHandler -- ^ Handler for incoming signals+ -> IO DBusConnection+connectBus transport handleCalls handleSignals = do+ addressString <- case transport of+ Session -> getEnv "DBUS_SESSION_BUS_ADDRESS"+ System -> do+ fromEnv <- Ex.try $ getEnv "DBUS_SYSTEM_BUS_ADDRESS"+ case fromEnv of+ Left (e :: Ex.SomeException) ->+ return "unix:path=/var/run/dbus/system_bus_socket"+ Right addr -> return addr+ Address addr -> return addr+ debugM "DBus" $ "connecting to " ++ addressString+ mbS <- connectString addressString+ s <- case mbS of+ Nothing -> C.monadThrow (CouldNotConnect+ "All addresses failed to connect")+ Just s -> return s+ sendCredentials s+ h <- socketToHandle s ReadWriteMode+ debugM "DBus" $ "Running SASL"+ runSasl (\bs -> do+ debugM "DBus.Sasl" $ "C: " ++ show (BS.toLazyByteString bs)+ BS.hPutBuilder h bs)+ (do+ bs <- BS.hGetLine h+ debugM "DBus.Sasl" $ "S: " ++ show bs+ return bs)+ external+ serialCounter <- newTVarIO 1+ let getSerial = do+ s <- readTVar serialCounter+ writeTVar serialCounter (s+1)+ return s+ lock <- newTMVarIO $ BS.hPutBuilder h+ answerSlots <- newTVarIO (Map.empty :: AnswerSlots)+ aliveRef <- newTVarIO True+ weakAliveRef <- mkWeakPtr aliveRef Nothing+ let kill = do+ mbRef <- deRefWeak weakAliveRef+ case mbRef of+ Nothing -> return ()+ Just ref -> atomically $ writeTVar ref False+ hClose h+ slots <- atomically $ do sls <- readTVar answerSlots+ writeTVar answerSlots Map.empty+ return sls+ atomically $ forM_ (Map.elems slots) $ \s -> s . Left $+ [DBV $ DBVString "Connection Closed"]+ mfix $ \conn' -> do+ debugM "DBus" $ "Forking"+ handlerThread <- forkIO $ Ex.catch (do+ CB.sourceHandle h+ C.$= parseMessages+ C.$$ (C.awaitForever $ liftIO .+ handleMessage (handleCalls conn')+ (handleSignals conn')+ answerSlots))+ (\e -> print (e :: Ex.SomeException) >> kill >> Ex.throwIO e)+ addFinalizer aliveRef $ killThread handlerThread+ let conn = DBusConnection { dBusCreateSerial = getSerial+ , dBusAnswerSlots = answerSlots+ , dBusWriteLock = lock+ , dBusConnectionName = ""+ , connectionAliveRef = aliveRef+ }+ debugM "DBus" $ "hello"+ connName <- hello conn+ debugM "DBus" $ "Done"+ return conn{dBusConnectionName = connName}++type Handler = DBusConnection -> MessageHeader -> [SomeDBusValue] -> IO ()++sendCredentials :: Socket -> IO Int+#ifdef SEND_CREDENTIALS+foreign import ccall "send_credentials_and_zero"+ sendCredentialsAndZero :: CInt -> IO CInt++sendCredentials (MkSocket si _ _ _ _) = fromIntegral <$> sendCredentialsAndZero si+#else+sendCredentials s = send s "\0"+#endif
+ src/DBus/Message.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module DBus.Message where++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Reader+import qualified Data.Attoparsec.Char8 as AP8+import qualified Data.Binary.Get as B+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Builder as BS+import Data.Char+import qualified Data.Conduit as C+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Singletons+import qualified Data.Text as Text+import Data.Word+import System.Mem.Weak++import DBus.Error+import DBus.Representable+import DBus.TH+import DBus.Types+import DBus.Wire++data MessageType = Invalid+ | MethodCall+ | MethodReturn+ | Error+ | Signal+ | Other Word8+ deriving (Eq, Show)++instance Representable MessageType where+ type RepType MessageType = 'DBusSimpleType TypeByte+ toRep Invalid = DBVByte $ 0+ toRep MethodCall = DBVByte $ 1+ toRep MethodReturn = DBVByte $ 2+ toRep Error = DBVByte $ 3+ toRep Signal = DBVByte $ 4+ toRep (Other i) = DBVByte $ fromIntegral i+ fromRep (DBVByte 0) = Just $ Invalid+ fromRep (DBVByte 1) = Just $ MethodCall+ fromRep (DBVByte 2) = Just $ MethodReturn+ fromRep (DBVByte 3) = Just $ Error+ fromRep (DBVByte 4) = Just $ Signal+ fromRep (DBVByte i) = Just $ Other $ fromIntegral i++data Flag = NoReplyExpected+ | NoAutoStart+ deriving (Eq, Show)++newtype Flags = Flags [Flag]+ deriving (Show, Eq)++instance Representable Flags where+ 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 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+ toRep (Signature ts) = DBVSignature ts+ fromRep (DBVSignature ts) = Just $ Signature ts++data HeaderFields = HeaderFields { hFPath :: Maybe ObjectPath+ , hFInterface :: Maybe Text.Text+ , hFMember :: Maybe Text.Text+ , hFErrorName :: Maybe Text.Text+ , hFReplySerial :: Maybe Word32+ , hFDestination :: Maybe Text.Text+ , hFSender :: Maybe Text.Text+ , hFMessageSignature :: Maybe Signature+ , hFUnixfds :: Maybe Word32+ } deriving (Show, Eq)++instance Representable HeaderFields where+ type RepType HeaderFields = RepType [HeaderField]+ toRep = toRep . toFields+ fromRep = fmap fromFields . fromRep++emptyHeaderFields :: HeaderFields+emptyHeaderFields = HeaderFields Nothing Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing++toFields :: HeaderFields -> [HeaderField]+toFields hfs = catMaybes+ [ HeaderFieldPath <$> hFPath hfs+ , HeaderFieldInterface <$> hFInterface hfs+ , HeaderFieldMember <$> hFMember hfs+ , HeaderFieldErrorName <$> hFErrorName hfs+ , HeaderFieldReplySerial <$> hFReplySerial hfs+ , HeaderFieldDestination <$> hFDestination hfs+ , HeaderFieldSender <$> hFSender hfs+ , HeaderFieldMessageSignature <$> hFMessageSignature hfs+ , HeaderFieldUnixFDs <$> hFUnixfds hfs+ ]++fromFields :: [HeaderField] -> HeaderFields+fromFields fs = foldr fromField emptyHeaderFields fs+ where+ fromField (HeaderFieldPath x) hf = hf{hFPath = Just x}+ fromField (HeaderFieldInterface x) hf = hf{hFInterface = Just x}+ fromField (HeaderFieldMember x) hf = hf{hFMember = Just x}+ fromField (HeaderFieldErrorName x) hf = hf{hFErrorName = Just x}+ fromField (HeaderFieldReplySerial x) hf = hf{hFReplySerial = Just x}+ fromField (HeaderFieldDestination x) hf = hf{hFDestination = Just x}+ 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++data HeaderField = HeaderFieldInvalid+ | HeaderFieldPath ObjectPath+ | HeaderFieldInterface Text.Text+ | HeaderFieldMember Text.Text+ | HeaderFieldErrorName Text.Text+ | HeaderFieldReplySerial Word32+ | HeaderFieldDestination Text.Text+ | HeaderFieldSender Text.Text+ | HeaderFieldMessageSignature Signature+ | HeaderFieldUnixFDs Word32+ deriving (Show, Eq)++makeRepresentable ''HeaderField++instance Representable Endian where+ 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+ 'l' -> Just Little+ 'b' -> Just Big+ _ -> Nothing++data MessageHeader =+ MessageHeader { endianessFlag :: Endian+ , messageType :: MessageType+ , flags :: Flags+ , version :: Word8+ , messageLength :: Word32+ , serial :: Word32+ , fields :: HeaderFields+ } deriving (Show, Eq)++makeRepresentable ''MessageHeader++methodCall :: Word32+ -> Text.Text+ -> ObjectPath+ -> Text.Text+ -> Text.Text+ -> [SomeDBusValue]+ -> [Flag]+ -> BS.Builder+methodCall sid dest path interface member args flags =+ let hFields = emptyHeaderFields{ hFPath = Just path+ , hFInterface = Just interface+ , hFMember = Just member+ , hFDestination = Just dest+ }+ header = MessageHeader+ { endianessFlag = Little+ , messageType = MethodCall+ , flags = Flags flags+ , version = 1+ , messageLength = 0+ , serial = sid+ , fields = hFields+ }+ in serializeMessage header args++methodReturn :: Word32+ -> Word32+ -> Text.Text+ -> [SomeDBusValue]+ -> BS.Builder+methodReturn sid rsid dest args =+ let hFields = emptyHeaderFields{ hFDestination = Just dest+ , hFReplySerial = Just rsid+ }+ header = MessageHeader+ { endianessFlag = Little+ , messageType = MethodReturn+ , flags = Flags []+ , version = 1+ , messageLength = 0+ , serial = sid+ , fields = hFields+ }+ in serializeMessage header args++errorMessage :: Word32+ -> Maybe Word32+ -> Text.Text+ -> Text.Text+ -> Maybe Text.Text+ -> [SomeDBusValue]+ -> BS.Builder+errorMessage sid rsid dest name text args =+ let hFields = emptyHeaderFields{ hFDestination = Just dest+ , hFErrorName = Just name+ , hFReplySerial = rsid+ }+ header = MessageHeader+ { endianessFlag = Little+ , messageType = Error+ , flags = Flags []+ , version = 1+ , messageLength = 0+ , serial = sid+ , fields = hFields+ }+ in serializeMessage header (maybe id (\t -> (DBV (DBVString t) :))+ text args)+++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}+ }+ in runDBusPut Little $ do+ l <- sizeOf 0 1 vs+ putDBV . toRep $ header (fromIntegral l)+ alignPut 8+ vs++getMessage = do+ mbEndian <- fromRep <$> (B.lookAhead $ runReaderT getDBV Little)+ endian <- case mbEndian of+ Nothing -> fail "could not read endiannes flag"+ Just e -> return e+ flip runReaderT endian $ do+ mbHeader <- fromRep <$> getDBV+ header <- case mbHeader of+ Nothing -> fail "Header has wrong type"+ Just h -> return h+ alignGet 8+ args <- case hFMessageSignature $ fields header of+ Nothing -> return []+ Just (Signature sigs) -> forM sigs $ \t ->+ getDBVByType t+ return (header, args)++parseMessages :: C.MonadThrow m =>+ C.ConduitM BS.ByteString (MessageHeader, [SomeDBusValue]) m b+parseMessages = forever $ C.yield =<< sinkGet getMessage++sendBS conn bs = do+ write <- atomically . takeTMVar $ dBusWriteLock conn+ write bs+ atomically $ putTMVar (dBusWriteLock conn) write+++-- | Asychronously call a method. Returns an STM action that waits for the+-- returned value.+callMethod :: Text.Text -- ^ Entity to send the message to+ -> ObjectPath -- ^ Object+ -> Text.Text -- ^ Interface+ -> Text.Text -- ^ Member (method) name+ -> [SomeDBusValue] -- ^ Arguments+ -> [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+ ref <- newEmptyTMVarIO+ rSlot <- newTVarIO ()+ mkWeak rSlot (connectionAliveRef conn) Nothing+ addFinalizer rSlot (finalizeSlot serial)+ slot <- atomically $ do+ modifyTVar (dBusAnswerSlots conn) (Map.insert serial $ putTMVar ref)+ return ref+ let bs = methodCall serial dest path interface member args flags+ sendBS conn bs+ return $ readTMVar slot <* readTVar rSlot+ where+ finalizeSlot s = do+ atomically $ modifyTVar (dBusAnswerSlots conn)+ (Map.delete s)++-- | Wait for the answer of a method call+getAnswer :: IO (STM b) -> IO b+getAnswer = (atomically =<<)++-- | 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) =>+ Text.Text -- ^ Entity to send the message to+ -> ObjectPath -- ^ Object+ -> Text.Text -- ^ Interface+ -> Text.Text -- ^ Member (method) to call+ -> [SomeDBusValue] -- ^ Arguments+ -> [Flag] -- ^ Method call flags+ -> DBusConnection -- ^ Connection to send the call over+ -> m a+callMethod' dest path interface member args flags conn = do+ ret <- liftIO . getAnswer+ $ callMethod dest path interface member args flags conn+ case ret of+ Left e -> C.monadThrow $ MethodErrorMessage e+ Right r -> case fromRep =<< dbusValue r of+ Nothing -> C.monadThrow $ MethodSignatureMissmatch r+ Just x -> return x
+ src/DBus/MessageBus.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+module DBus.MessageBus where++import Control.Monad.Trans (MonadIO)+import DBus.Message+import DBus.Object+import DBus.Types+import Data.Conduit (MonadThrow, monadThrow)+import Data.Default+import Data.Singletons+import qualified Data.Text as Text+import Data.Word++import DBus.Error++messageBusMethod :: ( MonadIO m+ , MonadThrow m+ , Representable a+ , SingI (RepType a)+ ) =>+ Text.Text+ -> [SomeDBusValue]+ -> DBusConnection+ -> m a+messageBusMethod name args = callMethod' "org.freedesktop.DBus"+ (objectPath "/org/freedesktop/DBus")+ "org.freedesktop.DBus" name args []++hello :: (MonadIO m, MonadThrow m) => DBusConnection -> m Text.Text+hello = messageBusMethod "Hello" []++data RequestNameFlag = RequestNameFlag { allowReplacement+ , replaceExisting+ , doNotQueue :: Bool+ }++instance Default RequestNameFlag where+ def = RequestNameFlag False False False++fromRequestNameFlags flags = sum [ fromFlag allowReplacement 0x01+ , fromFlag replaceExisting 0x02+ , fromFlag doNotQueue 0x04+ ]+ where+ fromFlag x n = if x flags then n else 0++data RequestNameReply = PrimaryOwner+ | InQueue+ | Exists+ | AlreadyOwner++requestName :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> RequestNameFlag+ -> DBusConnection+ -> m RequestNameReply+requestName name flags con = do+ reply <- messageBusMethod "RequestName" [ DBV $ DBVString name+ , DBV . DBVUInt32 $+ fromRequestNameFlags flags]+ con+ case reply :: Word32 of+ 1 -> return PrimaryOwner+ 2 -> return InQueue+ 3 -> return Exists+ 4 -> return AlreadyOwner+ e -> monadThrow . MarshalError $ "Not a ReqeustName reply: " ++ show e++data ReleaseNameReply = Released+ | NonExistent+ | NotOwner++releaseName :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m ReleaseNameReply+releaseName name con = do+ reply <- messageBusMethod "RequestName" [DBV $ DBVString name] con+ case reply :: Word32 of+ 1 -> return Released+ 2 -> return NonExistent+ 3 -> return NotOwner+ e -> monadThrow . MarshalError $ "Not a ReleaseName reply: " ++ show e++listQueuedOwners :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m [Text.Text]+listQueuedOwners name = messageBusMethod "ListQueuedOwners" [DBV $ DBVString name]+++listNames :: (MonadIO m, MonadThrow m) => DBusConnection -> m [Text.Text]+listNames = messageBusMethod "ListNames" []++listActivatableNames :: (MonadIO m, MonadThrow m) =>+ DBusConnection+ -> m [Text.Text]+listActivatableNames = messageBusMethod "ListActivatableNames" []++nameHasOwner :: (MonadIO m, MonadThrow m) => Text.Text -> DBusConnection -> m Bool+nameHasOwner name = messageBusMethod "NameHasOwner" [DBV $ toRep name]++data StartServiceResult = StartServiceSuccess+ | StartServiceAlreadyRunning+ deriving (Show, Read, Eq)++startServiceByName :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m StartServiceResult+startServiceByName name con = do+ res <- messageBusMethod "StartServiceByName"+ [DBV $ toRep name, DBV $ DBVUInt32 0]+ con+ return $ case (res :: Word32) of+ 1 -> StartServiceSuccess+ 2 -> StartServiceAlreadyRunning++getNameOwner :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m Text.Text+getNameOwner txt = messageBusMethod "GetNameOwner" [DBV $ DBVString txt]++getConnectionUnixUser :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m Word32+getConnectionUnixUser txt = messageBusMethod "GetConnectionUnixUser"+ [DBV $ DBVString txt]++getConnectionProcessID :: (MonadIO m, MonadThrow m) =>+ Text.Text+ -> DBusConnection+ -> m Word32+getConnectionProcessID txt = messageBusMethod "GetConnectionUnixProcessID"+ [DBV $ DBVString txt]++getID :: (MonadIO m, MonadThrow m) =>+ DBusConnection+ -> m Text.Text+getID = messageBusMethod "GetId" []
+ src/DBus/Object.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module DBus.Object where++import Control.Applicative ((<$>))+import Control.Monad+import Data.List (intercalate, find)+import Data.Maybe+import Data.Singletons+import Data.Singletons.List+import Data.Singletons.TH+import qualified Data.Text as Text++import DBus.Types++class IsMethod f where+ type ArgTypes f+ type ResultType f+ toMethod :: f -> MethodWrapper (ArgTypes f) (ResultType f)++instance SingI t => IsMethod (IO (DBusValue t)) where+ type ArgTypes (IO (DBusValue t)) = '[]+ type ResultType (IO (DBusValue t)) = t+ toMethod = MReturn++instance (IsMethod f, SingI t) => IsMethod (DBusValue t -> f) where+ type ArgTypes (DBusValue t -> f) = (t ': ArgTypes f)+ type ResultType (DBusValue t -> f) = ResultType f+ toMethod f = MAsk $ \x -> toMethod (f x)++class RepMethod f where+ type RepMethodArgs f :: [DBusType]+ type RepMethodValue f :: DBusType+ repMethod :: f -> MethodWrapper (RepMethodArgs f) (RepMethodValue f)++instance (Representable t, SingI (RepType t)) => RepMethod (IO t) where+ type RepMethodArgs (IO t) = '[]+ type RepMethodValue (IO t) = RepType t+ repMethod f = MReturn $ toRep `liftM` f++instance (RepMethod b, Representable a, SingI (RepType a) )+ => RepMethod (a -> b) where+ type RepMethodArgs (a -> b) = (RepType a ': RepMethodArgs b)+ type RepMethodValue (a -> b) = RepMethodValue b+ repMethod f = MAsk $ \x -> case fromRep x of+ Nothing -> error "marshalling error" -- TODO+ Just x -> repMethod $ f x++runMethodW :: SingI at =>+ MethodWrapper at rt+ -> [SomeDBusValue]+ -> Maybe (IO (DBusValue rt))+runMethodW m args = runMethodW' sing args m++runMethodW' :: Sing at+ -> [SomeDBusValue]+ -> MethodWrapper at rt+ -> Maybe (IO (DBusValue rt))+runMethodW' SNil [] (MReturn f) = Just f+runMethodW' (SCons t ts) (arg:args) (MAsk f) = (runMethodW' ts args . f )+ =<< dbusValue arg+runMethodW' _ _ _ = Nothing++methodWSignature :: (SingI at, SingI rt) =>+ MethodWrapper (at :: [DBusType]) (rt :: DBusType)+ -> ([DBusType], Maybe DBusType)+methodWSignature (_ :: MethodWrapper at rt) = ( fromSing (sing :: Sing at)+ , case fromSing (sing :: Sing rt) of+ TypeUnit -> Nothing+ t -> Just t)+++runMethod :: Method -> [SomeDBusValue] -> Maybe (IO SomeDBusValue)+runMethod (Method m _ _) args = liftM DBV <$> runMethodW m args++methodSignature :: Method -> ([DBusType], Maybe DBusType)+methodSignature (Method m _ _) = methodWSignature m++methodName :: Method -> Text.Text+methodName (Method _ n _) = n++argDescriptions :: MethodDescription t -> ([Text.Text], Text.Text)+argDescriptions (Result t) = ([], t)+argDescriptions (t :-> ts) = let (ts', r) = argDescriptions ts in (t : ts', r)++instance Show Method where+ show m@(Method _ n desc) =+ let (args, res) = argDescriptions desc+ (argst, rest) = methodSignature m+ components = zipWith (\name tp -> (Text.unpack name+ ++ ":"+ ++ ppType tp))+ (args ++ [res])+ (argst ++ [fromMaybe TypeUnit rest])+ in Text.unpack n ++ " :: " ++ intercalate " -> " components++instance Show Interface where+ show i = "Interface " ++ show (interfaceName i) ++ " [{"+ ++ intercalate "}, {" (map show $ interfaceMethods i) ++ "}]"++instance Show Object where+ show o = "Object " ++ show (objectPathToText $ objectObjectPath o) ++ " [("+ ++ intercalate "), (" (map show $ objectInterfaces o) ++ ")]"+++findObject :: ObjectPath -> Object -> Maybe Object+findObject path o = case stripObjectPrefix (objectObjectPath o) path of+ Nothing -> Nothing+ Just suff -> if isEmpty suff then Just o+ else listToMaybe . catMaybes $+ (findObject suff <$> objectSubObjects o)++callAtPath :: Object+ -> ObjectPath+ -> Text.Text+ -> Text.Text+ -> [SomeDBusValue]+ -> Either MsgError (IO SomeDBusValue)+callAtPath root path interface member args = case findObject path root of+ Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed"+ (Just . Text.pack $ "No such object "+ ++ show path)+ [])+ Just o -> case find ((== interface) . interfaceName) $ objectInterfaces o of+ Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed"+ (Just "No such interface")+ [])+ Just i -> case find ((== member) . methodName) $ interfaceMethods i of+ Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed"+ (Just "No such interface")+ [])+ Just m -> case runMethod m args of+ Nothing -> Left (MsgError "org.freedesktop.DBus.Error.InvalidArgs"+ (Just "Argument type missmatch")+ [])+ Just ret -> Right ret
+ src/DBus/Representable.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module DBus.Representable where++import DBus.Types+import DBus.TH++import Control.Applicative ((<$>), (<*>))+import Control.Monad+import Data.Int+import qualified Data.Map as Map+import Data.Singletons+import qualified Data.Text as Text+import Data.Word+import qualified Data.ByteString as BS++-- class Representable; see DBus.Types+forM [2..20] makeRepresentableTuple++instance Representable () where+ type RepType () = TypeUnit+ toRep _ = DBVUnit+ fromRep DBVUnit = Just ()++instance Representable Word8 where+ type RepType Word8 = 'DBusSimpleType TypeByte+ toRep x = DBVByte x+ fromRep (DBVByte x) = Just x++instance Representable Bool where+ type RepType Bool = 'DBusSimpleType TypeBoolean+ toRep x = DBVBool x+ fromRep (DBVBool x) = Just x++instance Representable Int16 where+ type RepType Int16 = 'DBusSimpleType TypeInt16+ toRep x = DBVInt16 x+ fromRep (DBVInt16 x) = Just x++instance Representable Word16 where+ type RepType Word16 = 'DBusSimpleType TypeUInt16+ toRep x = DBVUInt16 x+ fromRep (DBVUInt16 x) = Just x++instance Representable Int32 where+ type RepType Int32 = 'DBusSimpleType TypeInt32+ toRep x = DBVInt32 x+ fromRep (DBVInt32 x) = Just x++instance Representable Word32 where+ type RepType Word32 = 'DBusSimpleType TypeUInt32+ toRep x = DBVUInt32 x+ fromRep (DBVUInt32 x) = Just x++instance Representable Int64 where+ type RepType Int64 = 'DBusSimpleType TypeInt64+ toRep x = DBVInt64 x+ fromRep (DBVInt64 x) = Just x++instance Representable Word64 where+ type RepType Word64 = 'DBusSimpleType TypeUInt64+ toRep x = DBVUInt64 x+ fromRep (DBVUInt64 x) = Just x++instance Representable Double where+ 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+ toRep x = DBVString x+ fromRep (DBVString x) = Just x++instance Representable ObjectPath where+ type RepType ObjectPath = 'DBusSimpleType TypeObjectPath+ toRep x = DBVObjectPath x+ fromRep (DBVObjectPath x) = Just x++instance ( Representable a , SingI (RepType a))+ => Representable [a] where+ 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)+ toRep bs = DBVByteArray bs+ fromRep (DBVByteArray bs) = Just bs+ fromRep (DBVArray bs) = BS.pack <$> mapM fromRep bs++type family FromSimpleType (t :: DBusType) :: DBusSimpleType+type instance FromSimpleType ('DBusSimpleType k) = k++instance ( Ord k+ , Representable k+ , RepType k ~ 'DBusSimpleType r+ , Representable v )+ => Representable (Map.Map k v) where+ 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)++instance ( Representable l+ , Representable r+ , SingI (RepType l)+ , SingI (RepType r))+ => Representable (Either l r) where+ type RepType (Either l r) = TypeStruct '[ 'DBusSimpleType TypeBoolean+ , TypeVariant]+ toRep (Left l) = DBVStruct ( StructCons (DBVBool False) $+ StructSingleton (DBVVariant (toRep l)))+ toRep (Right r) = DBVStruct ( StructCons (DBVBool True) $+ StructSingleton (DBVVariant (toRep r)))+ fromRep (DBVStruct ((StructCons (DBVBool False)+ (StructSingleton r))))+ = Left <$> (fromRep =<< fromVariant r)+ fromRep (DBVStruct ((StructCons (DBVBool True)+ (StructSingleton r))))+ = Right <$> (fromRep =<< fromVariant r)
+ src/DBus/Signal.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+module DBus.Signal where++import Control.Applicative+import Control.Monad.Trans+import Data.Conduit (MonadThrow)+import qualified Data.List as List+import Data.Maybe+import Data.Monoid+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.Builder as TB++import DBus.Types+import DBus.Message+import DBus.MessageBus++data MatchRule = MatchRule { mrType :: Maybe MessageType+ , mrSender :: Maybe Text.Text+ , mrInterface :: Maybe Text.Text+ , mrMember :: Maybe Text.Text+ , mrPath :: Maybe (Bool, ObjectPath)+ , mrDestination :: Maybe Text.Text+ , mrArgs :: [(Int,Text.Text)]+ , mrArgPaths :: [(Int,Text.Text)]+ , mrArg0namespace :: Maybe Text.Text+ , mrEavesdrop :: Maybe Bool+ }++matchAll :: MatchRule+matchAll = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing+ [] [] Nothing Nothing++renderRule :: MatchRule -> Text.Text+renderRule mr = Text.concat . TextL.toChunks . TB.toLazyText .+ mconcat . List.intersperse (TB.singleton ',') $+ (catMaybes+ [ toRule "type" fromMessageType <$> mrType mr+ , toRule "sender" id <$> mrSender mr+ , toRule "interface" id <$> mrInterface mr+ , toRule "member" id <$> mrMember mr+ , (\(namespace, path) ->+ toRule ("path" <> if namespace then "_namespace" else mempty)+ objectPathToText path) <$> mrPath mr+ , toRule "destination" id <$> mrDestination mr+ , toRule "arg0namespace" id <$> mrArg0namespace mr+ , toRule "eavesdrop" boolToText <$> mrEavesdrop mr+ ])+ ++ ((\(i, v) -> toRule ("arg" <> num i) id v) <$> mrArgs mr)+ ++ ((\(i, v) -> toRule ("arg" <> num i <> "path") id v)+ <$> mrArgPaths mr)+ where+ toRule name toValue v = name+ <> "='"+ <> TB.fromText (toValue v)+ <> TB.singleton '\''+ boolToText True = "true"+ boolToText False = "false"+ fromMessageType MethodCall = "method_call"+ fromMessageType MethodReturn = "method_return"+ fromMessageType Signal = "signal"+ fromMessageType Error = "error"+ ft = TB.fromText+ num i = TB.fromText . Text.pack $ show i++-- | Match a Signal against a rule. The argN, argNPath and arg0namespace+-- parameter are ignored at the moment+matchSignal :: MessageHeader -> MatchRule -> Bool+matchSignal header rule =+ let fs = fields header+ in and $ catMaybes+ [ Just $ messageType header == Signal+ , (\x -> hFMember fs == Just x ) <$> mrMember rule+ , (\x -> hFInterface fs == Just x ) <$> mrInterface rule+ , (\(ns, x) -> case hFPath fs of+ Nothing -> False+ Just p -> if ns then isPathPrefix x p+ else x == p) <$> mrPath rule+ , (\x -> hFDestination fs == Just x) <$> mrDestination rule+ ]++addMatch :: (MonadIO m, MonadThrow m ) =>+ MatchRule+ -> DBusConnection+ -> m ()+addMatch rule = messageBusMethod "AddMatch" [DBV . DBVString $ renderRule rule]++removeMatch :: (MonadIO m, MonadThrow m ) =>+ MatchRule+ -> DBusConnection+ -> m ()+removeMatch rule = messageBusMethod "RemoveMatch"+ [DBV . DBVString $ renderRule rule]
+ src/DBus/Signature.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}+module DBus.Signature where++import Control.Applicative ((<$>))+import Control.Monad+import qualified Data.Attoparsec as AP+import qualified Data.Attoparsec.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 Data.Char+import qualified Data.IntMap as IMap+import Data.Monoid+import qualified Data.Text as Text++import DBus.Types++stToSignature :: DBusSimpleType -> Char+stToSignature TypeByte = 'y'+stToSignature TypeBoolean = 'b'+stToSignature TypeInt16 = 'n'+stToSignature TypeUInt16 = 'q'+stToSignature TypeInt32 = 'i'+stToSignature TypeUInt32 = 'u'+stToSignature TypeInt64 = 'x'+stToSignature TypeUInt64 = 't'+stToSignature TypeDouble = 'd'+stToSignature TypeUnixFD = 'h'+stToSignature TypeString = 's'+stToSignature TypeObjectPath = 'o'+stToSignature TypeSignature = 'g'++toSignature :: DBusType -> BS.ByteString+toSignature = BS.concat . BSL.toChunks . BS.toLazyByteString . toSignature'++toSignatures :: [DBusType] -> BS.ByteString+toSignatures = BS.concat . BSL.toChunks . BS.toLazyByteString . mconcat . map toSignature'++toSignature' :: DBusType -> BS.Builder+toSignature' (DBusSimpleType t) = BS.char8 $ stToSignature t+toSignature' (TypeArray t) = BS.char8 'a' <> toSignature' t+toSignature' (TypeStruct ts) = BS.char8 '('+ <> mconcat (toSignature' <$> ts)+ <> BS.char8 ')'+toSignature' (TypeDict kt vt) = BS.string8 "a{"+ <> BS.char8 (stToSignature kt)+ <> toSignature' vt+ <> BS.char8 '}'+toSignature' TypeVariant = BS.char8 'v'++simpleTypeMap = IMap.fromList[ (ord 'y', TypeByte )+ , (ord 'b', TypeBoolean )+ , (ord 'n', TypeInt16 )+ , (ord 'q', TypeUInt16 )+ , (ord 'i', TypeInt32 )+ , (ord 'u', TypeUInt32 )+ , (ord 'x', TypeInt64 )+ , (ord 't', TypeUInt64 )+ , (ord 'd', TypeDouble )+ , (ord 'h', TypeUnixFD )+ , (ord 's', TypeString )+ , (ord 'o', TypeObjectPath )+ , (ord 'g', TypeSignature )+ ]++simpleType = do+ c <- AP.anyWord8+ case IMap.lookup (fromIntegral c) simpleTypeMap of+ Nothing -> fail "not a simple type"+ Just t -> return t++dictEntrySignature = do+ AP.char8 '{'+ kt <- simpleType+ vt <- signature+ AP.string "}"+ return $ TypeDictEntry kt vt+++arraySignature = do+ AP.char8 'a'+ ((do TypeDictEntry kt vt <- dictEntrySignature+ return $ TypeDict kt vt)+ <> (TypeArray <$> signature))++++structSignature = do+ AP.char '('+ TypeStruct <$> AP.manyTill signature (AP.char ')')+++signature = AP.choice [ AP.char 'v' >> return TypeVariant+ , arraySignature+ , structSignature+ , DBusSimpleType <$> simpleType+ ]++eitherParseSig :: BS.ByteString -> Either Text.Text DBusType+eitherParseSig s = case AP.parseOnly signature s of+ Left e -> Left $ Text.pack e+ Right r -> Right r++parseSig :: BS.ByteString -> Maybe DBusType+parseSig s = case eitherParseSig s of+ Left _ -> Nothing+ Right r -> Just r++eitherParseSigs :: BS.ByteString -> Either Text.Text [DBusType]+eitherParseSigs s = case AP.parseOnly (AP.many' signature) s of+ Left e -> Left $ Text.pack e+ Right r -> Right r++parseSigs :: BS.ByteString -> Maybe [DBusType]+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
@@ -0,0 +1,197 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module DBus.TH where++import Control.Applicative ((<$>), (<*>))+import Control.Monad+import DBus.Types+import Data.Singletons (SingI)+import Language.Haskell.TH++for :: Functor f => f a -> (a -> b) -> f b+for = flip fmap++litStruct :: [ExpQ] -> ExpQ+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)++litStructPat :: [PatQ] -> PatQ+litStructPat xs = foldr cons (sing $ last xs) $ init xs+ where+ sing ps = conP 'StructSingleton [ps]+ cons p ps = conP 'StructCons [p, ps]++caseMaybes :: [(Name, Name)] -> ExpQ -> ExpQ+caseMaybes [] e = e+caseMaybes ((tmp,x):xs) e =+ caseE (appE (varE 'fromRep) (varE tmp))+ [ match (conP 'Nothing []) (normalB $ conE 'Nothing) []+ , match (conP 'Just [varP x]) (normalB $ caseMaybes xs e) []+ ]++fromTyVarBndr (PlainTV n) = VarT n+fromTyVarBndr (KindedTV n k) = VarT n++fromConstr :: Con -> (Name, [Type])+fromConstr (NormalC n stps) = (n, map snd stps)+fromConstr (RecC n vstps) = (n, map (\(_,_,t) -> t) vstps)++tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV n) = n+tyVarName (KindedTV n _k) = n++promotedListT :: [TypeQ] -> TypeQ+promotedListT xs = foldr appT promotedNilT (map (appT promotedConsT)xs)++relevantTyVars :: [Con] -> [Name]+relevantTyVars constrs = concatMap tyVars constrs+ where+ tyVars constr = concatMap tyVar . snd $ fromConstr constr+ tyVar (VarT n) = [n]+ tyVar _ = []++makeRepresentable name = do+ TyConI t <- reify name+ let (numTyParams, tyVarNames, cons) = case t of+ NewtypeD _ _ tvs c _ -> (length tvs, tyVarName <$> tvs, [c])+ DataD _ _ tvs cs _ -> (length tvs, tyVarName <$> tvs, cs)+ ctx1 = mapM (classP ''SingI . (:[]) . appT (conT ''RepType)) (varT <$> (relevantTyVars cons))+ ctx2 = mapM (classP ''Representable . (:[])) (varT <$> relevantTyVars cons)+ ctx = liftM2 (++) ctx1 ctx2+ fullType = (foldl appT (conT name) (varT <$> tyVarNames))+ iHead = appT (conT ''Representable) fullType+ cs = map fromConstr cons+ (repType, toClauses, fromClauses) <- case all (null . snd) cs of+ 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+ [(conName, fields)] -> oneCon conName fields+ cs -> multiCon cs+ inst <- instanceD ctx iHead+ [ tySynInstD ''RepType [fullType] repType+ , funD 'toRep toClauses+ , funD 'fromRep fromClauses+ ]+ return [inst]+ where+ oneCon conName fieldTypes = do+ (repType+ , (toPat, toBD)+ , (fromPat, fromBD)) <- singleConstructor conName fieldTypes+ return ( repType+ , [clause [toPat] (normalB toBD) []]+ , [clause [fromPat] (normalB fromBD) []]+ )+ enumerate conNames+ = return ( [t| 'DBusSimpleType TypeByte |]+ , for (zip conNames [0..]) $ \(cn, i) ->+ (clause [conP cn []] (normalB . appE (conE 'DBVByte)+ . litE $ integerL i) [])+ , (for (zip conNames [0..]) $ \(cn, i) ->+ (clause [(conP 'DBVByte) . (:[]) . litP $ integerL i] (normalB $ appE (conE 'Just)+ (conE cn)) []))+ ++ [clause [wildP] (normalB $ conE 'Nothing) []]+ )+ multiCon :: [(Name, [Type])] -> Q (TypeQ, [ClauseQ], [ClauseQ])+ multiCon cs = do+ clauses <- forM (zip [0..] cs) $ \(branch, (conName, ts)) -> do+ ( repType+ , (toPat, toBD)+ , (fromPat', fromBD')) <- singleConstructor conName ts+ let bd = appE (conE 'DBVStruct) $+ litStruct [ (appE (conE 'DBVByte) .+ litE $ integerL branch)+ , appE (conE 'DBVVariant) toBD]+ varName <- newName "x"+ let fromPat = conP 'DBVStruct [+ litStructPat [ conP 'DBVByte [litP $ integerL branch]+ , varP varName+ ]]+ fromBD = caseE [|fromVariant $(varE varName) :: Maybe (DBusValue $repType) |]+ [ match (conP 'Nothing [])+ (normalB $ conE 'Nothing) []+ , match (conP 'Just [fromPat'])+ (normalB $ fromBD') []+ ]++ return $ ( clause [toPat] (normalB bd) []+ , clause [fromPat] (normalB fromBD) []+ )++ return ( [t| TypeStruct '[ 'DBusSimpleType TypeByte, TypeVariant] |]+ , map fst clauses+ , map snd clauses+ )+ singleConstructor conName [] = do+ var <- newName "x"+ return $ ( [t| 'DBusSimpleType TypeByte |]+ , ( conP conName []+ , [| DBVByte 0|]+ )+ , ( [p| DBVByte _ |]+ , [| Just $(conE conName)|]+ )+ )+ singleConstructor conName [t] = do+ var <- newName "x"+ return $ ( [t| RepType $(return t) |]+ , ( conP conName [varP var]+ , [| toRep $(varE var)|]+ )+ , ( varP var+ , [| $(conE conName) <$>fromRep $(varE var)|]+ )+ )++ singleConstructor conName ts = do+ (varNames, tmpNames) <- unzip <$> (forM ts $ \_ -> (,) <$> (newName "x")+ <*> (newName "mbx"))++ return ( appT (promotedT 'TypeStruct) . promotedListT $+ (map (appT (conT ''RepType) . return) ts)+ , let+ pats = conP conName (map varP varNames)+ bs = (appE (conE 'DBVStruct)+ (litStruct $ map (appE (varE 'toRep) . varE) varNames))+ in (pats, bs)+ , let+ pats = conP 'DBVStruct [litStructPat $ varP <$> tmpNames]+ bs = (caseMaybes (zip tmpNames varNames)+ (appE (conE 'Just)+ $ foldl appE (conE conName) (varE <$> varNames)))+ in (pats, bs)+ )++-- TODO: Fold into makeRepresentable+makeRepresentableTuple :: Int -> Q Dec+makeRepresentableTuple num = do+ let names = take num $ map (varT . mkName . (:[])) ['a' .. 'z']+ ctx = sequence $ classP ''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+ [ tySynInstD ''RepType [tp] (appT (promotedT 'TypeStruct) tpList)+ , funD ('toRep) $ let+ pats = [tupP (map varP varNames)]+ bs = normalB (appE (conE 'DBVStruct)+ (litStruct $ map (appE (varE 'toRep) . varE) varNames))+ in [clause pats bs []]+ , funD ('fromRep) $ let+ pats = [conP 'DBVStruct [litStructPat $ varP <$> tmpNames]]+ bs = normalB (caseMaybes (zip tmpNames varNames)+ (appE (conE 'Just)+ $ tupE (varE <$> varNames)))+ in [clause pats bs []]+ ]
+ src/DBus/Transport.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+module DBus.Transport where++import Control.Applicative ((<$>))+import Control.Concurrent+import qualified Control.Exception as Ex+import Control.Monad+import Data.Attoparsec as AP+import Data.Attoparsec.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++data UDS = UDSPath BS.ByteString+ | UDSTmpDir BS.ByteString+ | UDSAbstract BS.ByteString+ deriving (Show, Eq)++data TCPFamily = TCPFamilyIPv4+ | TCPFamilyIPv6+ deriving (Show, Eq)++data TCP = TCP { tcpHost :: Maybe BS.ByteString+ , tcpBind :: Maybe BS.ByteString+ , tcpPort :: Maybe Word16+ , tcpFamily :: Maybe TCPFamily+ } deriving (Show, Eq)++data TransportType = TransportTCP TCP+ | TransportUnix UDS+ | OtherTransport BS.ByteString [(BS.ByteString, BS.ByteString)]+ deriving (Eq, Show)+++type GUID = BS.ByteString++withProtocol :: AP.Parser t+ -> ((t, [(BS.ByteString, BS.ByteString)]) -> AP.Parser a)+ -> AP.Parser (Maybe ((Maybe BS.ByteString), a))+withProtocol nameParser f = do+ name <- nameParser+ ((fmap Just $ do+ 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"+ Right r -> return $ Just r+ ret <- f (name, List.filter ((/= "guid").fst) pairs)+ return (mbGuid, ret)+ ) `mplus` (return Nothing))++parsePair :: AP.Parser (BS.ByteString, BS.ByteString)+parsePair = do+ key <- AP8.takeWhile1 (\c -> AP8.isAlpha_ascii c || (c >= '0' && c <= '9'))+ AP8.char8 '='+ value <- BS.pack <$> AP.many1' valueChar+ return (key, value)+ where+ valueChar = choice [ AP.satisfy $ AP.inClass "0-9A-Za-z_/.\\-"+ , AP8.char '%' >> parseHexChar+ ]++parseUnix = withProtocol (AP.string "unix") $ \ (_, pairs) -> TransportUnix <$>+ case pairs of+ [("path", p)] -> return $ UDSPath p+ [("tmpdir", p)] -> return $ UDSTmpDir p+ [("abstract", p)] -> return $ UDSAbstract p+ _ -> fail "unix path expects exactly one of path, tmpdir or abstract"++parseTCP :: AP.Parser (Maybe (Maybe GUID, TransportType))+parseTCP = withProtocol (AP.string "tcp") $ \(_, pairs) -> TransportTCP <$>+ foldM addValue (TCP Nothing Nothing Nothing Nothing) pairs+ where+ addValue tcp ("host" , x) = return $ tcp{tcpHost = Just x}+ addValue tcp ("bind" , x) = return $ tcp{tcpBind = Just x}+ addValue tcp ("port" , x) = case reads (BS8.unpack x) of+ [(p, "")] -> return tcp{tcpPort = Just p}+ _ -> fail "could not read port"+ addValue tcp ("family" , x) = case x of+ "ipv4" -> return $ tcp{tcpFamily = Just TCPFamilyIPv4}+ "ipv6" -> return $ tcp{tcpFamily = Just TCPFamilyIPv6}+ _ -> fail "unknown family"+ addValue _ _ = fail "unknown key"++parseOtherTransport :: AP.Parser (Maybe (Maybe GUID, TransportType))+parseOtherTransport =+ withProtocol (AP.takeWhile1 $ AP.inClass "a-zA-Z0-9-")+ $ \(name, pairs) -> return $ OtherTransport name pairs++parseMaybe Nothing = mzero+parseMaybe (Just x) = return x++parseTransport :: Parser (Maybe GUID, TransportType)+parseTransport = AP.choice [ parseMaybe =<< parseTCP+ , parseMaybe =<< parseUnix+ , parseMaybe =<< parseOtherTransport+ ]++parseTransports :: AP.Parser [(Maybe GUID, TransportType)]+parseTransports = parseTransport `AP.sepBy` AP8.char8 ';'++connectTcp :: TCP -> IO Socket+connectTcp tcp | Just host <- tcpHost tcp+ , Just port <- tcpPort tcp+ , port > 0+ = do+ let family = case tcpFamily tcp of+ Nothing -> AF_UNSPEC+ Just TCPFamilyIPv4 -> AF_INET+ Just TCPFamilyIPv6 -> AF_INET6+ addrInfo <- getAddrInfo (Just $ defaultHints{ addrFamily = family} )+ (Just . Text.unpack . Text.decodeUtf8 $ host)+ Nothing+ case addrInfo of+ (ai : _) -> Ex.catch+ (Ex.bracketOnError (socket (addrFamily ai)+ (addrSocketType ai)+ (addrProtocol ai))+ close+ $ \s -> do+ connect s $ addrAddress ai+ return s+ )+ (\(e :: Ex.SomeException) ->+ Ex.throwIO $ CouldNotConnect "Could not connect")++ _ -> Ex.throwIO $ CouldNotConnect "Host not found"+connectTcp _ = Ex.throwIO $ CouldNotConnect "TCP method does not specify necessary data"++connectUnix :: UDS -> IO Socket+connectUnix unix = do+ s <- socket AF_UNIX Stream defaultProtocol+ addr <- case unix of+ UDSPath p -> return . SockAddrUnix . Text.unpack $ Text.decodeUtf8 p+ UDSAbstract p -> return . SockAddrUnix . ('\0':)+ . Text.unpack $ Text.decodeUtf8 p+ UDSTmpDir _ -> Ex.throwIO $ CouldNotConnect "Can not connecto to Tmp dir"+ Ex.catch (connect s addr)+ (\(e:: Ex.SomeException) ->+ Ex.throwIO . CouldNotConnect $ "Error connecting to Unix Socket: "+ ++ show e)+ return s++connectTransport (TransportTCP tcp) = connectTcp tcp+connectTransport (TransportUnix unix) = connectUnix unix+connectTransport (OtherTransport name _) = Ex.throwIO . CouldNotConnect $+ "Transport method " ++ show name+ ++ "not implemented"++connectString :: String -> IO (Maybe Socket)+connectString s = case AP.parseOnly parseTransports+ (Text.encodeUtf8 . Text.pack $ s) of+ Left e -> return $ Nothing+ Right transports -> go transports+ where+ go ((_, t) : ts) = do+ mbS <- Ex.try $ connectTransport t+ case mbS of+ Left (e :: DBusError) -> print e >> go ts+ Right s -> return $ Just s+ go [] = return Nothing
+ src/DBus/Types.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module DBus.Types where++import Control.Applicative ((<$>), (<*>))+import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as Ex+import Control.Monad+import Control.Monad.Trans.Error+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Builder as BS+import Data.Data(Data)+import Data.Function (fix, on)+import Data.Int+import Data.List+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 qualified Data.Text as Text+import Data.Typeable(Typeable)+import Data.Word+import Unsafe.Coerce (unsafeCoerce)++-- import qualified DBus.Connection as DBus+-- import qualified DBus.Message as DBus+++data ObjectPath = ObjectPath { opAbsolute :: Bool+ , opParts :: [Text.Text]+ } deriving (Eq, Data, Typeable)++++newtype Signature = Signature {fromSignature :: [DBusType]}+ deriving (Show, Eq)++-- | Parse an object path. Contrary to the standard, empty path parts are ignored+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 "")+ `Text.append` Text.intercalate "/" parts++instance Show ObjectPath where+ show = Text.unpack . objectPathToText++stripObjectPrefix :: ObjectPath -> ObjectPath -> Maybe ObjectPath+stripObjectPrefix (ObjectPath abs1 pre) (ObjectPath abs2 x) | abs1 == abs2+ = ObjectPath False <$> stripPrefix pre x+stripObjectPrefix _ _ = Nothing++isPathPrefix :: ObjectPath -> ObjectPath -> Bool+isPathPrefix p x = case stripObjectPrefix p x of+ Nothing -> False+ Just _ -> True++isRoot (ObjectPath True p) = null p+isRoot _ = False++isEmpty (ObjectPath False p) = null p+isEmpty _ = False++data DBusSimpleType+ = TypeByte+ | TypeBoolean+ | TypeInt16+ | TypeUInt16+ | TypeInt32+ | TypeUInt32+ | TypeInt64+ | TypeUInt64+ | TypeDouble+ | TypeUnixFD+ | TypeString+ | TypeObjectPath+ | TypeSignature+ deriving (Show, Read, Eq, Data, Typeable)++ppSimpleType :: DBusSimpleType -> String+ppSimpleType TypeByte = "Word8"+ppSimpleType TypeBoolean = "Boolean"+ppSimpleType TypeInt16 = "Int16"+ppSimpleType TypeUInt16 = "UInt16"+ppSimpleType TypeInt32 = "Int32"+ppSimpleType TypeUInt32 = "UInt32"+ppSimpleType TypeInt64 = "Int64"+ppSimpleType TypeUInt64 = "UInt64"+ppSimpleType TypeDouble = "Double"+ppSimpleType TypeUnixFD = "UnixFD"+ppSimpleType TypeString = "String"+ppSimpleType TypeObjectPath = "ObjectPath"+ppSimpleType TypeSignature = "Signature"++data DBusType+ = DBusSimpleType DBusSimpleType+ | TypeArray DBusType+ | TypeStruct [DBusType]+ | TypeDict DBusSimpleType DBusType+ | TypeVariant+ | TypeDictEntry DBusSimpleType DBusType+ | TypeUnit -- TODO: Remove+ -- Unit isn't actually a DBus type. It is included+ -- to make it easier to use methods without a return value+ deriving (Show, Read, Eq, Data, Typeable)++ppType :: DBusType -> String+ppType (DBusSimpleType t) = ppSimpleType t+ppType (TypeArray ts) = "[" ++ ppType ts ++ "]"+ppType (TypeStruct ts) = "(" ++ intercalate "," (ppType <$> ts) ++ ")"+ppType (TypeDict k v) = "{" ++ ppSimpleType k ++ " => " ++ ppType v ++ "}"+ppType (TypeDictEntry k v) = "<" ++ ppSimpleType k ++ " => " ++ ppType v ++ ">"+ppType TypeVariant = "Variant"+ppType TypeUnit = "()"++data Parity = Null+ | Arg Parity+ deriving (Eq, Show, Data, Typeable)++type family ArgsOf x :: Parity+type instance ArgsOf (IO x) = 'Null+type instance ArgsOf (a -> b) = 'Arg (ArgsOf b)++infixr 0 :->+data MethodDescription parity where+ (:->) :: Text.Text -> MethodDescription n -> MethodDescription (Arg n)+ Result :: Text.Text -> MethodDescription Null++genSingletons [''DBusSimpleType, ''DBusType, ''Parity]+singEqInstances [''DBusSimpleType, ''DBusType, ''Parity]+-- singDecideInstances [''DBusSimpleType]++data DBusStruct :: [DBusType] -> * where+ StructSingleton :: DBusValue a -> DBusStruct '[a]+ StructCons :: DBusValue a -> DBusStruct as -> DBusStruct (a ': as)++instance Eq (DBusStruct t) where+ StructSingleton x == StructSingleton y = x == y+ StructCons x xs == StructCons y ys =+ x == y && xs == ys++data SomeDBusStruct where+ SDBS :: SingI ts => DBusStruct ts -> SomeDBusStruct++instance SingI a => Show (DBusStruct a) where+ show xs = showStruct sing xs++showStruct :: Sing a -> DBusStruct a -> String+showStruct (SCons t SNil) (StructSingleton x) =+ withSingI t $ "StructSingleton (" ++ show x ++ ")"+showStruct (SCons t ts ) (StructCons x xs) =+ withSingI t $ "StructCons (" ++ show x ++ ") (" ++ showStruct ts xs ++ ")"++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.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)+ -- TODO: Remove++ -- Unit isn't an actual DBus type and is included only for use with methods+ -- that don't return a value+ DBVUnit :: DBusValue TypeUnit+++instance Eq (DBusValue t) where+ DBVByte x == DBVByte y = x == y+ DBVBool x == DBVBool y = x == y+ DBVInt16 x == DBVInt16 y = x == y+ DBVUInt16 x == DBVUInt16 y = x == y+ DBVInt32 x == DBVInt32 y = x == y+ DBVUInt32 x == DBVUInt32 y = x == y+ DBVInt64 x == DBVInt64 y = x == y+ DBVUInt64 x == DBVUInt64 y = x == y+ DBVDouble x == DBVDouble y = x == y+ DBVUnixFD x == DBVUnixFD y = x == y+ DBVString x == DBVString y = x == y+ DBVObjectPath x == DBVObjectPath y = x == y+ DBVSignature x == DBVSignature y = x == y+ DBVVariant (x ::DBusValue s1) == DBVVariant (y ::DBusValue s2) =+ let xt = sing :: Sing s1+ yt = sing :: Sing s2+ in case xt %:== yt of -- Should be %~+ STrue -> (unsafeCoerce x :: DBusValue t) == (unsafeCoerce y)+ SFalse -> False++ DBVArray x == DBVArray y = x == y+ DBVByteArray x == DBVByteArray y = x == y+ DBVStruct x == DBVStruct y = x == y+ DBVDict x == DBVDict y = x == y+ 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+++-- TODO: Reinstate once https://github.com/goldfirere/singletons/issues/2 is+-- resolved++-- fromVariant :: SingI t => DBusValue TypeVariant -> Maybe (DBusValue t)+-- fromVariant (DBVVariant (v :: DBusValue s))+-- = fix $ \(_ :: Maybe (DBusValue t)) ->+-- let ss = (sing :: Sing s)+-- st = (sing :: Sing t)+-- in case (ss %~ st) of+-- Proved Refl -- Bring into scope a proof that s~t+-- -> Just v+-- Disproved _ -> Nothing++castDBV :: (SingI s, SingI t) => DBusValue s -> Maybe (DBusValue t)+castDBV (v :: DBusValue s)+ = fix $ \(_ :: Maybe (DBusValue t)) ->+ let ss = (sing :: Sing s)+ st = (sing :: Sing t)+ in case (ss %:== st) of+ STrue -> Just (unsafeCoerce v)+ SFalse -> Nothing++data SomeDBusValue where+ DBV :: SingI t => DBusValue t -> SomeDBusValue++instance Show SomeDBusValue where+ show (DBV x) = "DBV<"++ ppType (typeOf x) ++ "> (" ++ show x ++ ")"++dbusValue :: SingI t => SomeDBusValue -> Maybe (DBusValue t)+dbusValue (DBV v) = castDBV v++dbusSValue :: SingI t => SomeDBusValue -> Maybe (DBusValue ('DBusSimpleType t))+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 (DBVVariant v) = castDBV v++instance SingI t => Show (DBusValue t) where+ show (DBVByte x) = "DBVByte " ++ show x+ show (DBVBool x) = "DBVBool " ++ show x+ show (DBVInt16 x) = "DBVInt16 " ++ show x+ show (DBVUInt16 x) = "DBVUInt16 " ++ show x+ show (DBVInt32 x) = "DBVInt32 " ++ show x+ show (DBVUInt32 x) = "DBVUInt32 " ++ show x+ show (DBVInt64 x) = "DBVInt64 " ++ show x+ show (DBVUInt64 x) = "DBVUInt64 " ++ show x+ show (DBVDouble x) = "DBVDouble " ++ show x+ show (DBVUnixFD x) = "DBVUnixFD " ++ show x+ show (DBVString x) = "DBVString " ++ show x+ show (DBVObjectPath x) = "objectPath " ++ show (show x)+ show (DBVSignature x) = "DBVSignature " ++ show x+ show y@(DBVArray x :: DBusValue t) = case (sing :: Sing t) of+ STypeArray t -> withSingI t $+ "DBVArray " ++ show x +++ if null x+ then " :: DBusValue (" ++ (show $ typeOf y ) ++ ")"+ else ""+++ show y@(DBVByteArray x) = "DBVByteArray " ++ show x+ show y@(DBVStruct x :: DBusValue t) = case (sing :: Sing t) of+ STypeStruct ts -> withSingI ts $+ "DBVStruct (" ++ show x ++ ")"+ show y@(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"++typeOf :: SingI t => DBusValue t -> DBusType+typeOf (_ :: DBusValue a) = fromSing (sing :: SDBusType a)++class Representable a where+ type RepType a :: DBusType+ toRep :: a -> DBusValue (RepType a)+ fromRep :: DBusValue (RepType a) -> Maybe a++------------------------------------------------+-- Objects+------------------------------------------------+data MethodWrapper av rv where+ MReturn :: SingI t => IO (DBusValue t) -> MethodWrapper '[] t+ MAsk :: SingI t => (DBusValue t -> MethodWrapper avs rv )+ -> MethodWrapper (t ': avs) rv++type family ArgParity (x :: [DBusType]) :: Parity+type instance ArgParity '[] = 'Null+type instance ArgParity (x ': xs) = Arg (ArgParity xs)++data Method where+ Method :: (SingI avs, SingI t) =>+ MethodWrapper avs t+ -> Text.Text+ -> MethodDescription (ArgParity avs)+ -> Method+++data Annotation = Annotation { annotationName :: Text.Text+ , annotationValue :: Text.Text+ } deriving (Eq, Show, Data, Typeable)++data Interface = Interface { interfaceName :: Text.Text+ , interfaceMethods :: [Method]+ , interfaceAnnotations :: [Annotation]+ }++instance Eq Interface where+ (==) = (==) `on` interfaceName++data Object = Object { objectObjectPath :: ObjectPath+ , objectInterfaces :: [Interface]+ , objectSubObjects :: [Object]+ }++--------------------------------------------------+-- Connection and Message+--------------------------------------------------++data MsgError = MsgError { errorName :: Text.Text+ , errorText :: Maybe Text.Text+ , errorBody :: [SomeDBusValue]+ } deriving (Show, Typeable)++instance Ex.Exception MsgError++instance Error MsgError where+ strMsg str = MsgError { errorName = "org.freedesktop.DBus.Error.Failed"+ , errorText = Just (Text.pack str)+ , errorBody = []+ }+ noMsg = MsgError { errorName = "org.freedesktop.DBus.Error.Failed"+ , errorText = Nothing+ , errorBody = []+ }+++data Connection = Connection { primConnection :: () -- DBus.Connection+ , answerSlots :: TVar (Map.Map Word32+ (TMVar (Either MsgError+ SomeDBusValue)))+ , mainLoop :: ThreadId+ }++data MethodError = MethodErrorMessage [SomeDBusValue]+ | MethodSignatureMissmatch SomeDBusValue+ deriving (Show, Typeable)++instance Ex.Exception MethodError++type Serial = Word32+type Slot = Either [SomeDBusValue] SomeDBusValue -> STM ()+type AnswerSlots = Map.Map Serial Slot++data DBusConnection =+ DBusConnection+ { dBusCreateSerial :: STM Serial+ , dBusAnswerSlots :: TVar AnswerSlots+ , dBusWriteLock :: TMVar (BS.Builder -> IO ())+ , dBusConnectionName :: Text.Text+ , connectionAliveRef :: TVar Bool+ }
+ src/DBus/Wire.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module DBus.Wire where+++import Control.Applicative ((<$>), (<*>))+import Control.Monad+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.ByteString.Lazy.Builder as BS+import Data.Int+import Data.Singletons+import Data.Singletons.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+import DBus.Error+++fromEnum' :: (Enum a, Num c) => a -> c+fromEnum' = fromIntegral . fromEnum++toEnum' :: (Enum c, Integral a) => a -> c+toEnum' = toEnum . fromIntegral++alignment :: DBusType -> Int+alignment (DBusSimpleType TypeByte ) = 1+alignment (DBusSimpleType TypeBoolean ) = 4+alignment (DBusSimpleType TypeInt16 ) = 2+alignment (DBusSimpleType TypeUInt16 ) = 2+alignment (DBusSimpleType TypeInt32 ) = 4+alignment (DBusSimpleType TypeUInt32 ) = 4+alignment (DBusSimpleType TypeInt64 ) = 8+alignment (DBusSimpleType TypeUInt64 ) = 8+alignment (DBusSimpleType TypeDouble ) = 8+alignment (DBusSimpleType TypeUnixFD ) = 4+alignment (DBusSimpleType TypeString ) = 4+alignment (DBusSimpleType TypeObjectPath) = 4+alignment (DBusSimpleType TypeSignature) = 1+alignment TypeVariant = 1+alignment (TypeArray _) = 4+alignment (TypeStruct _) = 8+alignment (TypeDict _ _) = 8+++data Endian = Little | Big+ deriving (Show, Eq, Enum, Bounded)++type DBusPut a = RWS Endian BS.Builder Int a++endian :: (a -> BS.Builder)+ -> (a -> BS.Builder)+ -> a+ -> DBusPut ()+endian l b x = do+ e <- ask+ tell $ case e of+ Little -> l x+ Big -> b x++putSize :: MonadState Int m => Int -> m ()+putSize i = modify (+i)++alignPut :: Int -> DBusPut ()+alignPut bytes = do+ s <- get+ let align = ((-s) `mod` bytes)+ replicateM align . tell $ BS.word8 0+ putSize align++sizeOf :: Int -> Int -> DBusPut a -> DBusPut Int+sizeOf offset al' x = do+ let al = if al' == 0 then 1 else al'+ offsetA = if offset == 0 then 1 else offset+ s <- ask+ here <- get+ let start = ((here `aligning` offsetA) + offset) `aligning` al+ return $ (fst (execRWS x s start)) - start+ where+ 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++putWord8 :: Word8 -> DBusPut ()+putWord8 x = (tell $ BS.word8 x) >> putSize 1++putWord16 :: Word16 -> DBusPut ()+putWord16 = bytes BS.word16LE BS.word16BE 2++putWord32 :: Word32 -> DBusPut ()+putWord32 = bytes BS.word32LE BS.word32BE 4++putWord64 :: Word64 -> DBusPut ()+putWord64 = bytes BS.word64LE BS.word64BE 8++putInt8 :: Int8 -> DBusPut ()+putInt8 = putWord8 . fromIntegral++putInt16 :: Int16 -> DBusPut ()+putInt16 = putWord16 . fromIntegral++putInt32 :: Int32 -> DBusPut ()+putInt32 = putWord32 . fromIntegral++putInt64 :: Int64 -> DBusPut ()+putInt64 = putWord64 . fromIntegral++putDouble :: Double -> DBusPut ()+putDouble = bytes BS.doubleLE BS.doubleBE 8++putByteString :: BS.ByteString -> DBusPut ()+putByteString x = do+ tell $ BS.byteString x+ putSize (BS.length x)++putText :: Text.Text -> DBusPut ()+putText t = do+ let bs = Text.encodeUtf8 t+ putWord32 . fromIntegral $ BS.length bs+ putByteString bs+ putWord8 0++putObjectPath :: ObjectPath -> DBusPut ()+putObjectPath o = putText $ objectPathToText o++putSignatures s = do+ let bs = toSignatures s+ len = BS.length bs+ when (len > 255) $ fail "Signature too long"+ putWord8 $ fromIntegral len+ putByteString bs+ putWord8 0++putDBV = putDBV' sing++putDBV' :: Sing t -> DBusValue t -> DBusPut ()+putDBV' _ (DBVByte x) = putWord8 x+putDBV' _ (DBVBool x) = putWord32 $ fromEnum' x+putDBV' _ (DBVInt16 x) = putInt16 x+putDBV' _ (DBVUInt16 x) = putWord16 x+putDBV' _ (DBVInt32 x) = putInt32 x+putDBV' _ (DBVUInt32 x) = putWord32 x+putDBV' _ (DBVInt64 x) = putInt64 x+putDBV' _ (DBVUInt64 x) = putWord64 x+putDBV' _ (DBVDouble x) = putDouble x+putDBV' _ (DBVUnixFD x) = putWord32 x+putDBV' _ (DBVString x) = putText x+putDBV' _ (DBVObjectPath x) = putObjectPath x+putDBV' _ (DBVSignature x) = putSignatures x+putDBV' _ (DBVVariant x) = do+ putSignatures [typeOf x]+ putDBV' sing x+putDBV' (STypeArray t) (DBVArray x) = do+ let content = mapM_ (putDBV' t) x+ let al = alignment $ fromSing t+ size <- sizeOf 4 al content+ putWord32 $ fromIntegral size+ s <- get+ alignPut al+ content+putDBV' _ (DBVByteArray x) = do+ putWord32 . fromIntegral $ BS.length x+ putByteString x+putDBV' (STypeStruct ts) (DBVStruct x) = do+ alignPut 8+ putStruct ts x+putDBV' (STypeDict kt vt) (DBVDict x) =+ let content = forM_ x $ \(k,v) -> do+ alignPut 8+ putDBV' (SDBusSimpleType kt) k+ putDBV' vt v+ in do+ putWord32 . fromIntegral =<< sizeOf 4 8 content+ alignPut 8+ content++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++runDBusPut :: Num s => r -> RWS r b s a -> b+runDBusPut e x = snd $ evalRWS x e 0++putValues :: [SomeDBusValue]+ -> DBusPut ()+putValues vs = mapM_ (\(DBV v) -> putDBV v) vs++-----------------------------------+-- Get+-----------------------------------++type DBusGet a = ReaderT Endian B.Get a++getEndian :: B.Get a -> B.Get a -> DBusGet a+getEndian l b = do+ e <- ask+ case e of+ Little -> lift $ l+ Big -> lift $ b++alignGet :: Int -> DBusGet ()+alignGet bytes = do+ s <- fromIntegral <$> lift B.bytesRead+ let align = ((-s) `mod` bytes)+ lift $ B.skip align++getting :: B.Get a -> B.Get a -> Int -> DBusGet a+getting l b i = do+ alignGet i+ getEndian l b++getWord8 :: DBusGet Word8+getWord8 = getting B.getWord8 B.getWord8 1++getWord16 :: DBusGet Word16+getWord16 = getting B.getWord16le B.getWord16be 2++getWord32 :: DBusGet Word32+getWord32 = getting B.getWord32le B.getWord32be 4++getWord64 :: DBusGet Word64+getWord64 = getting B.getWord64le B.getWord64be 8++getInt16 :: DBusGet Int16+getInt16 = fromIntegral <$> getWord16++getInt32 :: DBusGet Int32+getInt32 = fromIntegral <$> getWord32++getInt64 :: DBusGet Int64+getInt64 = fromIntegral <$> getWord64++getDouble :: DBusGet Double+getDouble = getting B.getFloat64le B.getFloat64be 8++getText :: DBusGet Text.Text+getText = do+ len <- getWord32+ bs <- lift $ B.getByteString (fromIntegral len)+ guard . (== 0) =<< getWord8+ case Text.decodeUtf8' bs of+ Left _ -> fail "could not decode UTF 8"+ Right txt -> return txt++getBool :: DBusGet Bool+getBool = toEnum' <$> getWord32++getSignatures = do+ len <- getWord8+ bs <- lift $ B.getByteString (fromIntegral len)+ guard . (0 ==) =<< getWord8+ case parseSigs bs of+ Nothing -> fail $ "could not parse signature" ++ show bs+ Just s -> return s++getByteString = lift . B.getByteString++getDBV :: SingI t => DBusGet (DBusValue t)+getDBV = getDBV' sing++getDBVByType :: DBusType -> DBusGet SomeDBusValue+getDBVByType t = case toSing t of+ SomeSing s -> withSingI s $ DBV <$> getDBV' s++getDBV' :: Sing t -> DBusGet (DBusValue t)+getDBV' (SDBusSimpleType STypeByte ) = DBVByte <$> getWord8+getDBV' (SDBusSimpleType STypeBoolean ) = DBVBool <$> getBool+getDBV' (SDBusSimpleType STypeInt16 ) = DBVInt16 <$> getInt16+getDBV' (SDBusSimpleType STypeUInt16 ) = DBVUInt16 <$> getWord16+getDBV' (SDBusSimpleType STypeInt32 ) = DBVInt32 <$> getInt32+getDBV' (SDBusSimpleType STypeUInt32 ) = DBVUInt32 <$> getWord32+getDBV' (SDBusSimpleType STypeInt64 ) = DBVInt64 <$> getInt64+getDBV' (SDBusSimpleType STypeUInt64 ) = DBVUInt64 <$> getWord64+getDBV' (SDBusSimpleType STypeDouble ) = DBVDouble <$> getDouble+getDBV' (SDBusSimpleType STypeUnixFD ) = DBVUnixFD <$> getWord32+getDBV' (SDBusSimpleType STypeString ) = DBVString <$> getText+getDBV' (SDBusSimpleType STypeObjectPath) = DBVObjectPath . objectPath <$> getText+getDBV' (SDBusSimpleType STypeSignature) = DBVSignature <$> getSignatures+getDBV' STypeVariant = do+ ss <- getSignatures+ t <- case ss of+ [s] -> return s+ s -> fail $ "Expected 1 signature, got " ++ show (length s)+ case (toSing t) of+ SomeSing s -> withSingI s $ DBVVariant <$> getDBV' s+getDBV' (STypeArray (SDBusSimpleType STypeByte)) = do+ len <- getWord32+ DBVByteArray <$> getByteString (fromIntegral len)+getDBV' (STypeArray t) = do+ len <- getWord32+ alignGet (alignment (fromSing t))+ DBVArray <$> getMany (fromIntegral len) t+getDBV' (STypeStruct ts) = do+ alignGet 8+ DBVStruct <$> getStruct ts+getDBV' (STypeDict k v) = do+ len <- getWord32+ alignGet 8+ DBVDict <$> getManyPairs (fromIntegral len) (SDBusSimpleType k) v++getStruct :: Sing ts -> DBusGet (DBusStruct ts)+getStruct (SCons t SNil) = StructSingleton <$> getDBV' t+getStruct (SCons t ts) = StructCons <$> getDBV' t <*> getStruct ts++getMany :: Int64 -> Sing t -> DBusGet [DBusValue t]+getMany len t = do+ n <- lift B.bytesRead+ go (n + len)+ where+ go n = do+ this <- lift B.bytesRead+ case compare this n of+ LT -> do+ v <- getDBV' t+ vs <- go n+ return (v:vs)+ EQ -> return []+ GT -> mzero++getManyPairs :: Int64+ -> Sing kt+ -> Sing vt+ -> DBusGet [(DBusValue kt, DBusValue vt)]+getManyPairs len kt vt = do+ n <- lift B.bytesRead+ go (n+len)+ where+ go n = do+ this <- lift B.bytesRead+ case compare this n of+ LT -> do+ alignGet 8+ k <- getDBV' kt+ v <- getDBV' vt+ vs <- go n+ return ((k,v):vs)+ EQ -> return []+ GT -> mzero+++sinkGet :: C.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.Partial next) = C.await >>= sink . next
+ src/cbits/credentials.c view
@@ -0,0 +1,31 @@+#include <stdlib.h>+#include <sys/types.h>+#include <sys/un.h>+#include <sys/socket.h>+#include <string.h>+#include <stdio.h>++int send_credentials_and_zero (int s) {+ char buf[1] = { '\0' };+ union {+ struct cmsghdr hdr;+ char cred[CMSG_SPACE (sizeof (struct cmsgcred))];+ } cmsg;+ struct iovec iov;+ struct msghdr msg;+ iov.iov_base = buf;+ iov.iov_len = 1;++ memset(&msg, 0, sizeof(msg));+ msg.msg_iov = &iov;+ msg.msg_iovlen = 1;++ msg.msg_control = (caddr_t) &cmsg;+ msg.msg_controllen = CMSG_SPACE (sizeof (struct cmsgcred));++ cmsg.hdr.cmsg_len = CMSG_LEN (sizeof (struct cmsgcred));+ cmsg.hdr.cmsg_level = SOL_SOCKET;+ cmsg.hdr.cmsg_type = SCM_CREDS;+ int sent = sendmsg (s, &msg, 0 );+ return sent;+}