diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,5 +1,5 @@ name: dbus-core -version: 0.8.5.3 +version: 0.8.5.4 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt @@ -29,11 +29,7 @@ default: False library - if true - ghc-options: -Wall - - if impl(ghc >= 6.11) - ghc-options: -fno-warn-unused-do-bind + ghc-options: -Wall hs-source-dirs: hs @@ -43,7 +39,7 @@ , binary >= 0.4 && < 0.6 , bytestring >= 0.9 && < 0.10 , data-binary-ieee754 >= 0.3 && < 0.5 - , text >= 0.8 && < 0.11 + , text >= 0.8 && < 0.12 , containers >= 0.1 && < 0.5 , unix >= 2.2 && < 2.5 , network >= 2.2 && < 2.4 diff --git a/hs/DBus/Address.hs b/hs/DBus/Address.hs --- a/hs/DBus/Address.hs +++ b/hs/DBus/Address.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +14,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module DBus.Address ( Address , addressMethod @@ -20,17 +25,21 @@ , mkAddresses , strAddress ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf) import qualified Text.ParserCombinators.Parsec as P import Text.ParserCombinators.Parsec ((<|>)) -import DBus.Util (hexToInt, eitherToMaybe) +import DBus.Util (hexToInt, eitherToMaybe, void) + optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + data Address = Address { addressMethod :: Text , addressParameters :: M.Map Text Text @@ -39,17 +48,18 @@ instance Show Address where showsPrec d x = showParen (d> 10) $ showString "Address " . shows (strAddress x) + mkAddresses :: Text -> Maybe [Address] mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where address = do method <- P.many (P.noneOf ":;") - P.char ':' + void (P.char ':') params <- P.sepEndBy param (P.char ',') return $ Address (TL.pack method) (M.fromList params) param = do key <- P.many1 (P.noneOf "=;,") - P.char '=' + void (P.char '=') value <- P.many1 (encodedValue <|> unencodedValue) return (TL.pack key, TL.pack value) @@ -60,9 +70,10 @@ unencodedValue = P.oneOf optionallyEncoded encodedValue = do - P.char '%' + void (P.char '%') hex <- P.count 2 P.hexDigit return . chr . hexToInt $ hex + strAddress :: Address -> Text strAddress (Address t ps) = TL.concat [t, ":", ps'] where ps' = TL.intercalate "," $ do diff --git a/hs/DBus/Authentication.hs b/hs/DBus/Authentication.hs --- a/hs/DBus/Authentication.hs +++ b/hs/DBus/Authentication.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +14,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE DeriveDataTypeable #-} module DBus.Authentication ( Command @@ -21,32 +26,43 @@ , authenticate , realUserID ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString import Data.ByteString.Lazy.Char8 () import qualified DBus.UUID as UUID + import Data.Typeable (Typeable) import qualified Control.Exception as E + import Data.Word (Word8) + import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd) + import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) + import Data.Maybe (isJust) + type Command = Text newtype Mechanism = Mechanism { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID } + data AuthenticationError = AuthenticationError Text deriving (Show, Typeable) instance E.Exception AuthenticationError + authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 -> IO UUID.UUID authenticate mech put getByte = do @@ -54,12 +70,14 @@ uuid <- mechanismRun mech (putCommand put getByte) put "BEGIN\r\n" return uuid + putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command putCommand put get cmd = do let getC = liftM (chr . fromIntegral) get put $ encodeUtf8 cmd put "\r\n" liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC + realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do uid <- getRealUserID @@ -69,6 +87,7 @@ case eitherUUID of Right uuid -> return uuid Left err -> E.throwIO $ AuthenticationError err + checkOK :: Command -> Either Text UUID.UUID checkOK cmd = if validUUID then Right uuid else Left errorMsg where validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs --- a/hs/DBus/Bus.hs +++ b/hs/DBus/Bus.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +14,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module DBus.Bus ( getBus , getFirstBus @@ -20,9 +25,11 @@ , getSessionBus , getStarterBus ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import qualified Control.Exception as E import Control.Monad (when) import Data.Maybe (fromJust, isNothing) @@ -36,36 +43,50 @@ import qualified DBus.Message as M import qualified DBus.Types as T import DBus.Util (fromRight) + busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c + -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus. + getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) getBus = ((busForConnection =<<) .) . C.connect + + -- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to -- the central bus. + getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst + + -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set. + getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" noEnv (E.SomeException _) = return defaultAddr + -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. + getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. + getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" + getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do addr <- fmap TL.pack io @@ -73,6 +94,7 @@ Just [x] -> getBus Auth.realUserID x Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] _ -> E.throwIO $ C.InvalidAddress addr + hello :: M.MethodCall hello = M.MethodCall dbusPath "Hello" @@ -80,6 +102,7 @@ (Just dbusName) Set.empty [] + sendHello :: C.Connection -> IO T.BusName sendHello c = do serial <- fromRight `fmap` C.send c return hello @@ -92,6 +115,7 @@ E.throwIO $ E.AssertionFailed "Invalid response to Hello()" return . fromJust $ name + waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn waitForReply c serial = do received <- C.receive c diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs --- a/hs/DBus/Connection.hs +++ b/hs/DBus/Connection.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,39 +14,61 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE DeriveDataTypeable #-} module DBus.Connection ( + Connection , connectionAddress , connectionUUID + , ConnectionError (..) + , connect , connectFirst + , connectionClose + , send + , receive + ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID + import qualified Data.ByteString.Lazy as L import Data.Word (Word32) + import qualified Network as N import qualified Data.Map as Map + import qualified Network.Socket as NS + import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) + import qualified System.IO as I + import qualified Control.Exception as E import Data.Typeable (Typeable) + import qualified DBus.Authentication as Auth + import qualified DBus.Wire as W + data Connection = Connection { connectionAddress :: A.Address , connectionTransport :: Transport @@ -52,23 +76,29 @@ , connectionReadMVar :: C.MVar () , connectionUUID :: UUID.UUID } + instance Show Connection where showsPrec d con = showParen (d > 10) strCon where addr = A.strAddress $ connectionAddress con strCon = s "" s = showString + + -- | A 'Transport' is anything which can send and receive bytestrings, -- typically via a socket. + data Transport = Transport { transportSend :: L.ByteString -> IO () , transportRecv :: Word32 -> IO L.ByteString , transportClose :: IO () } + connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where transport' "unix" = unix transport' "tcp" = tcp transport' _ = E.throwIO . UnknownMethod + unix :: A.Address -> IO Transport unix a = port >>= N.connectTo "localhost" >>= handleTransport where params = A.addressParameters a @@ -86,6 +116,7 @@ (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew (Just x, Nothing) -> return $ TL.unpack x (Nothing, Just x) -> return $ '\x00' : TL.unpack x + tcp :: A.Address -> IO Transport tcp a = openHandle >>= handleTransport where params = A.addressParameters a @@ -95,13 +126,16 @@ addresses <- getAddresses family socket <- openSocket port addresses NS.socketToHandle socket I.ReadWriteMode + hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params + unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] getFamily = case Map.lookup "family" params of Just "ipv4" -> return NS.AF_INET Just "ipv6" -> return NS.AF_INET6 Nothing -> return NS.AF_UNSPEC Just x -> E.throwIO $ BadParameters a $ unknownFamily x + missingPort = "TCP transport requires the ``port'' parameter." badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] getPort = case Map.lookup "port" params of @@ -109,6 +143,7 @@ Just x -> case P.parse parseWord16 "" (TL.unpack x) of Right x' -> return $ NS.PortNum x' Left _ -> E.throwIO $ BadParameters a $ badPort x + parseWord16 = do chars <- P.many1 P.digit P.eof @@ -120,6 +155,7 @@ fail "bad port" let word = fromIntegral value return $ runGet getWord16host (runPut (putWord16be word)) + getAddresses family = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] @@ -127,9 +163,11 @@ , NS.addrSocketType = NS.Stream } NS.getAddrInfo (Just hints) (Just hostname) Nothing + setPort port (NS.SockAddrInet _ x) = NS.SockAddrInet port x setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z setPort _ addr = addr + openSocket _ [] = E.throwIO $ NoWorkingAddress [a] openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ \(E.SomeException _) -> openSocket port addrs @@ -139,11 +177,13 @@ (NS.addrProtocol addr) NS.connect sock . setPort port . NS.addrAddress $ addr return sock + handleTransport :: I.Handle -> IO Transport handleTransport h = do I.hSetBuffering h I.NoBuffering I.hSetBinaryMode h True return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) + data ConnectionError = InvalidAddress Text | BadParameters A.Address Text @@ -152,8 +192,11 @@ deriving (Show, Typeable) instance E.Exception ConnectionError + + -- | Open a connection to some address, using a given authentication -- mechanism. If the connection fails, a 'ConnectionError' will be thrown. + connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do t <- connectTransport a @@ -162,18 +205,26 @@ readLock <- C.newMVar () serialMVar <- C.newMVar M.firstSerial return $ Connection a t serialMVar readLock uuid + + -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened. + connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where allAddrs = [a | (_, a) <- orig] connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs connectFirst' ((mech, a):as) = E.catch (connect mech a) $ \(E.SomeException _) -> connectFirst' as + + -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used. + connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport + + -- | Send a single message, with a generated 'M.Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it -- receives the serial the message /will/ be sent with, before it's actually @@ -182,6 +233,7 @@ -- Only one message may be sent at a time; if multiple threads attempt to -- send messages in parallel, one will block until after the other has -- finished. + send :: M.Message a => Connection -> (M.Serial -> IO b) -> a -> IO (Either W.MarshalError b) send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> @@ -191,6 +243,7 @@ transportSend t bytes return $ Right x Left err -> return $ Left err + withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do s <- C.takeMVar m @@ -198,12 +251,15 @@ x <- E.unblock (io s) `E.onException` C.putMVar m s' C.putMVar m s' return x + + -- | Receive the next message from the connection, blocking until one is -- available. -- -- Only one message may be received at a time; if multiple threads attempt -- to receive messages in parallel, one will block until after the other has -- finished. + receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> W.unmarshalMessage $ transportRecv t diff --git a/hs/DBus/Constants.hs b/hs/DBus/Constants.hs --- a/hs/DBus/Constants.hs +++ b/hs/DBus/Constants.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +14,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T @@ -25,6 +28,7 @@ arrayMaximumLength :: Word32 arrayMaximumLength = 67108864 + dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -33,6 +37,7 @@ dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus" + interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -41,6 +46,7 @@ interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer" + errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed" diff --git a/hs/DBus/Introspection.hs b/hs/DBus/Introspection.hs --- a/hs/DBus/Introspection.hs +++ b/hs/DBus/Introspection.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +14,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module DBus.Introspection ( Object (..) , Interface (..) @@ -24,15 +29,21 @@ , toXML , fromXML ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import qualified Data.XML.Types as X import qualified Text.XML.LibXML.SAX as SAX import Control.Monad.ST (runST) import qualified Data.STRef as ST + import Control.Monad ((>=>)) import Data.Maybe (fromMaybe, listToMaybe) + import qualified DBus.Types as T + data Object = Object T.ObjectPath [Interface] [Object] deriving (Show, Eq) @@ -53,10 +64,12 @@ data PropertyAccess = Read | Write deriving (Show, Eq) + fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do root <- parseElement text parseRoot path root + parseElement :: Text -> Maybe X.Element parseElement text = runST $ do stackRef <- ST.newSTRef [([], [])] @@ -82,12 +95,14 @@ return $ case stack of [] -> Nothing (_, children'):_ -> Just $ head children' + parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do path <- case getattrM "name" e of Nothing -> Just defaultPath Just x -> T.mkObjectPath x parseObject path e + parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do let parentPath' = case T.strObjectPath parentPath of @@ -96,12 +111,14 @@ pathSegment <- getattrM "name" e path <- T.mkObjectPath $ TL.append parentPath' pathSegment parseObject path e + parseObject :: T.ObjectPath -> X.Element -> Maybe Object parseObject path e | X.elementName e == toName "node" = do interfaces <- children parseInterface (named "interface") e children' <- children (parseChild path) (named "node") e return $ Object path interfaces children' parseObject _ _ = Nothing + parseInterface :: X.Element -> Maybe Interface parseInterface e = do name <- T.mkInterfaceName =<< getattrM "name" e @@ -109,28 +126,33 @@ signals <- children parseSignal (named "signal") e properties <- children parseProperty (named "property") e return $ Interface name methods signals properties + parseMethod :: X.Element -> Maybe Method parseMethod e = do name <- T.mkMemberName =<< getattrM "name" e paramsIn <- children parseParameter (isParam ["in", ""]) e paramsOut <- children parseParameter (isParam ["out"]) e return $ Method name paramsIn paramsOut + parseSignal :: X.Element -> Maybe Signal parseSignal e = do name <- T.mkMemberName =<< getattrM "name" e params <- children parseParameter (isParam ["out", ""]) e return $ Signal name params + parseParameter :: X.Element -> Maybe Parameter parseParameter e = do let name = getattr "name" e sig <- parseType e return $ Parameter name sig + parseType :: X.Element -> Maybe T.Signature parseType e = do sig <- T.mkSignature =<< getattrM "type" e case T.signatureTypes sig of [_] -> Just sig _ -> Nothing + parseProperty :: X.Element -> Maybe Property parseProperty e = do let name = getattr "name" e @@ -142,6 +164,7 @@ "readwrite" -> Just [Read, Write] _ -> Nothing return $ Property name sig access + getattrM :: Text -> X.Element -> Maybe Text getattrM name = fmap attrText . listToMaybe . attrs where attrText = textContent . X.attributeContent @@ -163,6 +186,7 @@ toName :: Text -> X.Name toName t = X.Name t Nothing Nothing + newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) } instance Monad XmlWriter where @@ -171,17 +195,21 @@ (a, w) <- runXmlWriter m (b, w') <- runXmlWriter (f a) return (b, TL.append w w') + tell :: Text -> XmlWriter () tell t = XmlWriter $ Just ((), t) + toXML :: Object -> Maybe Text toXML obj = do (_, text) <- runXmlWriter (writeRoot obj) return text + writeRoot :: Object -> XmlWriter () writeRoot obj@(Object path _ _) = do tell "\n" writeObject (T.strObjectPath path) obj + writeChild :: T.ObjectPath -> Object -> XmlWriter () writeChild parentPath obj@(Object path _ _) = write where path' = T.strObjectPath path @@ -195,42 +223,50 @@ write = case relpathM of Just relpath -> writeObject relpath obj Nothing -> XmlWriter Nothing + writeObject :: Text -> Object -> XmlWriter () writeObject path (Object fullPath interfaces children') = writeElement "node" [("name", path)] $ do mapM_ writeInterface interfaces mapM_ (writeChild fullPath) children' + writeInterface :: Interface -> XmlWriter () writeInterface (Interface name methods signals properties) = writeElement "interface" [("name", T.strInterfaceName name)] $ do mapM_ writeMethod methods mapM_ writeSignal signals mapM_ writeProperty properties + writeMethod :: Method -> XmlWriter () writeMethod (Method name inParams outParams) = writeElement "method" [("name", T.strMemberName name)] $ do mapM_ (writeParameter "in") inParams mapM_ (writeParameter "out") outParams + writeSignal :: Signal -> XmlWriter () writeSignal (Signal name params) = writeElement "signal" [("name", T.strMemberName name)] $ do mapM_ (writeParameter "out") params + writeParameter :: Text -> Parameter -> XmlWriter () writeParameter direction (Parameter name sig) = writeEmptyElement "arg" [ ("name", name) , ("type", T.strSignature sig) , ("direction", direction) ] + writeProperty :: Property -> XmlWriter () writeProperty (Property name sig access) = writeEmptyElement "property" [ ("name", name) , ("type", T.strSignature sig) , ("access", strAccess access) ] + strAccess :: [PropertyAccess] -> Text strAccess access = TL.append readS writeS where readS = if elem Read access then "read" else "" writeS = if elem Write access then "write" else "" + writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do tell "<" @@ -241,12 +277,14 @@ tell "" + writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter () writeEmptyElement name attrs = do tell "<" tell name mapM_ writeAttribute attrs tell "/>" + writeAttribute :: (Text, Text) -> XmlWriter () writeAttribute (name, content) = do tell " " @@ -254,6 +292,7 @@ tell "='" tell (escape content) tell "'" + escape :: Text -> Text escape = TL.concatMap escapeChar where escapeChar c = case c of diff --git a/hs/DBus/MatchRule.hs b/hs/DBus/MatchRule.hs --- a/hs/DBus/MatchRule.hs +++ b/hs/DBus/MatchRule.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +14,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module DBus.MatchRule ( MatchRule (..) , MessageType (..) @@ -22,8 +27,10 @@ , matchAll , matches ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set @@ -31,6 +38,7 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex) + -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation. @@ -45,6 +53,7 @@ , matchParameters :: [ParameterValue] } deriving (Show) + -- | Parameters may match against two types, strings and object paths. It's -- probably an error to have two values for the same parameter. -- @@ -56,6 +65,7 @@ = StringValue Word8 Text | PathValue Word8 T.ObjectPath deriving (Show, Eq) + -- | The set of allowed message types to filter on is separate from the set -- supported for sending over the wire. This allows the server to support -- additional types not yet implemented in the library, or vice-versa. @@ -66,8 +76,11 @@ | Signal | Error deriving (Show, Eq) + + -- | Format a 'MatchRule' as the bus expects to receive in a call to -- @AddMatch@. + formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where filters = structureFilters ++ parameterFilters @@ -81,12 +94,14 @@ , ("destination", fmap T.strBusName . matchDestination) ] unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule + formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where key = "arg" `TL.append` TL.pack (show index) formatParameter (PathValue index x) = formatFilter' key value where key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" value = T.strObjectPath x + formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -95,7 +110,10 @@ formatType MethodReturn = "method_return" formatType Signal = "signal" formatType Error = "error" + + -- | Build a 'M.MethodCall' for adding a match rule to the bus. + addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall C.dbusPath @@ -104,7 +122,10 @@ (Just C.dbusName) Set.empty [T.toVariant $ formatRule rule] + + -- | An empty match rule, which matches everything. + matchAll :: MatchRule matchAll = MatchRule { matchType = Nothing @@ -115,8 +136,11 @@ , matchDestination = Nothing , matchParameters = [] } + + -- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful -- for implementing signal handlers. + matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ rule) $ [ fmap (typeMatches msg) . matchType @@ -127,32 +151,38 @@ , fmap (destMatches msg) . matchDestination , Just . parametersMatch msg . matchParameters ] + typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall _ _ _) MethodCall = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True typeMatches (M.ReceivedSignal _ _ _) Signal = True typeMatches (M.ReceivedError _ _ _) Error = True typeMatches _ _ = False + senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name + ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name = Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name = name == M.signalInterface msg ifaceMatches _ _ = False + memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name = name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name = name == M.signalMember msg memberMatches _ _ = False + pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path = path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path = path == M.signalPath msg pathMatches _ _ = False + destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = Just name == M.methodCallDestination msg @@ -163,6 +193,7 @@ destMatches (M.ReceivedSignal _ _ msg) name = Just name == M.signalDestination msg destMatches _ _ = False + parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool parametersMatch _ [] = True parametersMatch msg values = all validParam values where diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs --- a/hs/DBus/Message.hs +++ b/hs/DBus/Message.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,24 +14,35 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Message ( + Message ( messageFlags , messageBody ) + , Flag (..) + , Serial , serialValue , firstSerial , nextSerial + , MethodCall (..) + , MethodReturn (..) + , Error (..) , errorMessage + , Signal (..) + , Unknown (..) + , ReceivedMessage (..) , receivedSerial , receivedSender , receivedBody + ) where import DBus.Message.Internal diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs --- a/hs/DBus/Message/Internal.hs +++ b/hs/DBus/Message/Internal.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,24 +14,32 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module DBus.Message.Internal where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import qualified Data.Set as S import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) import qualified DBus.Types as T import DBus.Util (maybeIndex) + class Message a where messageTypeCode :: a -> Word8 messageHeaderFields :: a -> [HeaderField] messageFlags :: a -> S.Set Flag messageBody :: a -> [T.Variant] + data Flag = NoReplyExpected | NoAutoStart deriving (Show, Eq, Ord) + data HeaderField = Path T.ObjectPath | Interface T.InterfaceName @@ -40,8 +50,11 @@ | Sender T.BusName | Signature T.Signature deriving (Show, Eq) + + -- | A value used to uniquely identify a particular message within a session. -- 'Serial's are 32-bit unsigned integers, and eventually wrap. + newtype Serial = Serial { serialValue :: Word32 } deriving (Eq, Ord) @@ -51,13 +64,16 @@ instance T.Variable Serial where toVariant (Serial x) = T.toVariant x fromVariant = fmap Serial . T.fromVariant + firstSerial :: Serial firstSerial = Serial 1 nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1) + maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x']) + data MethodCall = MethodCall { methodCallPath :: T.ObjectPath , methodCallMember :: T.MemberName @@ -79,6 +95,7 @@ , maybe' Interface . methodCallInterface $ m , maybe' Destination . methodCallDestination $ m ] + data MethodReturn = MethodReturn { methodReturnSerial :: Serial , methodReturnDestination :: Maybe T.BusName @@ -95,6 +112,7 @@ ] , maybe' Destination . methodReturnDestination $ m ] + data Error = Error { errorName :: T.ErrorName , errorSerial :: Serial @@ -113,6 +131,7 @@ ] , maybe' Destination . errorDestination $ m ] + errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do field <- maybeIndex (errorBody msg) 0 @@ -120,6 +139,7 @@ if TL.null text then Nothing else return text + data Signal = Signal { signalPath :: T.ObjectPath , signalMember :: T.MemberName @@ -140,15 +160,19 @@ ] , maybe' Destination . signalDestination $ m ] + data Unknown = Unknown { unknownType :: Word8 , unknownFlags :: S.Set Flag , unknownBody :: [T.Variant] } deriving (Show, Eq) + + -- | Not an actual message type, but a wrapper around messages received from -- the bus. Each value contains the message's 'Serial' and possibly the -- origin's 'T.BusName' + data ReceivedMessage = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn @@ -156,18 +180,21 @@ | ReceivedSignal Serial (Maybe T.BusName) Signal | ReceivedUnknown Serial (Maybe T.BusName) Unknown deriving (Show, Eq) + receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s receivedSerial (ReceivedError s _ _) = s receivedSerial (ReceivedSignal s _ _) = s receivedSerial (ReceivedUnknown s _ _) = s + receivedSender :: ReceivedMessage -> Maybe T.BusName receivedSender (ReceivedMethodCall _ s _) = s receivedSender (ReceivedMethodReturn _ s _) = s receivedSender (ReceivedError _ s _) = s receivedSender (ReceivedSignal _ s _) = s receivedSender (ReceivedUnknown _ s _) = s + receivedBody :: ReceivedMessage -> [T.Variant] receivedBody (ReceivedMethodCall _ _ x) = messageBody x receivedBody (ReceivedMethodReturn _ _ x) = messageBody x diff --git a/hs/DBus/NameReservation.hs b/hs/DBus/NameReservation.hs --- a/hs/DBus/NameReservation.hs +++ b/hs/DBus/NameReservation.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +14,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation ( RequestNameFlag (..) @@ -29,17 +32,22 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex) + data RequestNameFlag = AllowReplacement | ReplaceExisting | DoNotQueue deriving (Show) + encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where flagValue AllowReplacement = 0x1 flagValue ReplaceExisting = 0x2 flagValue DoNotQueue = 0x4 + + -- | Build a 'M.MethodCall' for requesting a registered bus name. + requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall { M.methodCallPath = C.dbusPath @@ -51,24 +59,30 @@ [ T.toVariant name , T.toVariant . encodeFlags $ flags] } + data RequestNameReply = PrimaryOwner | InQueue | Exists | AlreadyOwner deriving (Show) + mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg = maybeIndex (M.messageBody msg) 0 >>= T.fromVariant >>= decodeRequestReply + decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue decodeRequestReply 3 = Just Exists decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing + + -- | Build a 'M.MethodCall' for releasing a registered bus name. + releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall { M.methodCallPath = C.dbusPath @@ -78,16 +92,19 @@ , M.methodCallMember = "ReleaseName" , M.methodCallBody = [T.toVariant name] } + data ReleaseNameReply = Released | NonExistent | NotOwner deriving (Show) + mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg = maybeIndex (M.messageBody msg) 0 >>= T.fromVariant >>= decodeReleaseReply + decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent diff --git a/hs/DBus/Types.hs b/hs/DBus/Types.hs --- a/hs/DBus/Types.hs +++ b/hs/DBus/Types.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,66 +14,86 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Types ( + -- * Available types Type (..) , typeCode + -- * Variants , Variant , Variable (..) + , variantType + -- * Signatures , Signature , signatureTypes , strSignature + , mkSignature , mkSignature_ + -- * Object paths , ObjectPath , strObjectPath , mkObjectPath , mkObjectPath_ + -- * Arrays , Array , arrayType , arrayItems + , toArray , fromArray , arrayFromItems + , arrayToBytes , arrayFromBytes + -- * Dictionaries , Dictionary , dictionaryItems , dictionaryKeyType , dictionaryValueType + , toDictionary , fromDictionary , dictionaryFromItems + , dictionaryToArray , arrayToDictionary + -- * Structures , Structure (..) + -- * Names + -- ** Bus names , BusName , strBusName , mkBusName , mkBusName_ + -- ** Interface names , InterfaceName , strInterfaceName , mkInterfaceName , mkInterfaceName_ + -- ** Error names , ErrorName , strErrorName , mkErrorName , mkErrorName_ + -- ** Member names , MemberName , strMemberName , mkMemberName , mkMemberName_ + ) where import DBus.Types.Internal diff --git a/hs/DBus/Types/Internal.cpphs b/hs/DBus/Types/Internal.cpphs --- a/hs/DBus/Types/Internal.cpphs +++ b/hs/DBus/Types/Internal.cpphs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,34 +14,55 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + + {-# LANGUAGE TypeSynonymInstances #-} + module DBus.Types.Internal where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int16, Int32, Int64) + import qualified Data.Text as T + import Data.Ord (comparing) + import Data.Text.Encoding (decodeUtf8) + import qualified Data.ByteString.Unsafe as B import qualified Foreign as F import System.IO.Unsafe (unsafePerformIO) + import Data.Text.Lazy.Encoding (encodeUtf8) + import DBus.Util (mkUnsafe) import qualified Data.String as String + import Text.ParserCombinators.Parsec ((<|>)) import qualified Text.ParserCombinators.Parsec as P import DBus.Util (checkLength, parseMaybe) + import Data.List (intercalate) + import Control.Monad (unless) + import Control.Arrow ((***)) import qualified Data.Map as Map + import Control.Monad (forM) + import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BL8 + data Type = DBusBoolean | DBusByte @@ -58,8 +81,11 @@ | DBusDictionary Type Type | DBusStructure [Type] deriving (Show, Eq) + + -- | \"Atomic\" types are any which can't contain any other types. Only -- atomic types may be used as dictionary keys. + isAtomicType :: Type -> Bool isAtomicType DBusBoolean = True isAtomicType DBusByte = True @@ -74,9 +100,13 @@ isAtomicType DBusSignature = True isAtomicType DBusObjectPath = True isAtomicType _ = False + + -- | Every type has an associated type code; a textual representation of -- the type, useful for debugging. + typeCode :: Type -> Text + typeCode t = TL.fromChunks [decodeUtf8 $ typeCodeB t] typeCodeB :: Type -> B.ByteString @@ -93,13 +123,19 @@ typeCodeB DBusSignature = "g" typeCodeB DBusObjectPath = "o" typeCodeB DBusVariant = "v" + typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t + typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"] + typeCodeB (DBusStructure ts) = B.concat $ ["("] ++ map typeCodeB ts ++ [")"] + + -- | 'Variant's may contain any other built-in D-Bus value. Besides -- representing native @VARIANT@ values, they allow type-safe storage and -- deconstruction of heterogeneous collections. + data Variant = VarBoxBool Bool | VarBoxWord8 Word8 @@ -122,6 +158,7 @@ class Variable a where toVariant :: a -> Variant fromVariant :: Variant -> Maybe a + instance Show Variant where showsPrec d var = showParen (d > 10) full where full = s "Variant " . shows code . s " " . valueStr @@ -147,9 +184,12 @@ (VarBoxArray x) -> showsPrec d x (VarBoxDictionary x) -> showsPrec d x (VarBoxStructure x) -> showsPrec d x + + -- | Every variant is strongly-typed; that is, the type of its contained -- value is known at all times. This function retrieves that type, so that -- the correct cast can be used to retrieve the value. + variantType :: Variant -> Type variantType var = case var of (VarBoxBool _) -> DBusBoolean @@ -176,13 +216,16 @@ variantSignature :: Variant -> Maybe Signature variantSignature = mkBytesSignature . typeCodeB . variantType + #define INSTANCE_VARIABLE(TYPE) \ instance Variable TYPE where \ { toVariant = VarBox/**/TYPE \ ; fromVariant (VarBox/**/TYPE x) = Just x \ ; fromVariant _ = Nothing \ } + INSTANCE_VARIABLE(Variant) + INSTANCE_VARIABLE(Bool) INSTANCE_VARIABLE(Word8) INSTANCE_VARIABLE(Int16) @@ -192,16 +235,20 @@ INSTANCE_VARIABLE(Word32) INSTANCE_VARIABLE(Word64) INSTANCE_VARIABLE(Double) + instance Variable TL.Text where toVariant = VarBoxString fromVariant (VarBoxString x) = Just x fromVariant _ = Nothing + instance Variable T.Text where toVariant = toVariant . TL.fromChunks . (:[]) fromVariant = fmap (T.concat . TL.toChunks) . fromVariant + instance Variable String where toVariant = toVariant . TL.pack fromVariant = fmap TL.unpack . fromVariant + INSTANCE_VARIABLE(Signature) data Signature = Signature { signatureTypes :: [Type] } deriving (Eq) @@ -209,15 +256,19 @@ instance Show Signature where showsPrec d x = showParen (d > 10) $ showString "Signature " . shows (strSignature x) + bytesSignature :: Signature -> B.ByteString bytesSignature (Signature ts) = B.concat $ map typeCodeB ts strSignature :: Signature -> Text strSignature (Signature ts) = TL.concat $ map typeCode ts + instance Ord Signature where compare = comparing strSignature + mkBytesSignature :: B.ByteString -> Maybe Signature mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where + parseAtom c yes no = case c of 0x62 -> yes DBusBoolean 0x79 -> yes DBusByte @@ -236,6 +287,8 @@ fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of 0x76 -> Just (Signature [DBusVariant]) _ -> Nothing + + slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature) slow buf len = loop [] 0 where loop acc ii | ii >= len = return . Just . Signature $ reverse acc @@ -260,6 +313,7 @@ Nothing -> return Nothing _ -> return Nothing + structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) structure buf len = loop [] where loop _ ii | ii >= len = return Nothing @@ -287,6 +341,7 @@ Nothing -> return Nothing _ -> return Nothing + array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) array _ len ii | ii >= len = return Nothing array buf len ii = do @@ -313,6 +368,7 @@ Nothing -> return Nothing _ -> return Nothing + dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) dict _ len ii | ii + 1 >= len = return Nothing dict buf len ii = do @@ -343,23 +399,28 @@ if c3 == 0x7D then Just () else Nothing t1 <- mt1 Just (ii' + 1, DBusDictionary t1 t2) + io (cstr, len) = case len of 0 -> return $ Just $ Signature [] 1 -> fmap fast $ F.peek cstr _ | len <= 255 -> slow (F.castPtr cstr) len _ -> return Nothing + mkSignature :: Text -> Maybe Signature mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8 + mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature instance String.IsString Signature where fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack + maybeValidType :: Type -> Maybe () maybeValidType t = if B.length (typeCodeB t) > 255 then Nothing else Just () + INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath { strObjectPath :: Text @@ -372,6 +433,7 @@ instance String.IsString ObjectPath where fromString = mkObjectPath_ . TL.pack + mkObjectPath :: Text -> Maybe ObjectPath mkObjectPath s = parseMaybe path' (TL.unpack s) where c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" @@ -380,14 +442,17 @@ mkObjectPath_ :: Text -> ObjectPath mkObjectPath_ = mkUnsafe "object path" mkObjectPath + INSTANCE_VARIABLE(Array) data Array = VariantArray Type [Variant] | ByteArray BL.ByteString deriving (Eq) + -- | This is the type contained within the array, not the type of the array -- itself. + arrayType :: Array -> Type arrayType (VariantArray t _) = t arrayType (ByteArray _) = DBusByte @@ -395,6 +460,7 @@ arrayItems :: Array -> [Variant] arrayItems (VariantArray _ xs) = xs arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs + instance Show Array where showsPrec d array = showParen (d > 10) $ s "Array " . showSig . s " [" . s valueString . s "]" where @@ -402,6 +468,7 @@ showSig = shows . typeCode . arrayType $ array showVar var = showsPrecVar 0 var "" valueString = intercalate ", " $ map showVar $ arrayItems array + arrayFromItems :: Type -> [Variant] -> Maybe Array arrayFromItems DBusByte vs = fmap (ByteArray . BL.pack) (mapM fromVariant vs) @@ -410,23 +477,28 @@ if all (\x -> variantType x == t) vs then Just $ VariantArray t vs else Nothing + toArray :: Variable a => Type -> [a] -> Maybe Array toArray t = arrayFromItems t . map toVariant fromArray :: Variable a => Array -> Maybe [a] fromArray = mapM fromVariant . arrayItems + arrayToBytes :: Array -> Maybe BL.ByteString arrayToBytes (ByteArray x) = Just x arrayToBytes _ = Nothing arrayFromBytes :: BL.ByteString -> Array arrayFromBytes = ByteArray + instance Variable BL.ByteString where toVariant = toVariant . arrayFromBytes fromVariant x = fromVariant x >>= arrayToBytes + instance Variable B.ByteString where toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x] fromVariant = fmap (B.concat . BL.toChunks) . fromVariant + INSTANCE_VARIABLE(Dictionary) data Dictionary = Dictionary @@ -435,6 +507,7 @@ , dictionaryItems :: [(Variant, Variant)] } deriving (Eq) + instance Show Dictionary where showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ s "Dictionary " . showSig . s " {" . s valueString . s "}" where @@ -442,6 +515,7 @@ showSig = shows $ TL.append (typeCode kt) (typeCode vt) valueString = intercalate ", " $ map showPair pairs showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" + dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary dictionaryFromItems kt vt pairs = do unless (isAtomicType kt) Nothing @@ -453,10 +527,12 @@ if all sameType pairs then Just $ Dictionary kt vt pairs else Nothing + toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b -> Maybe Dictionary toDictionary kt vt = dictionaryFromItems kt vt . pairs where pairs = map (toVariant *** toVariant) . Map.toList + fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary -> Maybe (Map.Map a b) fromDictionary (Dictionary _ _ vs) = do @@ -465,11 +541,13 @@ v' <- fromVariant v return (k', v') return $ Map.fromList pairs + dictionaryToArray :: Dictionary -> Array dictionaryToArray (Dictionary kt vt items) = array where Just array = toArray itemType structs itemType = DBusStructure [kt, vt] structs = [Structure [k, v] | (k, v) <- items] + arrayToDictionary :: Array -> Maybe Dictionary arrayToDictionary array = do let toPair x = do @@ -482,10 +560,12 @@ _ -> Nothing pairs <- mapM toPair $ arrayItems array dictionaryFromItems kt vt pairs + INSTANCE_VARIABLE(Structure) data Structure = Structure [Variant] deriving (Show, Eq) + #define NAME_TYPE(TYPE, NAME) \ newtype TYPE = TYPE {str/**/TYPE :: Text} \ deriving (Eq, Ord); \ @@ -504,6 +584,7 @@ \ mk/**/TYPE/**/_ :: Text -> TYPE; \ mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE + NAME_TYPE(BusName, "bus name") mkBusName :: Text -> Maybe BusName @@ -515,6 +596,7 @@ wellKnown = elems c elems start = elem' start >> P.many1 (P.char '.' >> elem' start) elem' start = P.oneOf start >> P.many (P.oneOf c') + NAME_TYPE(InterfaceName, "interface name") mkInterfaceName :: Text -> Maybe InterfaceName @@ -524,10 +606,12 @@ element = P.oneOf c >> P.many (P.oneOf c') name = element >> P.many1 (P.char '.' >> element) parser = name >> P.eof >> return (InterfaceName s) + NAME_TYPE(ErrorName, "error name") mkErrorName :: Text -> Maybe ErrorName mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + NAME_TYPE(MemberName, "member name") mkMemberName :: Text -> Maybe MemberName diff --git a/hs/DBus/UUID.hs b/hs/DBus/UUID.hs --- a/hs/DBus/UUID.hs +++ b/hs/DBus/UUID.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,13 +14,16 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.UUID ( UUID , toHex , fromHex ) where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + newtype UUID = UUID Text -- TODO: (Word64, Word64)? deriving (Eq) diff --git a/hs/DBus/Util.hs b/hs/DBus/Util.hs --- a/hs/DBus/Util.hs +++ b/hs/DBus/Util.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +14,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Util where import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt) @@ -60,3 +63,6 @@ -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs + +void :: Monad m => m a -> m () +void m = m >> return () diff --git a/hs/DBus/Util/MonadError.hs b/hs/DBus/Util/MonadError.hs --- a/hs/DBus/Util/MonadError.hs +++ b/hs/DBus/Util/MonadError.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +14,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Util.MonadError ( ErrorM (..) , ErrorT (..) diff --git a/hs/DBus/Wire.hs b/hs/DBus/Wire.hs --- a/hs/DBus/Wire.hs +++ b/hs/DBus/Wire.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,12 +14,19 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Wire ( + Endianness (..) + , MarshalError (..) + , UnmarshalError (..) + , marshalMessage + , unmarshalMessage + ) where import DBus.Wire.Internal import DBus.Wire.Marshal diff --git a/hs/DBus/Wire/Internal.hs b/hs/DBus/Wire/Internal.hs --- a/hs/DBus/Wire/Internal.hs +++ b/hs/DBus/Wire/Internal.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,9 +14,11 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Wire.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T + data Endianness = LittleEndian | BigEndian deriving (Show, Eq) @@ -26,7 +30,9 @@ decodeEndianness 108 = Just LittleEndian decodeEndianness 66 = Just BigEndian decodeEndianness _ = Nothing + alignment :: T.Type -> Word8 + alignment T.DBusByte = 1 alignment T.DBusWord16 = 2 alignment T.DBusWord32 = 4 @@ -35,14 +41,22 @@ alignment T.DBusInt32 = 4 alignment T.DBusInt64 = 8 alignment T.DBusDouble = 8 + alignment T.DBusBoolean = 4 + alignment T.DBusString = 4 alignment T.DBusObjectPath = 4 + alignment T.DBusSignature = 1 + alignment (T.DBusArray _) = 4 + alignment (T.DBusDictionary _ _) = 4 + alignment (T.DBusStructure _) = 8 + alignment T.DBusVariant = 1 + padding :: Word64 -> Word8 -> Word64 padding current count = required where diff --git a/hs/DBus/Wire/Marshal.hs b/hs/DBus/Wire/Marshal.hs --- a/hs/DBus/Wire/Marshal.hs +++ b/hs/DBus/Wire/Marshal.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,20 +14,30 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B + import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE + import DBus.Wire.Unicode (maybeEncodeUtf8) + import qualified DBus.Constants as C + import qualified DBus.Message.Internal as M + import Data.Bits ((.|.)) import qualified Data.Set as Set + import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust) @@ -34,6 +46,7 @@ import qualified DBus.Types as T import qualified DBus.Types.Internal as T + data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64 data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState @@ -65,12 +78,15 @@ {-# INLINE putState #-} putState :: MarshalState -> MarshalM () putState s = MarshalM $ \_ _ -> MarshalRR () s + runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of MarshalRL err -> Left err MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder + marshal :: T.Variant -> Marshal marshal v = case v of + T.VarBoxWord8 x -> marshalWord8 x T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x T.VarBoxWord32 x -> marshalWord32 x @@ -78,16 +94,24 @@ T.VarBoxInt16 x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x T.VarBoxInt32 x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x T.VarBoxInt64 x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x + T.VarBoxDouble x -> marshalDouble x + T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0 + T.VarBoxString x -> marshalText x T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x + T.VarBoxSignature x -> marshalSignature x + T.VarBoxArray x -> marshalArray x + T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x) + T.VarBoxStructure (T.Structure vs) -> do pad 8 mapM_ marshal vs + T.VarBoxVariant x -> do let textSig = T.typeCode . T.variantType $ x sig <- case T.variantSignature x of @@ -95,21 +119,25 @@ Nothing -> throwError $ InvalidVariantSignature textSig marshalSignature sig marshal x + appendS :: BS.ByteString -> Marshal appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let builder' = B.append builder $ B.fromByteString bytes count' = count + fromIntegral (BS.length bytes) in MarshalRR () (MarshalState builder' count') + appendL :: L.ByteString -> Marshal appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let builder' = B.append builder $ B.fromLazyByteString bytes count' = count + fromIntegral (L.length bytes) in MarshalRR () (MarshalState builder' count') + pad :: Word8 -> Marshal pad count = MarshalM $ \e s@(MarshalState _ existing) -> let padding' = fromIntegral $ padding existing count bytes = BS.replicate padding' 0 in unMarshalM (appendS bytes) e s + marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do pad size @@ -119,6 +147,7 @@ LittleEndian -> le x size' = fromIntegral size in MarshalRR () (MarshalState builder' (count + size')) + data MarshalError = MessageTooLong Word64 | ArrayTooLong Word64 @@ -138,13 +167,16 @@ ["Invalid variant signature: ", show x] show (InvalidText x) = concat ["Text cannot be marshaled: ", show x] + marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le + {-# INLINE marshalWord8 #-} marshalWord8 :: Word8 -> Marshal marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let builder' = B.append builder $ B.singleton x in MarshalRR () (MarshalState builder' (count + 1)) + marshalDouble :: Double -> Marshal marshalDouble x = do pad 8 @@ -154,6 +186,7 @@ LittleEndian -> IEEE.putFloat64le bytes = runPut $ put x in unMarshalM (appendL bytes) e s + marshalText :: Text -> Marshal marshalText x = do bytes <- case maybeEncodeUtf8 x of @@ -164,6 +197,7 @@ marshalWord32 . fromIntegral . L.length $ bytes appendL bytes marshalWord8 0 + marshalSignature :: T.Signature -> Marshal marshalSignature x = do let bytes = T.bytesSignature x @@ -171,6 +205,7 @@ marshalWord8 size appendS bytes marshalWord8 0 + marshalArray :: T.Array -> Marshal marshalArray x = do (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x @@ -180,9 +215,11 @@ marshalWord32 $ fromIntegral arrayLen appendL $ L.replicate arrayPadding 0 appendL arrayBytes + getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where Just bytes = T.arrayToBytes x + getArrayBytes itemType x = do let vs = T.arrayItems x s <- getState @@ -197,10 +234,12 @@ putState s return (paddingSize, itemBytes) + encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where flagValue M.NoReplyExpected = 0x1 flagValue M.NoAutoStart = 0x2 + encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x) = encodeField' 1 x encodeField (M.Interface x) = encodeField' 2 x @@ -216,9 +255,12 @@ [ T.toVariant code , T.toVariant $ T.toVariant x ] + + -- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is -- possible for marshaling to fail -- if this occurs, an appropriate error -- will be returned instead. + marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where @@ -236,6 +278,7 @@ pad 8 appendL bodyBytes checkMaximumSize + checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let textSig = TL.concat . map (T.typeCode . T.variantType) $ vs @@ -244,6 +287,7 @@ in case T.mkBytesSignature bytesSig of Just x -> return x Nothing -> invalid + marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 -> Marshal marshalHeader msg serial bodySig bodyLength = do @@ -256,8 +300,10 @@ let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] marshalArray . fromJust . T.toArray fieldType $ map encodeField fields + marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness + checkMaximumSize :: Marshal checkMaximumSize = do (MarshalState _ messageLength) <- getState diff --git a/hs/DBus/Wire/Unicode.hs b/hs/DBus/Wire/Unicode.hs --- a/hs/DBus/Wire/Unicode.hs +++ b/hs/DBus/Wire/Unicode.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +14,7 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + module DBus.Wire.Unicode ( maybeEncodeUtf8 , maybeDecodeUtf8) where diff --git a/hs/DBus/Wire/Unmarshal.hs b/hs/DBus/Wire/Unmarshal.hs --- a/hs/DBus/Wire/Unmarshal.hs +++ b/hs/DBus/Wire/Unmarshal.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,22 +14,35 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where + import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + + import Control.Monad (liftM) import qualified DBus.Util.MonadError as E import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL + import qualified Data.Binary.Get as G + import qualified Data.Binary.IEEE754 as IEEE + import DBus.Wire.Unicode (maybeDecodeUtf8) + import qualified DBus.Message.Internal as M + import Data.Bits ((.&.)) import qualified Data.Set as Set + import qualified DBus.Constants as C + import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) @@ -35,6 +50,8 @@ import DBus.Wire.Internal import qualified DBus.Types.Internal as T +import DBus.Util (void) + data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64 data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState @@ -65,14 +82,17 @@ {-# INLINE putState #-} putState :: UnmarshalState -> Unmarshal () putState s = Unmarshal $ \_ _ -> UnmarshalRR () s + runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of UnmarshalRL err -> Left err UnmarshalRR a _ -> Right a + unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes unmarshalType :: T.Type -> Unmarshal T.Variant + unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le @@ -89,25 +109,33 @@ unmarshalType T.DBusInt64 = do x <- unmarshalGet 8 G.getWord64be G.getWord64le return . T.toVariant $ (fromIntegral x :: Int64) + unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le + unmarshalType T.DBusBoolean = unmarshalWord32 >>= fromMaybeU' "boolean" (\x -> case x of 0 -> Just False 1 -> Just True _ -> Nothing) + unmarshalType T.DBusString = liftM T.toVariant unmarshalText unmarshalType T.DBusObjectPath = unmarshalText >>= fromMaybeU' "object path" T.mkObjectPath + unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature + unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t + unmarshalType (T.DBusDictionary kt vt) = do let pairType = T.DBusStructure [kt, vt] array <- unmarshalArray pairType fromMaybeU' "dictionary" T.arrayToDictionary array + unmarshalType (T.DBusStructure ts) = do skipPadding 8 liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts + unmarshalType T.DBusVariant = do let getType sig = case T.signatureTypes sig of [t] -> Just t @@ -115,6 +143,7 @@ t <- fromMaybeU "variant signature" getType =<< unmarshalSignature T.toVariant `liftM` unmarshalType t + {-# INLINE consume #-} consume :: Word64 -> Unmarshal BL.ByteString consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let @@ -123,18 +152,21 @@ in if BL.length x == count' then UnmarshalRR x (UnmarshalState bytes' (offset + count)) else UnmarshalRL $ UnexpectedEOF offset + skipPadding :: Word8 -> Unmarshal () skipPadding count = do (UnmarshalState _ offset) <- getState bytes <- consume $ padding offset count unless (BL.all (== 0) bytes) $ throwError $ InvalidPadding offset + skipTerminator :: Unmarshal () skipTerminator = do (UnmarshalState _ offset) <- getState bytes <- consume 1 unless (BL.all (== 0) bytes) $ throwError $ MissingTerminator offset + fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of Just x' -> return x' @@ -145,6 +177,7 @@ fromMaybeU' label f x = do x' <- fromMaybeU label f x return $ T.toVariant x' + unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do skipPadding count @@ -159,6 +192,7 @@ unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a -> Unmarshal T.Variant unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le + untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do done <- test @@ -168,6 +202,7 @@ x <- comp xs <- untilM test comp return $ x:xs + data UnmarshalError = UnsupportedProtocolVersion Word8 | UnexpectedEOF Word64 @@ -195,14 +230,17 @@ show (MissingTerminator pos) = concat ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" + unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le + unmarshalText :: Unmarshal Text unmarshalText = do byteCount <- unmarshalWord32 bytes <- consume . fromIntegral $ byteCount skipTerminator fromMaybeU "text" maybeDecodeUtf8 bytes + unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do byteCount <- BL.head `liftM` consume 1 @@ -210,10 +248,12 @@ skipTerminator let bytes = B.concat $ BL.toChunks lazy fromMaybeU "signature" T.mkBytesSignature bytes + unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do byteCount <- unmarshalWord32 T.arrayFromBytes `liftM` consume (fromIntegral byteCount) + unmarshalArray itemType = do let getOffset = do (UnmarshalState _ o) <- getState @@ -227,12 +267,14 @@ when (end' > end) $ throwError ArraySizeMismatch fromMaybeU "array" (T.arrayFromItems itemType) vs + decodeFlags :: Word8 -> Set.Set M.Flag decodeFlags word = Set.fromList flags where flagSet = [ (0x1, M.NoReplyExpected) , (0x2, M.NoAutoStart) ] flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] + decodeField :: T.Structure -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of @@ -251,26 +293,34 @@ decodeField' x f label = case T.fromVariant x of Just x' -> return [f x'] Nothing -> E.throwErrorM $ InvalidHeaderField label x + unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where T.Structure [c, v] = struct c' = fromJust . T.fromVariant $ c v' = fromJust . T.fromVariant $ v + + -- | Read bytes from a monad until a complete message has been received. + unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do let getBytes = E.ErrorT . liftM Right . getBytes' + let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16 + let messageVersion = BL.index fixedBytes 3 when (messageVersion /= C.protocolVersion) $ E.throwErrorT $ UnsupportedProtocolVersion messageVersion + let eByte = BL.index fixedBytes 0 endianness <- case decodeEndianness eByte of Just x' -> return x' Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte + let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of Right x' -> return x' Left e -> E.throwErrorT e @@ -279,31 +329,44 @@ let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 let bodyLength = fromJust . T.fromVariant $ fixed !! 4 let serial = fromJust . T.fromVariant $ fixed !! 5 + let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 + + let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount let headerBytes = BL.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes + let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of Left err -> E.throwErrorT err Right x -> return x + + let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 - getBytes . fromIntegral $ bodyPadding + void (getBytes (fromIntegral bodyPadding)) + let bodySig = findBodySignature fields + bodyBytes <- getBytes bodyLength body <- unmarshal' bodySig bodyBytes + + y <- case E.runErrorM $ buildReceivedMessage typeCode fields of Right x -> return x Left err -> E.throwErrorT $ MissingHeaderField err return $ y serial flags body + findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where signature = listToMaybe [x | M.Signature x <- fields] + buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) + buildReceivedMessage 1 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -313,6 +376,7 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodCall path member iface dest flags body in M.ReceivedMethodCall serial sender msg + buildReceivedMessage 2 fields = do replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] return $ \serial _ body -> let @@ -320,6 +384,7 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodReturn replySerial dest body in M.ReceivedMethodReturn serial sender msg + buildReceivedMessage 3 fields = do name <- require "error name" [x | M.ErrorName x <- fields] replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] @@ -328,6 +393,7 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Error name replySerial dest body in M.ReceivedError serial sender msg + buildReceivedMessage 4 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -337,10 +403,12 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Signal path member iface dest body in M.ReceivedSignal serial sender msg + buildReceivedMessage typeCode fields = return $ \serial flags body -> let sender = listToMaybe [x | M.Sender x <- fields] msg = M.Unknown typeCode flags body in M.ReceivedUnknown serial sender msg + require :: Text -> [a] -> E.ErrorM Text a require _ (x:_) = return x require label _ = E.throwErrorM label diff --git a/hs/Tests.hs b/hs/Tests.hs --- a/hs/Tests.hs +++ b/hs/Tests.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,8 +14,12 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + module Main (tests, main) where + import Test.QuickCheck import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -40,8 +46,10 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I + tests :: [F.Test] tests = [ F.testGroup "dummy" [] + , F.testGroup "String" [ testProperty "String -> strict Text" $ funEq (fromVariant . toVariant) (Just . T.pack) @@ -56,19 +64,23 @@ , testProperty "Strict Text <- lazy Text" $ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) ] + , F.testGroup "Signature" [ testProperty "Signature identity" $ funEq (mkSignature . strSignature) Just ] + , F.testGroup "ObjectPath" [ testProperty "ObjectPath identity" $ funEq (mkObjectPath . strObjectPath) Just ] + , F.testGroup "Array" [ testProperty "Array identity" $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) , testProperty "Array homogeneity" prop_ArrayHomogeneous ] + , F.testGroup "Dictionary" [ testProperty "Dictionary identity" $ \x -> Just x == dictionaryFromItems @@ -82,22 +94,27 @@ , testProperty "Dictionary <-> Array conversion" $ funEq (arrayToDictionary . dictionaryToArray) Just ] + , F.testGroup "BusName" [ testProperty "BusName identity" $ funEq (mkBusName . strBusName) Just ] + , F.testGroup "InterfaceName" [ testProperty "InterfaceName identity" $ funEq (mkInterfaceName . strInterfaceName) Just ] + , F.testGroup "ErrorName" [ testProperty "ErrorName identity" $ funEq (mkErrorName . strErrorName) Just ] + , F.testGroup "MemberName" [ testProperty "MemberName identity" $ funEq (mkMemberName . strMemberName) Just ] + , F.testGroup "Wire format" [ testProperty "Marshal -> Ummarshal" prop_Unmarshal , F.testGroup "Messages" @@ -107,6 +124,7 @@ , testProperty "Signals" prop_WireSignal ] ] + , F.testGroup "Addresses" [ testProperty "Address identity" $ \x -> mkAddresses (strAddress x) == Just [x] @@ -137,6 +155,7 @@ , test "no param" $ isNothing . mkAddresses $ "a:," ] ] + , F.testGroup "Introspection" [ testProperty "Generate -> Parse" $ \x@(I.Object path _ _) -> let @@ -145,10 +164,12 @@ parsed = I.fromXML path xml' in isJust xml ==> I.fromXML path xml' == Just x ] + ] main :: IO () main = F.defaultMain tests + instance Arbitrary Type where arbitrary = oneof [atomicType, containerType] @@ -179,6 +200,7 @@ return $ DBusDictionary kt vt 2 -> fmap DBusStructure $ halfSized arbitrary 3 -> return DBusVariant + instance Arbitrary Variant where arbitrary = arbitrary >>= genVariant @@ -200,14 +222,17 @@ (DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) (DBusStructure _) -> fmap toVariant (arbitrary :: Gen Structure) DBusVariant -> fmap toVariant (arbitrary :: Gen Variant) + instance Arbitrary Signature where arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary + instance Arbitrary ObjectPath where arbitrary = fmap (mkObjectPath_ . TL.pack) path' where c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" path = fmap (intercalate "/" . ([] :)) genElements path' = frequency [(1, return "/"), (9, path)] genElements = atLeast 1 (atLeast 1 (elements c)) + instance Arbitrary Array where arbitrary = do t <- atomicType @@ -221,6 +246,7 @@ firstType = if null types then DBusByte else head types + instance Arbitrary Dictionary where arbitrary = do kt <- atomicType @@ -236,8 +262,10 @@ vType = dictionaryValueType x correctType (k, v) = variantType k == kType && variantType v == vType + instance Arbitrary Structure where arbitrary = fmap Structure $ halfSized arbitrary + instance Arbitrary BusName where arbitrary = sizedText 255 (oneof [unique, wellKnown]) where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" @@ -255,6 +283,7 @@ x <- elements start xs <- atLeast 0 (elements c') return (x:xs) + instance Arbitrary InterfaceName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -266,8 +295,10 @@ x <- elements c xs <- atLeast 0 (elements c') return (x:xs) + instance Arbitrary ErrorName where arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary + instance Arbitrary MemberName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -277,10 +308,13 @@ x <- elements c xs <- atLeast 0 (elements c') return . TL.pack $ (x:xs) + instance Arbitrary Flag where arbitrary = elements [NoReplyExpected, NoAutoStart] + instance Arbitrary Serial where arbitrary = fmap Serial arbitrary + instance Arbitrary MethodCall where arbitrary = do path <- arbitrary @@ -290,12 +324,14 @@ flags <- fmap Set.fromList arbitrary Structure body <- arbitrary return $ MethodCall path member iface dest flags body + instance Arbitrary MethodReturn where arbitrary = do serial <- arbitrary dest <- arbitrary Structure body <- arbitrary return $ MethodReturn serial dest body + instance Arbitrary Error where arbitrary = do name <- arbitrary @@ -303,6 +339,7 @@ dest <- arbitrary Structure body <- arbitrary return $ Error name serial dest body + instance Arbitrary Signal where arbitrary = do path <- arbitrary @@ -311,8 +348,10 @@ dest <- arbitrary Structure body <- arbitrary return $ Signal path member iface dest body + instance Arbitrary Endianness where arbitrary = elements [LittleEndian, BigEndian] + prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where sig = mkSignature . typeCode . variantType $ x @@ -345,6 +384,7 @@ prop_WireSignal e serial msg = prop_MarshalMessage e serial msg $ ReceivedSignal serial Nothing msg + instance Arbitrary Address where arbitrary = genAddress where optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." @@ -381,6 +421,7 @@ let addrStr = concat [m, ":", params, extraSemicolon] let Just [addr] = mkAddresses $ TL.pack addrStr return addr + subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do @@ -443,6 +484,7 @@ [[], [I.Read], [I.Write], [I.Read, I.Write]] return $ I.Property (TL.pack name) sig access + halfSized :: Gen a -> Gen a halfSized gen = sized $ \n -> if n > 0 then resize (n `div` 2) gen @@ -466,9 +508,11 @@ isRight :: Either a b -> Bool isRight = either (const False) (const True) + test :: Testable a => F.TestName -> a -> F.Test test name prop = F.plusTestOptions options (testProperty name prop) where options = F.TestOptions Nothing (Just 1) Nothing Nothing + instance Arbitrary T.Text where arbitrary = fmap T.pack arbitrary diff --git a/src/addresses.anansi b/src/addresses.anansi --- a/src/addresses.anansi +++ b/src/addresses.anansi @@ -32,7 +32,7 @@ import Text.Printf (printf) import qualified Text.ParserCombinators.Parsec as P import Text.ParserCombinators.Parsec ((<|>)) -import DBus.Util (hexToInt, eitherToMaybe) +import DBus.Util (hexToInt, eitherToMaybe, void) : \subsection{Address syntax} @@ -98,13 +98,13 @@ mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where address = do method <- P.many (P.noneOf ":;") - P.char ':' + void (P.char ':') params <- P.sepEndBy param (P.char ',') return $ Address (TL.pack method) (M.fromList params) param = do key <- P.many1 (P.noneOf "=;,") - P.char '=' + void (P.char '=') value <- P.many1 (encodedValue <|> unencodedValue) return (TL.pack key, TL.pack value) @@ -115,7 +115,7 @@ unencodedValue = P.oneOf optionallyEncoded encodedValue = do - P.char '%' + void (P.char '%') hex <- P.count 2 P.hexDigit return . chr . hexToInt $ hex : diff --git a/src/util.anansi b/src/util.anansi --- a/src/util.anansi +++ b/src/util.anansi @@ -104,6 +104,9 @@ -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs + +void :: Monad m => m a -> m () +void m = m >> return () : \subsection{Bundled ErrorT variant} diff --git a/src/wire.anansi b/src/wire.anansi --- a/src/wire.anansi +++ b/src/wire.anansi @@ -256,6 +256,7 @@ import DBus.Wire.Internal import qualified DBus.Types.Internal as T +import DBus.Util (void) : :d unmarshal imports @@ -1078,7 +1079,7 @@ :d read body let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 -getBytes . fromIntegral $ bodyPadding +void (getBytes (fromIntegral bodyPadding)) : :f DBus/Wire/Unmarshal.hs