diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/d-bus.cabal b/d-bus.cabal new file mode 100644 --- /dev/null +++ b/d-bus.cabal @@ -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 diff --git a/src/DBus.hs b/src/DBus.hs new file mode 100644 --- /dev/null +++ b/src/DBus.hs @@ -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 () diff --git a/src/DBus/Auth.hs b/src/DBus/Auth.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Auth.hs @@ -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 diff --git a/src/DBus/Error.hs b/src/DBus/Error.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Error.hs @@ -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 diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Introspect.hs @@ -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) diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs new file mode 100644 --- /dev/null +++ b/src/DBus/MainLoop.hs @@ -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 diff --git a/src/DBus/Message.hs b/src/DBus/Message.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Message.hs @@ -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 diff --git a/src/DBus/MessageBus.hs b/src/DBus/MessageBus.hs new file mode 100644 --- /dev/null +++ b/src/DBus/MessageBus.hs @@ -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" [] diff --git a/src/DBus/Object.hs b/src/DBus/Object.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Object.hs @@ -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 diff --git a/src/DBus/Representable.hs b/src/DBus/Representable.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Representable.hs @@ -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) diff --git a/src/DBus/Signal.hs b/src/DBus/Signal.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Signal.hs @@ -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] diff --git a/src/DBus/Signature.hs b/src/DBus/Signature.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Signature.hs @@ -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 diff --git a/src/DBus/TH.hs b/src/DBus/TH.hs new file mode 100644 --- /dev/null +++ b/src/DBus/TH.hs @@ -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 []] + ] diff --git a/src/DBus/Transport.hs b/src/DBus/Transport.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Transport.hs @@ -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 diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Types.hs @@ -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 + } diff --git a/src/DBus/Wire.hs b/src/DBus/Wire.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Wire.hs @@ -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 diff --git a/src/cbits/credentials.c b/src/cbits/credentials.c new file mode 100644 --- /dev/null +++ b/src/cbits/credentials.c @@ -0,0 +1,31 @@ +#include +#include +#include +#include +#include +#include + +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; +}