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.3.1 +version: 0.8.4 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt @@ -34,18 +34,16 @@ build-depends: base >=4.0 && < 5.0 - , parsec >= 3.0 && < 4 + , parsec >= 2.0 && < 3.2 , binary >= 0.4 && < 0.6 , bytestring >= 0.9 && < 0.10 , data-binary-ieee754 >= 0.3 && < 0.5 - , HaXml >= 1.20 && < 1.21 - , pretty >= 1.0 && < 1.1 , text >= 0.7 && < 0.8 - , transformers >= 0.2 && < 0.3 - , monads-tf >= 0.1 && < 0.2 , containers >= 0.1 && < 0.4 , unix >= 2.2 && < 2.5 , network >= 2.2 && < 2.3 + , libxml-sax >= 0.5 && < 0.6 + , xml-types >= 0.1 && < 0.2 exposed-modules: DBus.Address @@ -63,6 +61,7 @@ other-modules: DBus.Message.Internal + DBus.Types.Internal DBus.Wire.Internal DBus.Wire.Marshal DBus.Wire.Unmarshal @@ -86,11 +85,6 @@ ghc-options: -fhpc other-modules: - DBus.Address - DBus.Constants - DBus.Introspection - DBus.Message - DBus.Types - DBus.Wire + DBus.Types.Internal DBus.Util 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,7 @@ + +#line 19 "src/addresses.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 20 "src/addresses.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 21 "src/addresses.anansi" module DBus.Address ( Address , addressMethod @@ -20,17 +30,25 @@ , mkAddresses , strAddress ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/addresses.anansi" + import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf) -import qualified Text.Parsec as P -import Text.Parsec ((<|>)) +import qualified Text.ParserCombinators.Parsec as P +import Text.ParserCombinators.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe) + +#line 74 "src/addresses.anansi" optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + +#line 82 "src/addresses.anansi" data Address = Address { addressMethod :: Text , addressParameters :: M.Map Text Text @@ -39,6 +57,8 @@ instance Show Address where showsPrec d x = showParen (d> 10) $ showString "Address " . shows (strAddress x) + +#line 97 "src/addresses.anansi" mkAddresses :: Text -> Maybe [Address] mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where address = do @@ -63,6 +83,8 @@ P.char '%' hex <- P.count 2 P.hexDigit return . chr . hexToInt $ hex + +#line 128 "src/addresses.anansi" 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,7 @@ + +#line 27 "src/authentication.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 28 "src/authentication.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 29 "src/authentication.anansi" {-# LANGUAGE DeriveDataTypeable #-} module DBus.Authentication ( Command @@ -21,31 +31,54 @@ , authenticate , realUserID ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + +#line 38 "src/authentication.anansi" + +#line 45 "src/authentication.anansi" import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString +import Data.ByteString.Lazy.Char8 () import qualified DBus.UUID as UUID + +#line 61 "src/authentication.anansi" import Data.Typeable (Typeable) import qualified Control.Exception as E + +#line 78 "src/authentication.anansi" import Data.Word (Word8) + +#line 94 "src/authentication.anansi" import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd) + +#line 115 "src/authentication.anansi" import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) + +#line 136 "src/authentication.anansi" import Data.Maybe (isJust) + +#line 52 "src/authentication.anansi" type Command = Text newtype Mechanism = Mechanism { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID } + +#line 66 "src/authentication.anansi" data AuthenticationError = AuthenticationError Text deriving (Show, Typeable) instance E.Exception AuthenticationError + +#line 82 "src/authentication.anansi" authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 -> IO UUID.UUID authenticate mech put getByte = do @@ -53,12 +86,16 @@ uuid <- mechanismRun mech (putCommand put getByte) put "BEGIN\r\n" return uuid + +#line 101 "src/authentication.anansi" 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 + +#line 121 "src/authentication.anansi" realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do uid <- getRealUserID @@ -68,6 +105,8 @@ case eitherUUID of Right uuid -> return uuid Left err -> E.throwIO $ AuthenticationError err + +#line 140 "src/authentication.anansi" 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,7 @@ + +#line 19 "src/bus.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 20 "src/bus.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 21 "src/bus.anansi" module DBus.Bus ( getBus , getFirstBus @@ -20,9 +30,13 @@ , getSessionBus , getStarterBus ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/bus.anansi" + import qualified Control.Exception as E import Control.Monad (when) import Data.Maybe (fromJust, isNothing) @@ -36,36 +50,64 @@ import qualified DBus.Message as M import qualified DBus.Types as T import DBus.Util (fromRight) + +#line 50 "src/bus.anansi" busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c + +#line 99 "src/api-docs.anansi" -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus. + +#line 54 "src/bus.anansi" getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) getBus = ((busForConnection =<<) .) . C.connect + +#line 62 "src/bus.anansi" + +#line 104 "src/api-docs.anansi" -- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to -- the central bus. + +#line 63 "src/bus.anansi" getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst + +#line 74 "src/bus.anansi" + +#line 109 "src/api-docs.anansi" -- | 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. + +#line 75 "src/bus.anansi" 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 + +#line 116 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. + +#line 82 "src/bus.anansi" getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +#line 121 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. + +#line 86 "src/bus.anansi" getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" + +#line 91 "src/bus.anansi" getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do addr <- fmap TL.pack io @@ -73,6 +115,8 @@ Just [x] -> getBus Auth.realUserID x Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] _ -> E.throwIO $ C.InvalidAddress addr + +#line 103 "src/bus.anansi" hello :: M.MethodCall hello = M.MethodCall dbusPath "Hello" @@ -80,6 +124,8 @@ (Just dbusName) Set.empty [] + +#line 113 "src/bus.anansi" sendHello :: C.Connection -> IO T.BusName sendHello c = do serial <- fromRight `fmap` C.send c return hello @@ -92,6 +138,8 @@ E.throwIO $ E.AssertionFailed "Invalid response to Hello()" return . fromJust $ name + +#line 128 "src/bus.anansi" 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,7 @@ + +#line 19 "src/connections.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,39 +16,83 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 20 "src/connections.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 21 "src/connections.anansi" {-# LANGUAGE DeriveDataTypeable #-} module DBus.Connection ( + +#line 53 "src/connections.anansi" Connection , connectionAddress , connectionUUID + +#line 288 "src/connections.anansi" , ConnectionError (..) + +#line 327 "src/connections.anansi" , connect , connectFirst + +#line 340 "src/connections.anansi" , connectionClose + +#line 370 "src/connections.anansi" , send + +#line 394 "src/connections.anansi" , receive + +#line 24 "src/connections.anansi" ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + +#line 26 "src/connections.anansi" + +#line 36 "src/connections.anansi" import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID + +#line 75 "src/connections.anansi" import qualified Data.ByteString.Lazy as L import Data.Word (Word32) + +#line 107 "src/connections.anansi" import qualified Network as N import qualified Data.Map as Map + +#line 147 "src/connections.anansi" import qualified Network.Socket as NS -import qualified Text.Parsec as P + +#line 193 "src/connections.anansi" +import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) + +#line 255 "src/connections.anansi" import qualified System.IO as I + +#line 272 "src/connections.anansi" import qualified Control.Exception as E import Data.Typeable (Typeable) + +#line 297 "src/connections.anansi" import qualified DBus.Authentication as Auth + +#line 353 "src/connections.anansi" import qualified DBus.Wire as W + +#line 43 "src/connections.anansi" data Connection = Connection { connectionAddress :: A.Address , connectionTransport :: Transport @@ -52,23 +100,35 @@ , connectionReadMVar :: C.MVar () , connectionUUID :: UUID.UUID } + +#line 62 "src/connections.anansi" instance Show Connection where showsPrec d con = showParen (d > 10) strCon where addr = A.strAddress $ connectionAddress con strCon = s "" s = showString + +#line 80 "src/connections.anansi" + +#line 59 "src/api-docs.anansi" -- | A 'Transport' is anything which can send and receive bytestrings, -- typically via a socket. + +#line 81 "src/connections.anansi" data Transport = Transport { transportSend :: L.ByteString -> IO () , transportRecv :: Word32 -> IO L.ByteString , transportClose :: IO () } + +#line 92 "src/connections.anansi" connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where transport' "unix" = unix transport' "tcp" = tcp transport' _ = E.throwIO . UnknownMethod + +#line 112 "src/connections.anansi" unix :: A.Address -> IO Transport unix a = port >>= N.connectTo "localhost" >>= handleTransport where params = A.addressParameters a @@ -86,6 +146,8 @@ (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew (Just x, Nothing) -> return $ TL.unpack x (Nothing, Just x) -> return $ '\x00' : TL.unpack x + +#line 151 "src/connections.anansi" tcp :: A.Address -> IO Transport tcp a = openHandle >>= handleTransport where params = A.addressParameters a @@ -95,13 +157,19 @@ addresses <- getAddresses family socket <- openSocket port addresses NS.socketToHandle socket I.ReadWriteMode + +#line 165 "src/connections.anansi" hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params + +#line 169 "src/connections.anansi" 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 + +#line 178 "src/connections.anansi" 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,14 +177,21 @@ Just x -> case P.parse parseWord16 "" (TL.unpack x) of Right x' -> return $ NS.PortNum x' Left _ -> E.throwIO $ BadParameters a $ badPort x + +#line 200 "src/connections.anansi" parseWord16 = do chars <- P.many1 P.digit P.eof let value = read chars :: Integer unless (value > 0 && value <= 65535) $ - P.parserFail "bad port" >> return () + -- Calling 'fail' is acceptable here, because Parsec 2 + -- offers no other error reporting mechanism, and + -- implements 'fail'. + fail "bad port" let word = fromIntegral value return $ runGet getWord16host (runPut (putWord16be word)) + +#line 214 "src/connections.anansi" getAddresses family = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] @@ -124,9 +199,13 @@ , NS.addrSocketType = NS.Stream } NS.getAddrInfo (Just hints) (Just hostname) Nothing + +#line 228 "src/connections.anansi" 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 + +#line 238 "src/connections.anansi" openSocket _ [] = E.throwIO $ NoWorkingAddress [a] openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ \(E.SomeException _) -> openSocket port addrs @@ -136,11 +215,15 @@ (NS.addrProtocol addr) NS.connect sock . setPort port . NS.addrAddress $ addr return sock + +#line 259 "src/connections.anansi" 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) + +#line 277 "src/connections.anansi" data ConnectionError = InvalidAddress Text | BadParameters A.Address Text @@ -149,8 +232,14 @@ deriving (Show, Typeable) instance E.Exception ConnectionError + +#line 301 "src/connections.anansi" + +#line 64 "src/api-docs.anansi" -- | Open a connection to some address, using a given authentication -- mechanism. If the connection fails, a 'ConnectionError' will be thrown. + +#line 302 "src/connections.anansi" connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do t <- connectTransport a @@ -159,18 +248,34 @@ readLock <- C.newMVar () serialMVar <- C.newMVar M.firstSerial return $ Connection a t serialMVar readLock uuid + +#line 317 "src/connections.anansi" + +#line 69 "src/api-docs.anansi" -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened. + +#line 318 "src/connections.anansi" 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 + +#line 334 "src/connections.anansi" + +#line 74 "src/api-docs.anansi" -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used. + +#line 335 "src/connections.anansi" connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport + +#line 357 "src/connections.anansi" + +#line 79 "src/api-docs.anansi" -- | 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 @@ -179,6 +284,8 @@ -- 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. + +#line 358 "src/connections.anansi" send :: M.Message a => Connection -> (M.Serial -> IO b) -> a -> IO (Either W.MarshalError b) send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> @@ -188,6 +295,8 @@ transportSend t bytes return $ Right x Left err -> return $ Left err + +#line 374 "src/connections.anansi" withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do s <- C.takeMVar m @@ -195,12 +304,18 @@ x <- E.unblock (io s) `E.onException` C.putMVar m s' C.putMVar m s' return x + +#line 387 "src/connections.anansi" + +#line 90 "src/api-docs.anansi" -- | 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. + +#line 388 "src/connections.anansi" 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,7 @@ + +#line 19 "src/constants.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +16,8 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 20 "src/constants.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T @@ -25,6 +31,8 @@ arrayMaximumLength :: Word32 arrayMaximumLength = 67108864 + +#line 38 "src/constants.anansi" dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -33,6 +41,8 @@ dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus" + +#line 51 "src/constants.anansi" interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -41,6 +51,8 @@ interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer" + +#line 64 "src/constants.anansi" 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,7 @@ + +#line 44 "src/introspection.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 45 "src/introspection.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 46 "src/introspection.anansi" module DBus.Introspection ( Object (..) , Interface (..) @@ -24,16 +34,28 @@ , toXML , fromXML ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL -import qualified Text.XML.HaXml as H -import Text.XML.HaXml.Parse (xmlParse') -import DBus.Util (eitherToMaybe) -import Data.Char (chr) -import Data.Maybe (fromMaybe) -import Text.XML.HaXml.Pretty (document) -import Text.PrettyPrint.HughesPJ (render) + +#line 58 "src/introspection.anansi" + +#line 105 "src/introspection.anansi" +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 Data.Text.Encoding (encodeUtf8) + +#line 254 "src/introspection.anansi" +import Control.Monad ((>=>)) +import Data.Maybe (fromMaybe, listToMaybe) + +#line 59 "src/introspection.anansi" import qualified DBus.Types as T + +#line 65 "src/introspection.anansi" data Object = Object T.ObjectPath [Interface] [Object] deriving (Show, Eq) @@ -54,176 +76,269 @@ data PropertyAccess = Read | Write deriving (Show, Eq) + +#line 94 "src/introspection.anansi" fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do - doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text - let (H.Document _ _ root _) = doc + root <- parseElement text parseRoot path root -parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object + +#line 113 "src/introspection.anansi" +parseElement :: Text -> Maybe X.Element +parseElement text = runST $ do + stackRef <- ST.newSTRef [([], [])] + let callbacks = SAX.ParserCallbacks + { SAX.parsedBeginElement = \_ attrs -> do + ST.modifySTRef stackRef ((attrs, []):) + , SAX.parsedEndElement = \name -> do + stack <- ST.readSTRef stackRef + let (attrs, children'):stack' = stack + let e = X.Element name attrs (map X.NodeElement (reverse children')) + let (pAttrs, pChildren):stack'' = stack' + let parent = (pAttrs, e:pChildren) + ST.writeSTRef stackRef (parent:stack'') + , SAX.parsedCharacters = \_ -> return () + , SAX.parsedComment = \_ -> return () + , SAX.parsedProcessingInstruction = \_ -> return () + } + let onError _ = ST.writeSTRef stackRef [] + p <- SAX.newParser callbacks onError Nothing + mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text + SAX.parseComplete p + stack <- ST.readSTRef stackRef + return $ case stack of + [] -> Nothing + (_, children'):_ -> Just $ head children' + +#line 148 "src/introspection.anansi" +parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do - path <- case getAttr "name" e of + path <- case getattrM "name" e of Nothing -> Just defaultPath Just x -> T.mkObjectPath x - parseObject' path e -parseChild :: T.ObjectPath -> H.Element a -> Maybe Object + parseObject path e + +#line 161 "src/introspection.anansi" +parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do let parentPath' = case T.strObjectPath parentPath of "/" -> "/" x -> TL.append x "/" - pathSegment <- getAttr "name" e + pathSegment <- getattrM "name" e path <- T.mkObjectPath $ TL.append parentPath' pathSegment - parseObject' path e -parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object -parseObject' path e@(H.Elem "node" _ _) = do - interfaces <- children parseInterface (H.tag "interface") e - children' <- children (parseChild path) (H.tag "node") e + parseObject path e + +#line 175 "src/introspection.anansi" +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 :: H.Element a -> Maybe Interface +parseObject _ _ = Nothing + +#line 186 "src/introspection.anansi" +parseInterface :: X.Element -> Maybe Interface parseInterface e = do - name <- T.mkInterfaceName =<< getAttr "name" e - methods <- children parseMethod (H.tag "method") e - signals <- children parseSignal (H.tag "signal") e - properties <- children parseProperty (H.tag "property") e + name <- T.mkInterfaceName =<< getattrM "name" e + methods <- children parseMethod (named "method") e + signals <- children parseSignal (named "signal") e + properties <- children parseProperty (named "property") e return $ Interface name methods signals properties -parseMethod :: H.Element a -> Maybe Method + +#line 199 "src/introspection.anansi" +parseMethod :: X.Element -> Maybe Method parseMethod e = do - name <- T.mkMemberName =<< getAttr "name" e + name <- T.mkMemberName =<< getattrM "name" e paramsIn <- children parseParameter (isParam ["in", ""]) e paramsOut <- children parseParameter (isParam ["out"]) e return $ Method name paramsIn paramsOut -parseSignal :: H.Element a -> Maybe Signal + +#line 210 "src/introspection.anansi" +parseSignal :: X.Element -> Maybe Signal parseSignal e = do - name <- T.mkMemberName =<< getAttr "name" e + name <- T.mkMemberName =<< getattrM "name" e params <- children parseParameter (isParam ["out", ""]) e return $ Signal name params -parseParameter :: H.Element a -> Maybe Parameter + +#line 220 "src/introspection.anansi" +parseParameter :: X.Element -> Maybe Parameter parseParameter e = do - let name = getAttr' "name" e + let name = getattr "name" e sig <- parseType e return $ Parameter name sig -parseType :: H.Element a -> Maybe T.Signature + +#line 228 "src/introspection.anansi" +parseType :: X.Element -> Maybe T.Signature parseType e = do - sig <- T.mkSignature =<< getAttr "type" e + sig <- T.mkSignature =<< getattrM "type" e case T.signatureTypes sig of [_] -> Just sig _ -> Nothing -parseProperty :: H.Element a -> Maybe Property + +#line 240 "src/introspection.anansi" +parseProperty :: X.Element -> Maybe Property parseProperty e = do - let name = getAttr' "name" e + let name = getattr "name" e sig <- parseType e - access <- case getAttr' "access" e of + access <- case getattr "access" e of "" -> Just [] "read" -> Just [Read] "write" -> Just [Write] "readwrite" -> Just [Read, Write] _ -> Nothing return $ Property name sig access -attrValue :: H.AttValue -> Maybe Text -attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where - (H.AttValue parts) = attr - - unescape (Left x) = Just x - unescape (Right (H.RefEntity x)) = lookup x namedRefs - unescape (Right (H.RefChar x)) = Just [chr x] - - namedRefs = - [ ("lt", "<") - , ("gt", ">") - , ("amp", "&") - , ("apos", "'") - , ("quot", "\"") - ] -getAttr :: String -> H.Element a -> Maybe Text -getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue -getAttr' :: String -> H.Element a -> Text -getAttr' = (fromMaybe "" .) . getAttr +#line 259 "src/introspection.anansi" +getattrM :: Text -> X.Element -> Maybe Text +getattrM name = fmap attrText . listToMaybe . attrs where + attrText = textContent . X.attributeContent + attrs = X.elementAttributes >=> X.isNamed (toName name) + textContent cs = TL.concat [t | X.ContentText t <- cs] -isParam :: [Text] -> H.CFilter a -isParam dirs content = do - arg@(H.CElem e _) <- H.tag "arg" content - let direction = getAttr' "direction" e - [arg | direction `elem` dirs] +getattr :: Text -> X.Element -> Text +getattr = (fromMaybe "" .) . getattrM -children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] -children f filt (H.Elem _ _ contents) = - mapM f [x | (H.CElem x _) <- concatMap filt contents] -dtdPublicID, dtdSystemID :: String -dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" -dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" +isParam :: [Text] -> X.Element -> [X.Element] +isParam dirs = named "arg" >=> checkDir where + checkDir e = [e | getattr "direction" e `elem` dirs] + +children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b] +children f p = mapM f . concatMap p . X.elementChildren + +named :: X.Named a => Text -> a -> [a] +named = X.isNamed . toName + +toName :: Text -> X.Name +toName t = X.Name t Nothing Nothing + +#line 293 "src/introspection.anansi" +newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) } + +instance Monad XmlWriter where + return a = XmlWriter $ Just (a, TL.empty) + m >>= f = XmlWriter $ do + (a, w) <- runXmlWriter m + (b, w') <- runXmlWriter (f a) + return (b, TL.append w w') + +#line 304 "src/introspection.anansi" +tell :: Text -> XmlWriter () +tell t = XmlWriter $ Just ((), t) + +#line 309 "src/introspection.anansi" toXML :: Object -> Maybe Text -toXML obj = fmap (TL.pack . render . document) doc where - prolog = H.Prolog Nothing [] (Just doctype) [] - doctype = H.DTD "node" (Just (H.PUBLIC - (H.PubidLiteral dtdPublicID) - (H.SystemLiteral dtdSystemID))) [] - doc = do - root <- xmlRoot obj - return $ H.Document prolog H.emptyST root [] -xmlRoot :: Object -> Maybe (H.Element a) -xmlRoot obj@(Object path _ _) = do - (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj - return root -xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) -xmlObject parentPath obj@(Object path _ _) = do - let path' = T.strObjectPath path - parent' = T.strObjectPath parentPath - relpath <- if TL.isPrefixOf parent' path' +toXML obj = do + (_, text) <- runXmlWriter (writeRoot obj) + return text + +#line 316 "src/introspection.anansi" +writeRoot :: Object -> XmlWriter () +writeRoot obj@(Object path _ _) = do + tell "\n" + writeObject (T.strObjectPath path) obj + +#line 324 "src/introspection.anansi" +writeChild :: T.ObjectPath -> Object -> XmlWriter () +writeChild parentPath obj@(Object path _ _) = write where + path' = T.strObjectPath path + parent' = T.strObjectPath parentPath + relpathM = if TL.isPrefixOf parent' path' then Just $ if parent' == "/" then TL.drop 1 path' else TL.drop (TL.length parent' + 1) path' else Nothing - xmlObject' relpath obj -xmlObject' :: Text -> Object -> Maybe (H.Content a) -xmlObject' path (Object fullPath interfaces children') = do - children'' <- mapM (xmlObject fullPath) children' - return $ mkElement "node" - [mkAttr "name" $ TL.unpack path] - $ concat - [ map xmlInterface interfaces - , children'' - ] -xmlInterface :: Interface -> H.Content a -xmlInterface (Interface name methods signals properties) = - mkElement "interface" - [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] - $ concat - [ map xmlMethod methods - , map xmlSignal signals - , map xmlProperty properties - ] -xmlMethod :: Method -> H.Content a -xmlMethod (Method name inParams outParams) = mkElement "method" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ concat - [ map (xmlParameter "in") inParams - , map (xmlParameter "out") outParams - ] -xmlSignal :: Signal -> H.Content a -xmlSignal (Signal name params) = mkElement "signal" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ map (xmlParameter "out") params -xmlParameter :: String -> Parameter -> H.Content a -xmlParameter direction (Parameter name sig) = mkElement "arg" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "direction" direction - ] [] -xmlProperty :: Property -> H.Content a -xmlProperty (Property name sig access) = mkElement "property" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "access" $ xmlAccess access - ] [] -xmlAccess :: [PropertyAccess] -> String -xmlAccess access = readS ++ writeS where + + write = case relpathM of + Just relpath -> writeObject relpath obj + Nothing -> XmlWriter Nothing + +#line 340 "src/introspection.anansi" +writeObject :: Text -> Object -> XmlWriter () +writeObject path (Object fullPath interfaces children') = writeElement "node" + [("name", path)] $ do + mapM_ writeInterface interfaces + mapM_ (writeChild fullPath) children' + +#line 348 "src/introspection.anansi" +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 + +#line 357 "src/introspection.anansi" +writeMethod :: Method -> XmlWriter () +writeMethod (Method name inParams outParams) = writeElement "method" + [("name", T.strMemberName name)] $ do + mapM_ (writeParameter "in") inParams + mapM_ (writeParameter "out") outParams + +#line 365 "src/introspection.anansi" +writeSignal :: Signal -> XmlWriter () +writeSignal (Signal name params) = writeElement "signal" + [("name", T.strMemberName name)] $ do + mapM_ (writeParameter "out") params + +#line 372 "src/introspection.anansi" +writeParameter :: Text -> Parameter -> XmlWriter () +writeParameter direction (Parameter name sig) = writeEmptyElement "arg" + [ ("name", name) + , ("type", T.strSignature sig) + , ("direction", direction) + ] + +#line 381 "src/introspection.anansi" +writeProperty :: Property -> XmlWriter () +writeProperty (Property name sig access) = writeEmptyElement "property" + [ ("name", name) + , ("type", T.strSignature sig) + , ("access", strAccess access) + ] + +#line 390 "src/introspection.anansi" +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 "" -mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a -mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined -mkAttr :: String -> String -> H.Attribute -mkAttr name value = (name, H.AttValue [Left escaped]) where - raw = H.CString True value () - escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] +#line 397 "src/introspection.anansi" +writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter () +writeElement name attrs content = do + tell "<" + tell name + mapM_ writeAttribute attrs + tell ">" + content + tell "" + +#line 410 "src/introspection.anansi" +writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter () +writeEmptyElement name attrs = do + tell "<" + tell name + mapM_ writeAttribute attrs + tell "/>" + +#line 419 "src/introspection.anansi" +writeAttribute :: (Text, Text) -> XmlWriter () +writeAttribute (name, content) = do + tell " " + tell name + tell "='" + tell (escape content) + tell "'" + +#line 429 "src/introspection.anansi" +escape :: Text -> Text +escape = TL.concatMap escapeChar where + escapeChar c = case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> TL.singleton c 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,7 @@ + +#line 23 "src/match-rules.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,7 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 24 "src/match-rules.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 25 "src/match-rules.anansi" module DBus.MatchRule ( MatchRule (..) , MessageType (..) @@ -22,8 +32,12 @@ , matchAll , matches ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + +#line 35 "src/match-rules.anansi" import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set @@ -31,6 +45,8 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex) + +#line 45 "src/match-rules.anansi" -- | 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 +61,8 @@ , matchParameters :: [ParameterValue] } deriving (Show) + +#line 62 "src/match-rules.anansi" -- | 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 +74,8 @@ = StringValue Word8 Text | PathValue Word8 T.ObjectPath deriving (Show, Eq) + +#line 76 "src/match-rules.anansi" -- | 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 +86,14 @@ | Signal | Error deriving (Show, Eq) + +#line 92 "src/match-rules.anansi" + +#line 126 "src/api-docs.anansi" -- | Format a 'MatchRule' as the bus expects to receive in a call to -- @AddMatch@. + +#line 93 "src/match-rules.anansi" formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where filters = structureFilters ++ parameterFilters @@ -81,12 +107,16 @@ , ("destination", fmap T.strBusName . matchDestination) ] unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule + +#line 109 "src/match-rules.anansi" 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 + +#line 121 "src/match-rules.anansi" formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -95,7 +125,13 @@ formatType MethodReturn = "method_return" formatType Signal = "signal" formatType Error = "error" + +#line 135 "src/match-rules.anansi" + +#line 131 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for adding a match rule to the bus. + +#line 136 "src/match-rules.anansi" addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall C.dbusPath @@ -104,7 +140,13 @@ (Just C.dbusName) Set.empty [T.toVariant $ formatRule rule] + +#line 150 "src/match-rules.anansi" + +#line 135 "src/api-docs.anansi" -- | An empty match rule, which matches everything. + +#line 151 "src/match-rules.anansi" matchAll :: MatchRule matchAll = MatchRule { matchType = Nothing @@ -115,8 +157,14 @@ , matchDestination = Nothing , matchParameters = [] } + +#line 167 "src/match-rules.anansi" + +#line 139 "src/api-docs.anansi" -- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful -- for implementing signal handlers. + +#line 168 "src/match-rules.anansi" matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ rule) $ [ fmap (typeMatches msg) . matchType @@ -127,32 +175,44 @@ , fmap (destMatches msg) . matchDestination , Just . parametersMatch msg . matchParameters ] + +#line 181 "src/match-rules.anansi" 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 + +#line 190 "src/match-rules.anansi" senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name + +#line 195 "src/match-rules.anansi" 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 + +#line 204 "src/match-rules.anansi" 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 + +#line 213 "src/match-rules.anansi" 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 + +#line 222 "src/match-rules.anansi" destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = Just name == M.methodCallDestination msg @@ -163,6 +223,8 @@ destMatches (M.ReceivedSignal _ _ msg) name = Just name == M.signalDestination msg destMatches _ _ = False + +#line 235 "src/match-rules.anansi" 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,7 @@ + +#line 23 "src/messages.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,24 +16,46 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 24 "src/messages.anansi" module DBus.Message ( + +#line 51 "src/messages.anansi" Message ( messageFlags , messageBody ) + +#line 69 "src/messages.anansi" , Flag (..) + +#line 124 "src/messages.anansi" , Serial , serialValue , firstSerial , nextSerial + +#line 169 "src/messages.anansi" , MethodCall (..) + +#line 206 "src/messages.anansi" , MethodReturn (..) + +#line 256 "src/messages.anansi" , Error (..) , errorMessage + +#line 296 "src/messages.anansi" , Signal (..) + +#line 327 "src/messages.anansi" , Unknown (..) + +#line 377 "src/messages.anansi" , ReceivedMessage (..) , receivedSerial , receivedSender , receivedBody + +#line 26 "src/messages.anansi" ) 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,7 @@ + +#line 31 "src/messages.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,24 +16,40 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 32 "src/messages.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 33 "src/messages.anansi" module DBus.Message.Internal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + +#line 35 "src/messages.anansi" 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) + +#line 43 "src/messages.anansi" class Message a where messageTypeCode :: a -> Word8 messageHeaderFields :: a -> [HeaderField] messageFlags :: a -> S.Set Flag messageBody :: a -> [T.Variant] + +#line 62 "src/messages.anansi" data Flag = NoReplyExpected | NoAutoStart deriving (Show, Eq, Ord) + +#line 80 "src/messages.anansi" data HeaderField = Path T.ObjectPath | Interface T.InterfaceName @@ -40,8 +60,14 @@ | Sender T.BusName | Signature T.Signature deriving (Show, Eq) + +#line 98 "src/messages.anansi" + +#line 152 "src/api-docs.anansi" -- | A value used to uniquely identify a particular message within a session. -- 'Serial's are 32-bit unsigned integers, and eventually wrap. + +#line 99 "src/messages.anansi" newtype Serial = Serial { serialValue :: Word32 } deriving (Eq, Ord) @@ -51,13 +77,19 @@ instance T.Variable Serial where toVariant (Serial x) = T.toVariant x fromVariant = fmap Serial . T.fromVariant + +#line 113 "src/messages.anansi" firstSerial :: Serial firstSerial = Serial 1 nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1) + +#line 138 "src/messages.anansi" maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x']) + +#line 145 "src/messages.anansi" data MethodCall = MethodCall { methodCallPath :: T.ObjectPath , methodCallMember :: T.MemberName @@ -79,6 +111,8 @@ , maybe' Interface . methodCallInterface $ m , maybe' Destination . methodCallDestination $ m ] + +#line 187 "src/messages.anansi" data MethodReturn = MethodReturn { methodReturnSerial :: Serial , methodReturnDestination :: Maybe T.BusName @@ -95,6 +129,8 @@ ] , maybe' Destination . methodReturnDestination $ m ] + +#line 221 "src/messages.anansi" data Error = Error { errorName :: T.ErrorName , errorSerial :: Serial @@ -113,6 +149,8 @@ ] , maybe' Destination . errorDestination $ m ] + +#line 246 "src/messages.anansi" errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do field <- maybeIndex (errorBody msg) 0 @@ -120,6 +158,8 @@ if TL.null text then Nothing else return text + +#line 273 "src/messages.anansi" data Signal = Signal { signalPath :: T.ObjectPath , signalMember :: T.MemberName @@ -140,15 +180,23 @@ ] , maybe' Destination . signalDestination $ m ] + +#line 318 "src/messages.anansi" data Unknown = Unknown { unknownType :: Word8 , unknownFlags :: S.Set Flag , unknownBody :: [T.Variant] } deriving (Show, Eq) + +#line 339 "src/messages.anansi" + +#line 157 "src/api-docs.anansi" -- | 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' + +#line 340 "src/messages.anansi" data ReceivedMessage = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn @@ -156,18 +204,24 @@ | ReceivedSignal Serial (Maybe T.BusName) Signal | ReceivedUnknown Serial (Maybe T.BusName) Unknown deriving (Show, Eq) + +#line 350 "src/messages.anansi" receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s receivedSerial (ReceivedError s _ _) = s receivedSerial (ReceivedSignal s _ _) = s receivedSerial (ReceivedUnknown s _ _) = s + +#line 359 "src/messages.anansi" 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 + +#line 368 "src/messages.anansi" 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,7 @@ + +#line 22 "src/name-reservation.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +16,8 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 23 "src/name-reservation.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation ( RequestNameFlag (..) @@ -29,17 +35,27 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex) + +#line 43 "src/name-reservation.anansi" data RequestNameFlag = AllowReplacement | ReplaceExisting | DoNotQueue deriving (Show) + +#line 51 "src/name-reservation.anansi" encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where flagValue AllowReplacement = 0x1 flagValue ReplaceExisting = 0x2 flagValue DoNotQueue = 0x4 + +#line 62 "src/name-reservation.anansi" + +#line 144 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for requesting a registered bus name. + +#line 63 "src/name-reservation.anansi" requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall { M.methodCallPath = C.dbusPath @@ -51,24 +67,36 @@ [ T.toVariant name , T.toVariant . encodeFlags $ flags] } + +#line 77 "src/name-reservation.anansi" data RequestNameReply = PrimaryOwner | InQueue | Exists | AlreadyOwner deriving (Show) + +#line 86 "src/name-reservation.anansi" mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg = maybeIndex (M.messageBody msg) 0 >>= T.fromVariant >>= decodeRequestReply + +#line 94 "src/name-reservation.anansi" decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue decodeRequestReply 3 = Just Exists decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing + +#line 103 "src/name-reservation.anansi" + +#line 148 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for releasing a registered bus name. + +#line 104 "src/name-reservation.anansi" releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall { M.methodCallPath = C.dbusPath @@ -78,16 +106,22 @@ , M.methodCallMember = "ReleaseName" , M.methodCallBody = [T.toVariant name] } + +#line 116 "src/name-reservation.anansi" data ReleaseNameReply = Released | NonExistent | NotOwner deriving (Show) + +#line 124 "src/name-reservation.anansi" mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg = maybeIndex (M.messageBody msg) 0 >>= T.fromVariant >>= decodeReleaseReply + +#line 132 "src/name-reservation.anansi" decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent diff --git a/hs/DBus/Types.cpphs b/hs/DBus/Types.cpphs deleted file mode 100644 --- a/hs/DBus/Types.cpphs +++ /dev/null @@ -1,504 +0,0 @@ --- Copyright (C) 2009-2010 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- 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 ( - -- * 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 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 Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import DBus.Util (checkLength, parseMaybe) -import DBus.Util (mkUnsafe) -import qualified Data.String as String -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString -import qualified Data.ByteString as StrictByteString -import Data.List (intercalate) -import Control.Monad (unless) -import Control.Arrow ((***)) -import qualified Data.Map as Map -import Control.Monad (forM) -data Type - = DBusBoolean - | DBusByte - | DBusInt16 - | DBusInt32 - | DBusInt64 - | DBusWord16 - | DBusWord32 - | DBusWord64 - | DBusDouble - | DBusString - | DBusSignature - | DBusObjectPath - | DBusVariant - | DBusArray Type - | 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 -isAtomicType DBusInt16 = True -isAtomicType DBusInt32 = True -isAtomicType DBusInt64 = True -isAtomicType DBusWord16 = True -isAtomicType DBusWord32 = True -isAtomicType DBusWord64 = True -isAtomicType DBusDouble = True -isAtomicType DBusString = True -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 DBusBoolean = "b" -typeCode DBusByte = "y" -typeCode DBusInt16 = "n" -typeCode DBusInt32 = "i" -typeCode DBusInt64 = "x" -typeCode DBusWord16 = "q" -typeCode DBusWord32 = "u" -typeCode DBusWord64 = "t" -typeCode DBusDouble = "d" -typeCode DBusString = "s" -typeCode DBusSignature = "g" -typeCode DBusObjectPath = "o" -typeCode DBusVariant = "v" -typeCode (DBusArray t) = TL.cons 'a' $ typeCode t -typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] -typeCode (DBusStructure ts) = TL.concat $ - ["("] ++ map typeCode 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 - | VarBoxInt16 Int16 - | VarBoxInt32 Int32 - | VarBoxInt64 Int64 - | VarBoxWord16 Word16 - | VarBoxWord32 Word32 - | VarBoxWord64 Word64 - | VarBoxDouble Double - | VarBoxString Text - | VarBoxSignature Signature - | VarBoxObjectPath ObjectPath - | VarBoxVariant Variant - | VarBoxArray Array - | VarBoxDictionary Dictionary - | VarBoxStructure Structure - deriving (Eq) - -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 - code = typeCode $ variantType var - s = showString - valueStr = showsPrecVar 11 var - -showsPrecVar :: Int -> Variant -> ShowS -showsPrecVar d var = case var of - (VarBoxBool x) -> showsPrec d x - (VarBoxWord8 x) -> showsPrec d x - (VarBoxInt16 x) -> showsPrec d x - (VarBoxInt32 x) -> showsPrec d x - (VarBoxInt64 x) -> showsPrec d x - (VarBoxWord16 x) -> showsPrec d x - (VarBoxWord32 x) -> showsPrec d x - (VarBoxWord64 x) -> showsPrec d x - (VarBoxDouble x) -> showsPrec d x - (VarBoxString x) -> showsPrec d x - (VarBoxSignature x) -> showsPrec d x - (VarBoxObjectPath x) -> showsPrec d x - (VarBoxVariant x) -> showsPrec d x - (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 - (VarBoxWord8 _) -> DBusByte - (VarBoxInt16 _) -> DBusInt16 - (VarBoxInt32 _) -> DBusInt32 - (VarBoxInt64 _) -> DBusInt64 - (VarBoxWord16 _) -> DBusWord16 - (VarBoxWord32 _) -> DBusWord32 - (VarBoxWord64 _) -> DBusWord64 - (VarBoxDouble _) -> DBusDouble - (VarBoxString _) -> DBusString - (VarBoxSignature _) -> DBusSignature - (VarBoxObjectPath _) -> DBusObjectPath - (VarBoxVariant _) -> DBusVariant - (VarBoxArray x) -> DBusArray (arrayType x) - (VarBoxDictionary x) -> let - keyT = dictionaryKeyType x - valueT = dictionaryValueType x - in DBusDictionary keyT valueT - (VarBoxStructure x) -> let - Structure items = x - in DBusStructure (map variantType items) -#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) -INSTANCE_VARIABLE(Int32) -INSTANCE_VARIABLE(Int64) -INSTANCE_VARIABLE(Word16) -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) - -instance Show Signature where - showsPrec d x = showParen (d > 10) $ - showString "Signature " . shows (strSignature x) -strSignature :: Signature -> Text -strSignature (Signature ts) = TL.concat $ map typeCode ts -instance Ord Signature where - compare = comparing strSignature -mkSignature :: Text -> Maybe Signature -mkSignature text = parsed where - just t = Just $ Signature [t] - fast = case TL.head text of - 'b' -> just DBusBoolean - 'y' -> just DBusByte - 'n' -> just DBusInt16 - 'i' -> just DBusInt32 - 'x' -> just DBusInt64 - 'q' -> just DBusWord16 - 'u' -> just DBusWord32 - 't' -> just DBusWord64 - 'd' -> just DBusDouble - 's' -> just DBusString - 'g' -> just DBusSignature - 'o' -> just DBusObjectPath - 'v' -> just DBusVariant - _ -> Nothing - slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text - sigParser = do - types <- P.many parseType - P.eof - return $ Signature types - parseType = parseAtom <|> parseContainer - parseContainer = - parseArray - <|> parseStruct - <|> (P.char 'v' >> return DBusVariant) - parseArray = do - P.char 'a' - parseDict <|> fmap DBusArray parseType - parseDict = do - P.char '{' - keyType <- parseAtom - valueType <- parseType - P.char '}' - return $ DBusDictionary keyType valueType - parseStruct = do - P.char '(' - types <- P.many parseType - P.char ')' - return $ DBusStructure types - parseAtom = - (P.char 'b' >> return DBusBoolean) - <|> (P.char 'y' >> return DBusByte) - <|> (P.char 'n' >> return DBusInt16) - <|> (P.char 'i' >> return DBusInt32) - <|> (P.char 'x' >> return DBusInt64) - <|> (P.char 'q' >> return DBusWord16) - <|> (P.char 'u' >> return DBusWord32) - <|> (P.char 't' >> return DBusWord64) - <|> (P.char 'd' >> return DBusDouble) - <|> (P.char 's' >> return DBusString) - <|> (P.char 'g' >> return DBusSignature) - <|> (P.char 'o' >> return DBusObjectPath) - parsed = case TL.length text of - 0 -> Just $ Signature [] - 1 -> fast - _ -> slow -mkSignature_ :: Text -> Signature -mkSignature_ = mkUnsafe "signature" mkSignature - -instance String.IsString Signature where - fromString = mkSignature_ . TL.pack -INSTANCE_VARIABLE(ObjectPath) -newtype ObjectPath = ObjectPath - { strObjectPath :: Text - } - deriving (Eq, Ord) - -instance Show ObjectPath where - showsPrec d (ObjectPath x) = showParen (d > 10) $ - showString "ObjectPath " . shows x - -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'] ++ "_" - path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char - path' = path >> P.eof >> return (ObjectPath s) - -mkObjectPath_ :: Text -> ObjectPath -mkObjectPath_ = mkUnsafe "object path" mkObjectPath -INSTANCE_VARIABLE(Array) -data Array - = VariantArray Type [Variant] - | ByteArray 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 - -arrayItems :: Array -> [Variant] -arrayItems (VariantArray _ xs) = xs -arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs -instance Show Array where - showsPrec d array = showParen (d > 10) $ - s "Array " . showSig . s " [" . s valueString . s "]" where - s = showString - 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 . ByteString.pack) (mapM fromVariant vs) - -arrayFromItems t vs = do - mkSignature (typeCode t) - 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 ByteString -arrayToBytes (ByteArray x) = Just x -arrayToBytes _ = Nothing - -arrayFromBytes :: ByteString -> Array -arrayFromBytes = ByteArray -instance Variable ByteString where - toVariant = toVariant . arrayFromBytes - fromVariant x = fromVariant x >>= arrayToBytes -instance Variable StrictByteString.ByteString where - toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] - fromVariant x = do - chunks <- ByteString.toChunks `fmap` fromVariant x - return $ StrictByteString.concat chunks -INSTANCE_VARIABLE(Dictionary) -data Dictionary = Dictionary - { dictionaryKeyType :: Type - , dictionaryValueType :: Type - , 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 - s = showString - 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 - mkSignature (typeCode kt) - mkSignature (typeCode vt) - - let sameType (k, v) = variantType k == kt && - variantType v == vt - 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 - pairs <- forM vs $ \(k, v) -> do - k' <- fromVariant k - 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 - struct <- fromVariant x - case struct of - Structure [k, v] -> Just (k, v) - _ -> Nothing - (kt, vt) <- case arrayType array of - DBusStructure [kt, vt] -> Just (kt, vt) - _ -> 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); \ - \ - instance Show TYPE where \ - { showsPrec d (TYPE x) = showParen (d > 10) $ \ - showString "TYPE " . shows x \ - }; \ - \ - instance String.IsString TYPE where \ - { fromString = mk/**/TYPE/**/_ . TL.pack }; \ - \ - instance Variable TYPE where \ - { toVariant = toVariant . str/**/TYPE \ - ; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \ - \ - mk/**/TYPE/**/_ :: Text -> TYPE; \ - mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE -NAME_TYPE(BusName, "bus name") - -mkBusName :: Text -> Maybe BusName -mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" - c' = c ++ ['0'..'9'] - parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) - unique = P.char ':' >> elems c' - 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 -mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - 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 -mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - name = P.oneOf c >> P.many (P.oneOf c') - parser = name >> P.eof >> return (MemberName s) diff --git a/hs/DBus/Types.hs b/hs/DBus/Types.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Types.hs @@ -0,0 +1,121 @@ + +#line 23 "src/types.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +#line 24 "src/types.anansi" +module DBus.Types ( + +#line 100 "src/types.anansi" + -- * Available types + Type (..) + , typeCode + +#line 176 "src/types.anansi" + -- * Variants + , Variant + , Variable (..) + +#line 248 "src/types.anansi" + , variantType + +#line 442 "src/types.anansi" + -- * Signatures + , Signature + , signatureTypes + , strSignature + +#line 714 "src/types.anansi" + , mkSignature + , mkSignature_ + +#line 789 "src/types.anansi" + -- * Object paths + , ObjectPath + , strObjectPath + , mkObjectPath + , mkObjectPath_ + +#line 839 "src/types.anansi" + -- * Arrays + , Array + , arrayType + , arrayItems + +#line 885 "src/types.anansi" + , toArray + , fromArray + , arrayFromItems + +#line 903 "src/types.anansi" + , arrayToBytes + , arrayFromBytes + +#line 967 "src/types.anansi" + -- * Dictionaries + , Dictionary + , dictionaryItems + , dictionaryKeyType + , dictionaryValueType + +#line 1044 "src/types.anansi" + , toDictionary + , fromDictionary + , dictionaryFromItems + +#line 1116 "src/types.anansi" + , dictionaryToArray + , arrayToDictionary + +#line 1133 "src/types.anansi" + -- * Structures + , Structure (..) + +#line 1174 "src/types.anansi" + -- * Names + +#line 1204 "src/types.anansi" + -- ** Bus names + , BusName + , strBusName + , mkBusName + , mkBusName_ + +#line 1257 "src/types.anansi" + -- ** Interface names + , InterfaceName + , strInterfaceName + , mkInterfaceName + , mkInterfaceName_ + +#line 1298 "src/types.anansi" + -- ** Error names + , ErrorName + , strErrorName + , mkErrorName + , mkErrorName_ + +#line 1334 "src/types.anansi" + -- ** Member names + , MemberName + , strMemberName + , mkMemberName + , mkMemberName_ + +#line 26 "src/types.anansi" + ) where +import DBus.Types.Internal diff --git a/hs/DBus/Types/Internal.cpphs b/hs/DBus/Types/Internal.cpphs new file mode 100644 --- /dev/null +++ b/hs/DBus/Types/Internal.cpphs @@ -0,0 +1,706 @@ + +#line 31 "src/types.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +#line 32 "src/types.anansi" + +#line 52 "src/introduction.anansi" +{-# LANGUAGE OverloadedStrings #-} + +#line 33 "src/types.anansi" + +#line 372 "src/types.anansi" +{-# LANGUAGE TypeSynonymInstances #-} + +#line 34 "src/types.anansi" +module DBus.Types.Internal where + +#line 56 "src/introduction.anansi" +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +#line 36 "src/types.anansi" + +#line 325 "src/types.anansi" +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +#line 359 "src/types.anansi" +import qualified Data.Text as T + +#line 433 "src/types.anansi" +import Data.Ord (comparing) + +#line 454 "src/types.anansi" +import Data.Text.Encoding (decodeUtf8) + +#line 513 "src/types.anansi" +import qualified Data.ByteString.Unsafe as B +import qualified Foreign as F +import System.IO.Unsafe (unsafePerformIO) + +#line 684 "src/types.anansi" +import Data.Text.Lazy.Encoding (encodeUtf8) + +#line 697 "src/types.anansi" +import DBus.Util (mkUnsafe) +import qualified Data.String as String + +#line 772 "src/types.anansi" +import Text.ParserCombinators.Parsec ((<|>)) +import qualified Text.ParserCombinators.Parsec as P +import DBus.Util (checkLength, parseMaybe) + +#line 978 "src/types.anansi" +import Data.List (intercalate) + +#line 995 "src/types.anansi" +import Control.Monad (unless) + +#line 1017 "src/types.anansi" +import Control.Arrow ((***)) +import qualified Data.Map as Map + +#line 1029 "src/types.anansi" +import Control.Monad (forM) + +#line 37 "src/types.anansi" +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 + +#line 52 "src/types.anansi" +data Type + = DBusBoolean + | DBusByte + | DBusInt16 + | DBusInt32 + | DBusInt64 + | DBusWord16 + | DBusWord32 + | DBusWord64 + | DBusDouble + | DBusString + | DBusSignature + | DBusObjectPath + | DBusVariant + | DBusArray Type + | DBusDictionary Type Type + | DBusStructure [Type] + deriving (Show, Eq) + +#line 73 "src/types.anansi" + +#line 27 "src/api-docs.anansi" +-- | \"Atomic\" types are any which can't contain any other types. Only +-- atomic types may be used as dictionary keys. + +#line 74 "src/types.anansi" +isAtomicType :: Type -> Bool +isAtomicType DBusBoolean = True +isAtomicType DBusByte = True +isAtomicType DBusInt16 = True +isAtomicType DBusInt32 = True +isAtomicType DBusInt64 = True +isAtomicType DBusWord16 = True +isAtomicType DBusWord32 = True +isAtomicType DBusWord64 = True +isAtomicType DBusDouble = True +isAtomicType DBusString = True +isAtomicType DBusSignature = True +isAtomicType DBusObjectPath = True +isAtomicType _ = False + +#line 94 "src/types.anansi" + +#line 32 "src/api-docs.anansi" +-- | Every type has an associated type code; a textual representation of +-- the type, useful for debugging. + +#line 95 "src/types.anansi" +typeCode :: Type -> Text + +#line 458 "src/types.anansi" +typeCode t = TL.fromChunks [decodeUtf8 $ typeCodeB t] + +typeCodeB :: Type -> B.ByteString +typeCodeB DBusBoolean = "b" +typeCodeB DBusByte = "y" +typeCodeB DBusInt16 = "n" +typeCodeB DBusInt32 = "i" +typeCodeB DBusInt64 = "x" +typeCodeB DBusWord16 = "q" +typeCodeB DBusWord32 = "u" +typeCodeB DBusWord64 = "t" +typeCodeB DBusDouble = "d" +typeCodeB DBusString = "s" +typeCodeB DBusSignature = "g" +typeCodeB DBusObjectPath = "o" +typeCodeB DBusVariant = "v" + +#line 480 "src/types.anansi" +typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t + +#line 487 "src/types.anansi" +typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"] + +#line 495 "src/types.anansi" +typeCodeB (DBusStructure ts) = B.concat $ + ["("] ++ map typeCodeB ts ++ [")"] + +#line 150 "src/types.anansi" + +#line 37 "src/api-docs.anansi" +-- | '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. + +#line 151 "src/types.anansi" +data Variant + = VarBoxBool Bool + | VarBoxWord8 Word8 + | VarBoxInt16 Int16 + | VarBoxInt32 Int32 + | VarBoxInt64 Int64 + | VarBoxWord16 Word16 + | VarBoxWord32 Word32 + | VarBoxWord64 Word64 + | VarBoxDouble Double + | VarBoxString Text + | VarBoxSignature Signature + | VarBoxObjectPath ObjectPath + | VarBoxVariant Variant + | VarBoxArray Array + | VarBoxDictionary Dictionary + | VarBoxStructure Structure + deriving (Eq) + +class Variable a where + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a + +#line 186 "src/types.anansi" +instance Show Variant where + showsPrec d var = showParen (d > 10) full where + full = s "Variant " . shows code . s " " . valueStr + code = typeCode $ variantType var + s = showString + valueStr = showsPrecVar 11 var + +showsPrecVar :: Int -> Variant -> ShowS +showsPrecVar d var = case var of + (VarBoxBool x) -> showsPrec d x + (VarBoxWord8 x) -> showsPrec d x + (VarBoxInt16 x) -> showsPrec d x + (VarBoxInt32 x) -> showsPrec d x + (VarBoxInt64 x) -> showsPrec d x + (VarBoxWord16 x) -> showsPrec d x + (VarBoxWord32 x) -> showsPrec d x + (VarBoxWord64 x) -> showsPrec d x + (VarBoxDouble x) -> showsPrec d x + (VarBoxString x) -> showsPrec d x + (VarBoxSignature x) -> showsPrec d x + (VarBoxObjectPath x) -> showsPrec d x + (VarBoxVariant x) -> showsPrec d x + (VarBoxArray x) -> showsPrec d x + (VarBoxDictionary x) -> showsPrec d x + (VarBoxStructure x) -> showsPrec d x + +#line 218 "src/types.anansi" + +#line 43 "src/api-docs.anansi" +-- | 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. + +#line 219 "src/types.anansi" +variantType :: Variant -> Type +variantType var = case var of + (VarBoxBool _) -> DBusBoolean + (VarBoxWord8 _) -> DBusByte + (VarBoxInt16 _) -> DBusInt16 + (VarBoxInt32 _) -> DBusInt32 + (VarBoxInt64 _) -> DBusInt64 + (VarBoxWord16 _) -> DBusWord16 + (VarBoxWord32 _) -> DBusWord32 + (VarBoxWord64 _) -> DBusWord64 + (VarBoxDouble _) -> DBusDouble + (VarBoxString _) -> DBusString + (VarBoxSignature _) -> DBusSignature + (VarBoxObjectPath _) -> DBusObjectPath + (VarBoxVariant _) -> DBusVariant + (VarBoxArray x) -> DBusArray (arrayType x) + (VarBoxDictionary x) -> let + keyT = dictionaryKeyType x + valueT = dictionaryValueType x + in DBusDictionary keyT valueT + (VarBoxStructure x) -> let + Structure items = x + in DBusStructure (map variantType items) + +variantSignature :: Variant -> Maybe Signature +variantSignature = mkBytesSignature . typeCodeB . variantType + +#line 255 "src/types.anansi" +#define INSTANCE_VARIABLE(TYPE) \ + instance Variable TYPE where \ + { toVariant = VarBox/**/TYPE \ + ; fromVariant (VarBox/**/TYPE x) = Just x \ + ; fromVariant _ = Nothing \ + } + +#line 266 "src/types.anansi" +INSTANCE_VARIABLE(Variant) + +#line 330 "src/types.anansi" +INSTANCE_VARIABLE(Bool) +INSTANCE_VARIABLE(Word8) +INSTANCE_VARIABLE(Int16) +INSTANCE_VARIABLE(Int32) +INSTANCE_VARIABLE(Int64) +INSTANCE_VARIABLE(Word16) +INSTANCE_VARIABLE(Word32) +INSTANCE_VARIABLE(Word64) +INSTANCE_VARIABLE(Double) + +#line 348 "src/types.anansi" +instance Variable TL.Text where + toVariant = VarBoxString + fromVariant (VarBoxString x) = Just x + fromVariant _ = Nothing + +#line 363 "src/types.anansi" +instance Variable T.Text where + toVariant = toVariant . TL.fromChunks . (:[]) + fromVariant = fmap (T.concat . TL.toChunks) . fromVariant + +#line 376 "src/types.anansi" +instance Variable String where + toVariant = toVariant . TL.pack + fromVariant = fmap TL.unpack . fromVariant + +#line 409 "src/types.anansi" +INSTANCE_VARIABLE(Signature) +data Signature = Signature { signatureTypes :: [Type] } + deriving (Eq) + +instance Show Signature where + showsPrec d x = showParen (d > 10) $ + showString "Signature " . shows (strSignature x) + +#line 422 "src/types.anansi" +bytesSignature :: Signature -> B.ByteString +bytesSignature (Signature ts) = B.concat $ map typeCodeB ts + +strSignature :: Signature -> Text +strSignature (Signature ts) = TL.concat $ map typeCode ts + +#line 437 "src/types.anansi" +instance Ord Signature where + compare = comparing strSignature + +#line 529 "src/types.anansi" +mkBytesSignature :: B.ByteString -> Maybe Signature +mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where + +#line 542 "src/types.anansi" + parseAtom c yes no = case c of + 0x62 -> yes DBusBoolean + 0x79 -> yes DBusByte + 0x6E -> yes DBusInt16 + 0x69 -> yes DBusInt32 + 0x78 -> yes DBusInt64 + 0x71 -> yes DBusWord16 + 0x75 -> yes DBusWord32 + 0x74 -> yes DBusWord64 + 0x64 -> yes DBusDouble + 0x73 -> yes DBusString + 0x67 -> yes DBusSignature + 0x6F -> yes DBusObjectPath + _ -> no + + fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of + 0x76 -> Just (Signature [DBusVariant]) + _ -> Nothing + +#line 532 "src/types.anansi" + +#line 563 "src/types.anansi" + slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature) + slow buf len = loop [] 0 where + loop acc ii | ii >= len = return . Just . Signature $ reverse acc + loop acc ii = do + c <- F.peekElemOff buf ii + let next t = loop (t : acc) (ii + 1) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + _ -> return Nothing + +#line 590 "src/types.anansi" + structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) + structure buf len = loop [] where + loop _ ii | ii >= len = return Nothing + loop acc ii = do + c <- F.peekElemOff buf ii + let next t = loop (t : acc) (ii + 1) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + -- ')' + 0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc)) + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + _ -> return Nothing + +#line 620 "src/types.anansi" + array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) + array _ len ii | ii >= len = return Nothing + array buf len ii = do + c <- F.peekElemOff buf ii + let next t = return $ Just (ii + 1, DBusArray t) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> return $ Just (ii', DBusArray t) + Nothing -> return Nothing + + -- '{' + 0x7B -> dict buf len (ii + 1) + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> return $ Just (ii', DBusArray t) + Nothing -> return Nothing + + _ -> return Nothing + +#line 649 "src/types.anansi" + dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) + dict _ len ii | ii + 1 >= len = return Nothing + dict buf len ii = do + c1 <- F.peekElemOff buf ii + c2 <- F.peekElemOff buf (ii + 1) + + let mt1 = parseAtom c1 Just Nothing + + let next t = return $ Just (ii + 2, t) + mt2 <- parseAtom c2 next $ case c2 of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> structure buf len (ii + 2) + + -- 'a' + 0x61 -> array buf len (ii + 2) + + _ -> return Nothing + + case mt2 of + Nothing -> return Nothing + Just (ii', t2) -> if ii' >= len + then return Nothing + else do + c3 <- F.peekElemOff buf ii' + return $ do + if c3 == 0x7D then Just () else Nothing + t1 <- mt1 + Just (ii' + 1, DBusDictionary t1 t2) + +#line 533 "src/types.anansi" + + 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 + +#line 688 "src/types.anansi" +mkSignature :: Text -> Maybe Signature +mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8 + +#line 702 "src/types.anansi" +mkSignature_ :: Text -> Signature +mkSignature_ = mkUnsafe "signature" mkSignature + +instance String.IsString Signature where + fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack + +#line 724 "src/types.anansi" +maybeValidType :: Type -> Maybe () +maybeValidType t = if B.length (typeCodeB t) > 255 + then Nothing + else Just () + +#line 745 "src/types.anansi" +INSTANCE_VARIABLE(ObjectPath) +newtype ObjectPath = ObjectPath + { strObjectPath :: Text + } + deriving (Eq, Ord) + +instance Show ObjectPath where + showsPrec d (ObjectPath x) = showParen (d > 10) $ + showString "ObjectPath " . shows x + +instance String.IsString ObjectPath where + fromString = mkObjectPath_ . TL.pack + +#line 778 "src/types.anansi" +mkObjectPath :: Text -> Maybe ObjectPath +mkObjectPath s = parseMaybe path' (TL.unpack s) where + c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char + path' = path >> P.eof >> return (ObjectPath s) + +mkObjectPath_ :: Text -> ObjectPath +mkObjectPath_ = mkUnsafe "object path" mkObjectPath + +#line 822 "src/types.anansi" +INSTANCE_VARIABLE(Array) +data Array + = VariantArray Type [Variant] + | ByteArray BL.ByteString + deriving (Eq) + + +#line 49 "src/api-docs.anansi" +-- | This is the type contained within the array, not the type of the array +-- itself. + +#line 829 "src/types.anansi" +arrayType :: Array -> Type +arrayType (VariantArray t _) = t +arrayType (ByteArray _) = DBusByte + +arrayItems :: Array -> [Variant] +arrayItems (VariantArray _ xs) = xs +arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs + +#line 849 "src/types.anansi" +instance Show Array where + showsPrec d array = showParen (d > 10) $ + s "Array " . showSig . s " [" . s valueString . s "]" where + s = showString + showSig = shows . typeCode . arrayType $ array + showVar var = showsPrecVar 0 var "" + valueString = intercalate ", " $ map showVar $ arrayItems array + +#line 863 "src/types.anansi" +arrayFromItems :: Type -> [Variant] -> Maybe Array +arrayFromItems DBusByte vs = fmap (ByteArray . BL.pack) (mapM fromVariant vs) + +arrayFromItems t vs = do + maybeValidType t + if all (\x -> variantType x == t) vs + then Just $ VariantArray t vs + else Nothing + +#line 877 "src/types.anansi" +toArray :: Variable a => Type -> [a] -> Maybe Array +toArray t = arrayFromItems t . map toVariant + +fromArray :: Variable a => Array -> Maybe [a] +fromArray = mapM fromVariant . arrayItems + +#line 894 "src/types.anansi" +arrayToBytes :: Array -> Maybe BL.ByteString +arrayToBytes (ByteArray x) = Just x +arrayToBytes _ = Nothing + +arrayFromBytes :: BL.ByteString -> Array +arrayFromBytes = ByteArray + +#line 911 "src/types.anansi" +instance Variable BL.ByteString where + toVariant = toVariant . arrayFromBytes + fromVariant x = fromVariant x >>= arrayToBytes + +#line 917 "src/types.anansi" +instance Variable B.ByteString where + toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x] + fromVariant = fmap (B.concat . BL.toChunks) . fromVariant + +#line 956 "src/types.anansi" +INSTANCE_VARIABLE(Dictionary) + +data Dictionary = Dictionary + { dictionaryKeyType :: Type + , dictionaryValueType :: Type + , dictionaryItems :: [(Variant, Variant)] + } + deriving (Eq) + +#line 982 "src/types.anansi" +instance Show Dictionary where + showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ + s "Dictionary " . showSig . s " {" . s valueString . s "}" where + s = showString + showSig = shows $ TL.append (typeCode kt) (typeCode vt) + valueString = intercalate ", " $ map showPair pairs + showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" + +#line 999 "src/types.anansi" +dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary +dictionaryFromItems kt vt pairs = do + unless (isAtomicType kt) Nothing + maybeValidType kt + maybeValidType vt + + let sameType (k, v) = variantType k == kt && + variantType v == vt + if all sameType pairs + then Just $ Dictionary kt vt pairs + else Nothing + +#line 1022 "src/types.anansi" +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 + +#line 1033 "src/types.anansi" +fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary + -> Maybe (Map.Map a b) +fromDictionary (Dictionary _ _ vs) = do + pairs <- forM vs $ \(k, v) -> do + k' <- fromVariant k + v' <- fromVariant v + return (k', v') + return $ Map.fromList pairs + +#line 1093 "src/types.anansi" +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] + +#line 1101 "src/types.anansi" +arrayToDictionary :: Array -> Maybe Dictionary +arrayToDictionary array = do + let toPair x = do + struct <- fromVariant x + case struct of + Structure [k, v] -> Just (k, v) + _ -> Nothing + (kt, vt) <- case arrayType array of + DBusStructure [kt, vt] -> Just (kt, vt) + _ -> Nothing + pairs <- mapM toPair $ arrayItems array + dictionaryFromItems kt vt pairs + +#line 1126 "src/types.anansi" +INSTANCE_VARIABLE(Structure) + +data Structure = Structure [Variant] + deriving (Show, Eq) + +#line 1153 "src/types.anansi" +#define NAME_TYPE(TYPE, NAME) \ + newtype TYPE = TYPE {str/**/TYPE :: Text} \ + deriving (Eq, Ord); \ + \ + instance Show TYPE where \ + { showsPrec d (TYPE x) = showParen (d > 10) $ \ + showString "TYPE " . shows x \ + }; \ + \ + instance String.IsString TYPE where \ + { fromString = mk/**/TYPE/**/_ . TL.pack }; \ + \ + instance Variable TYPE where \ + { toVariant = toVariant . str/**/TYPE \ + ; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \ + \ + mk/**/TYPE/**/_ :: Text -> TYPE; \ + mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE + +#line 1190 "src/types.anansi" +NAME_TYPE(BusName, "bus name") + +mkBusName :: Text -> Maybe BusName +mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) + unique = P.char ':' >> elems c' + wellKnown = elems c + elems start = elem' start >> P.many1 (P.char '.' >> elem' start) + elem' start = P.oneOf start >> P.many (P.oneOf c') + +#line 1245 "src/types.anansi" +NAME_TYPE(InterfaceName, "interface name") + +mkInterfaceName :: Text -> Maybe InterfaceName +mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + element = P.oneOf c >> P.many (P.oneOf c') + name = element >> P.many1 (P.char '.' >> element) + parser = name >> P.eof >> return (InterfaceName s) + +#line 1291 "src/types.anansi" +NAME_TYPE(ErrorName, "error name") + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + +#line 1323 "src/types.anansi" +NAME_TYPE(MemberName, "member name") + +mkMemberName :: Text -> Maybe MemberName +mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + name = P.oneOf c >> P.many (P.oneOf c') + parser = name >> P.eof >> return (MemberName s) 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,7 @@ + +#line 22 "src/util.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,13 +16,19 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 23 "src/util.anansi" module DBus.UUID ( UUID , toHex , fromHex ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + +#line 29 "src/util.anansi" 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,7 @@ + +#line 58 "src/util.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,8 +16,10 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 59 "src/util.anansi" module DBus.Util where -import Text.Parsec (Parsec, parse) +import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt) import Data.List (isPrefixOf) @@ -21,7 +27,7 @@ checkLength length' s | length s <= length' = Just s checkLength _ _ = Nothing -parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe :: Parser a -> String -> Maybe a parseMaybe p = either (const Nothing) Just . parse p "" mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b 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,7 @@ + +#line 117 "src/util.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,20 +16,32 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE TypeFamilies #-} + +#line 118 "src/util.anansi" module DBus.Util.MonadError - ( ErrorT (..) - , throwError + ( ErrorM (..) + , ErrorT (..) + , throwErrorM + , throwErrorT ) where -import Control.Monad.Trans.Class -import Control.Monad.State -import Control.Monad.Error.Class +newtype ErrorM e a = ErrorM { runErrorM :: Either e a } -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } +instance Functor (ErrorM e) where + fmap f m = ErrorM $ case runErrorM m of + Left err -> Left err + Right x -> Right $ f x -instance Functor m => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT +instance Monad (ErrorM e) where + return = ErrorM . Right + (>>=) m k = case runErrorM m of + Left err -> ErrorM $ Left err + Right x -> k x +throwErrorM :: e -> ErrorM e a +throwErrorM = ErrorM . Left + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + instance Monad m => Monad (ErrorT e m) where return = ErrorT . return . Right (>>=) m k = ErrorT $ do @@ -34,19 +50,5 @@ Left l -> return $ Left l Right r -> runErrorT $ k r -instance MonadTrans (ErrorT e) where - lift = ErrorT . liftM Right - -instance Monad m => MonadError (ErrorT e m) where - type ErrorType (ErrorT e m) = e - throwError = ErrorT . return . Left - catchError m h = ErrorT $ do - x <- runErrorT m - case x of - Left l -> runErrorT $ h l - Right r -> return $ Right r - -instance MonadState m => MonadState (ErrorT e m) where - type StateType (ErrorT e m) = StateType m - get = lift get - put = lift . put +throwErrorT :: Monad m => e -> ErrorT e m a +throwErrorT = ErrorT . return . Left 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,7 @@ + +#line 21 "src/wire.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,12 +16,26 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 22 "src/wire.anansi" module DBus.Wire ( + +#line 54 "src/wire.anansi" Endianness (..) + +#line 238 "src/wire.anansi" , MarshalError (..) + +#line 442 "src/wire.anansi" , UnmarshalError (..) + +#line 921 "src/wire.anansi" , marshalMessage + +#line 991 "src/wire.anansi" , unmarshalMessage + +#line 24 "src/wire.anansi" ) 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,7 @@ + +#line 31 "src/wire.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,9 +16,13 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 32 "src/wire.anansi" module DBus.Wire.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T + +#line 40 "src/wire.anansi" data Endianness = LittleEndian | BigEndian deriving (Show, Eq) @@ -26,7 +34,11 @@ decodeEndianness 108 = Just LittleEndian decodeEndianness 66 = Just BigEndian decodeEndianness _ = Nothing + +#line 69 "src/wire.anansi" alignment :: T.Type -> Word8 + +#line 451 "src/wire.anansi" alignment T.DBusByte = 1 alignment T.DBusWord16 = 2 alignment T.DBusWord32 = 4 @@ -35,14 +47,30 @@ alignment T.DBusInt32 = 4 alignment T.DBusInt64 = 8 alignment T.DBusDouble = 8 + +#line 548 "src/wire.anansi" alignment T.DBusBoolean = 4 + +#line 629 "src/wire.anansi" alignment T.DBusString = 4 alignment T.DBusObjectPath = 4 + +#line 671 "src/wire.anansi" alignment T.DBusSignature = 1 + +#line 687 "src/wire.anansi" alignment (T.DBusArray _) = 4 + +#line 769 "src/wire.anansi" alignment (T.DBusDictionary _ _) = 4 + +#line 786 "src/wire.anansi" alignment (T.DBusStructure _) = 8 + +#line 804 "src/wire.anansi" alignment T.DBusVariant = 1 + +#line 71 "src/wire.anansi" 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,7 @@ + +#line 89 "src/wire.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,94 +16,167 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 90 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL -import qualified Control.Monad.State as State -import qualified DBus.Util.MonadError as E + +#line 93 "src/wire.anansi" + +#line 105 "src/wire.anansi" +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B + +#line 514 "src/wire.anansi" import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE + +#line 599 "src/wire.anansi" import DBus.Wire.Unicode (maybeEncodeUtf8) -import Data.Text.Lazy.Encoding (encodeUtf8) + +#line 703 "src/wire.anansi" import qualified DBus.Constants as C + +#line 830 "src/wire.anansi" import qualified DBus.Message.Internal as M + +#line 845 "src/wire.anansi" import Data.Bits ((.|.)) import qualified Data.Set as Set + +#line 94 "src/wire.anansi" import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust) import Data.Word (Word8, Word32, Word64) -import Data.Int (Int16, Int32, Int64) +import Data.Int (Int64) import qualified DBus.Types as T -data MarshalState = MarshalState Endianness B.Builder !Word64 -type MarshalM = E.ErrorT MarshalError (State.State MarshalState) +import qualified DBus.Types.Internal as T + +#line 111 "src/wire.anansi" +data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64 + +data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState + type Marshal = MarshalM () +newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a } + +instance Monad MarshalM where + {-# INLINE return #-} + return a = MarshalM $ \_ s -> MarshalRR a s + + {-# INLINE (>>=) #-} + m >>= k = MarshalM $ \e s -> case unMarshalM m e s of + MarshalRL err -> MarshalRL err + MarshalRR a s' -> unMarshalM (k a) e s' + + {-# INLINE (>>) #-} + m >> k = MarshalM $ \e s -> case unMarshalM m e s of + MarshalRL err -> MarshalRL err + MarshalRR _ s' -> unMarshalM k e s' + +throwError :: MarshalError -> MarshalM a +throwError err = MarshalM $ \_ _ -> MarshalRL err + +{-# INLINE getState #-} +getState :: MarshalM MarshalState +getState = MarshalM $ \_ s -> MarshalRR s s + +{-# INLINE putState #-} +putState :: MarshalState -> MarshalM () +putState s = MarshalM $ \_ _ -> MarshalRR () s + +#line 148 "src/wire.anansi" runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString -runMarshal m e = case State.runState (E.runErrorT m) initialState of - (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) - (Left x, _) -> Left x - where initialState = MarshalState e B.empty 0 +runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of + MarshalRL err -> Left err + MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder + +#line 155 "src/wire.anansi" marshal :: T.Variant -> Marshal -marshal v = marshalType (T.variantType v) where - x :: T.Variable a => a - x = fromJust . T.fromVariant $ v - marshalType :: T.Type -> Marshal - marshalType T.DBusByte = append $ L.singleton x - marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x - marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x - marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x - marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) - marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) - marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) - marshalType T.DBusDouble = do - pad 8 - (MarshalState e _ _) <- State.get - let put = case e of - BigEndian -> IEEE.putFloat64be - LittleEndian -> IEEE.putFloat64le - let bytes = runPut $ put x - append bytes - marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 - marshalType T.DBusString = marshalText x - marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x - marshalType T.DBusSignature = marshalSignature x - marshalType (T.DBusArray _) = marshalArray x - marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) - marshalType (T.DBusStructure _) = do - let T.Structure vs = x +marshal v = case v of + +#line 483 "src/wire.anansi" + T.VarBoxWord8 x -> marshalWord8 x + T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x + T.VarBoxWord32 x -> marshalWord32 x + T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x + 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 + +#line 523 "src/wire.anansi" + T.VarBoxDouble x -> marshalDouble x + +#line 552 "src/wire.anansi" + T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0 + +#line 634 "src/wire.anansi" + T.VarBoxString x -> marshalText x + T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x + +#line 675 "src/wire.anansi" + T.VarBoxSignature x -> marshalSignature x + +#line 691 "src/wire.anansi" + T.VarBoxArray x -> marshalArray x + +#line 773 "src/wire.anansi" + T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x) + +#line 790 "src/wire.anansi" + T.VarBoxStructure (T.Structure vs) -> do pad 8 mapM_ marshal vs - marshalType T.DBusVariant = do - let rawSig = T.typeCode . T.variantType $ x - sig <- case T.mkSignature rawSig of + +#line 808 "src/wire.anansi" + T.VarBoxVariant x -> do + let textSig = T.typeCode . T.variantType $ x + sig <- case T.variantSignature x of Just x' -> return x' - Nothing -> E.throwError $ InvalidVariantSignature rawSig + Nothing -> throwError $ InvalidVariantSignature textSig marshalSignature sig marshal x -append :: L.ByteString -> Marshal -append bytes = do - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ B.fromLazyByteString bytes - count' = count + fromIntegral (L.length bytes) - State.put $ MarshalState e builder' count' + +#line 163 "src/wire.anansi" +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') + +#line 171 "src/wire.anansi" +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') + +#line 179 "src/wire.anansi" pad :: Word8 -> Marshal -pad count = do - (MarshalState _ _ existing) <- State.get - let padding' = fromIntegral $ padding existing count - append $ L.replicate padding' 0 +pad count = MarshalM $ \e s@(MarshalState _ existing) -> let + padding' = fromIntegral $ padding existing count + bytes = BS.replicate padding' 0 + in unMarshalM (appendS bytes) e s + +#line 190 "src/wire.anansi" marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do pad size - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ case e of - BigEndian -> be x - LittleEndian -> le x - let count' = count + fromIntegral size - State.put $ MarshalState e builder' count' + MarshalM $ \e (MarshalState builder count) -> let + builder' = B.append builder $ case e of + BigEndian -> be x + LittleEndian -> le x + size' = fromIntegral size + in MarshalRR () (MarshalState builder' (count + size')) + +#line 216 "src/wire.anansi" data MarshalError = MessageTooLong Word64 | ArrayTooLong Word64 @@ -119,55 +196,89 @@ ["Invalid variant signature: ", show x] show (InvalidText x) = concat ["Text cannot be marshaled: ", show x] + +#line 465 "src/wire.anansi" marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le + +#line 470 "src/wire.anansi" +{-# 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)) + +#line 527 "src/wire.anansi" +marshalDouble :: Double -> Marshal +marshalDouble x = do + pad 8 + MarshalM $ \e s -> let + put = case e of + BigEndian -> IEEE.putFloat64be + LittleEndian -> IEEE.putFloat64le + bytes = runPut $ put x + in unMarshalM (appendL bytes) e s + +#line 603 "src/wire.anansi" marshalText :: Text -> Marshal marshalText x = do bytes <- case maybeEncodeUtf8 x of Just x' -> return x' - Nothing -> E.throwError $ InvalidText x + Nothing -> throwError $ InvalidText x when (L.any (== 0) bytes) $ - E.throwError $ InvalidText x + throwError $ InvalidText x marshalWord32 . fromIntegral . L.length $ bytes - append bytes - append (L.singleton 0) + appendL bytes + marshalWord8 0 + +#line 651 "src/wire.anansi" marshalSignature :: T.Signature -> Marshal marshalSignature x = do - let bytes = encodeUtf8 . T.strSignature $ x - let size = fromIntegral . L.length $ bytes - append (L.singleton size) - append bytes - append (L.singleton 0) + let bytes = T.bytesSignature x + let size = fromIntegral . BS.length $ bytes + marshalWord8 size + appendS bytes + marshalWord8 0 + +#line 707 "src/wire.anansi" marshalArray :: T.Array -> Marshal marshalArray x = do (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x let arrayLen = L.length arrayBytes when (arrayLen > fromIntegral C.arrayMaximumLength) - (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + (throwError $ ArrayTooLong $ fromIntegral arrayLen) marshalWord32 $ fromIntegral arrayLen - append $ L.replicate arrayPadding 0 - append arrayBytes + appendL $ L.replicate arrayPadding 0 + appendL arrayBytes + +#line 719 "src/wire.anansi" getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where Just bytes = T.arrayToBytes x + +#line 725 "src/wire.anansi" getArrayBytes itemType x = do let vs = T.arrayItems x - s <- State.get - (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get - (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get + s <- getState + (MarshalState _ afterLength) <- marshalWord32 0 >> getState + (MarshalState _ afterPadding) <- pad (alignment itemType) >> getState - State.put $ MarshalState e B.empty afterPadding - (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get + putState $ MarshalState B.empty afterPadding + (MarshalState itemBuilder _) <- mapM_ marshal vs >> getState let itemBytes = B.toLazyByteString itemBuilder paddingSize = fromIntegral $ afterPadding - afterLength - State.put s + putState s return (paddingSize, itemBytes) + +#line 850 "src/wire.anansi" encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where flagValue M.NoReplyExpected = 0x1 flagValue M.NoAutoStart = 0x2 + +#line 868 "src/wire.anansi" encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x) = encodeField' 1 x encodeField (M.Interface x) = encodeField' 2 x @@ -183,49 +294,64 @@ [ T.toVariant code , T.toVariant $ T.toVariant x ] + +#line 925 "src/wire.anansi" + +#line 163 "src/api-docs.anansi" -- | 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. + +#line 926 "src/wire.anansi" marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where body = M.messageBody msg marshaler = do sig <- checkBodySig body - empty <- State.get + empty <- getState mapM_ marshal body - (MarshalState _ bodyBytesB _) <- State.get - State.put empty + (MarshalState bodyBytesB _) <- getState + putState empty marshalEndianness e let bodyBytes = B.toLazyByteString bodyBytesB marshalHeader msg serial sig $ fromIntegral . L.length $ bodyBytes pad 8 - append bodyBytes + appendL bodyBytes checkMaximumSize + +#line 946 "src/wire.anansi" checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let - sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs - invalid = E.throwError $ InvalidBodySignature sigStr - in case T.mkSignature sigStr of + textSig = TL.concat . map (T.typeCode . T.variantType) $ vs + bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs + invalid = throwError $ InvalidBodySignature textSig + in case T.mkBytesSignature bytesSig of Just x -> return x Nothing -> invalid + +#line 957 "src/wire.anansi" marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 -> Marshal marshalHeader msg serial bodySig bodyLength = do let fields = M.Signature bodySig : M.messageHeaderFields msg - marshal . T.toVariant . M.messageTypeCode $ msg - marshal . T.toVariant . encodeFlags . M.messageFlags $ msg - marshal . T.toVariant $ C.protocolVersion + marshalWord8 . M.messageTypeCode $ msg + marshalWord8 . encodeFlags . M.messageFlags $ msg + marshalWord8 C.protocolVersion marshalWord32 bodyLength - marshal . T.toVariant $ serial + marshalWord32 . M.serialValue $ serial let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] - marshal . T.toVariant . fromJust . T.toArray fieldType + marshalArray . fromJust . T.toArray fieldType $ map encodeField fields + +#line 972 "src/wire.anansi" marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness + +#line 977 "src/wire.anansi" checkMaximumSize :: Marshal checkMaximumSize = do - (MarshalState _ _ messageLength) <- State.get + (MarshalState _ messageLength) <- getState when (messageLength > fromIntegral C.messageMaximumLength) - (E.throwError $ MessageTooLong $ fromIntegral messageLength) + (throwError $ MessageTooLong $ fromIntegral messageLength) 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,7 @@ + +#line 574 "src/wire.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,6 +16,8 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 575 "src/wire.anansi" 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,7 @@ + +#line 246 "src/wire.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,39 +16,102 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 247 "src/wire.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 248 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL -import qualified Control.Monad.State as State -import Control.Monad.Trans.Class (lift) + +#line 251 "src/wire.anansi" + +#line 262 "src/wire.anansi" +import Control.Monad (liftM) import qualified DBus.Util.MonadError as E -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +#line 364 "src/wire.anansi" import qualified Data.Binary.Get as G + +#line 519 "src/wire.anansi" import qualified Data.Binary.IEEE754 as IEEE + +#line 616 "src/wire.anansi" import DBus.Wire.Unicode (maybeDecodeUtf8) + +#line 834 "src/wire.anansi" import qualified DBus.Message.Internal as M + +#line 840 "src/wire.anansi" import Data.Bits ((.&.)) import qualified Data.Set as Set + +#line 987 "src/wire.anansi" import qualified DBus.Constants as C -import Control.Monad (when, unless, liftM) + +#line 252 "src/wire.anansi" +import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64) import DBus.Wire.Internal -import qualified DBus.Types as T -data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 -type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) -runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a -runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where - state = UnmarshalState e bytes 0 +import qualified DBus.Types.Internal as T + +#line 272 "src/wire.anansi" +data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64 + +data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState + +newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a } + +instance Monad Unmarshal where + {-# INLINE return #-} + return a = Unmarshal $ \_ s -> UnmarshalRR a s + + {-# INLINE (>>=) #-} + m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of + UnmarshalRL err -> UnmarshalRL err + UnmarshalRR a s' -> unUnmarshal (k a) e s' + + {-# INLINE (>>) #-} + m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of + UnmarshalRL err -> UnmarshalRL err + UnmarshalRR _ s' -> unUnmarshal k e s' + +throwError :: UnmarshalError -> Unmarshal a +throwError err = Unmarshal $ \_ _ -> UnmarshalRL err + +{-# INLINE getState #-} +getState :: Unmarshal UnmarshalState +getState = Unmarshal $ \_ s -> UnmarshalRR s s + +{-# INLINE putState #-} +putState :: UnmarshalState -> Unmarshal () +putState s = Unmarshal $ \_ _ -> UnmarshalRR () s + +#line 305 "src/wire.anansi" +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 + +#line 312 "src/wire.anansi" unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes unmarshalType :: T.Type -> Unmarshal T.Variant -unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 + +#line 493 "src/wire.anansi" +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 unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le @@ -60,76 +127,104 @@ unmarshalType T.DBusInt64 = do x <- unmarshalGet 8 G.getWord64be G.getWord64le return . T.toVariant $ (fromIntegral x :: Int64) + +#line 539 "src/wire.anansi" unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le + +#line 556 "src/wire.anansi" unmarshalType T.DBusBoolean = unmarshalWord32 >>= fromMaybeU' "boolean" (\x -> case x of 0 -> Just False 1 -> Just True _ -> Nothing) -unmarshalType T.DBusString = fmap T.toVariant unmarshalText +#line 639 "src/wire.anansi" +unmarshalType T.DBusString = liftM T.toVariant unmarshalText + unmarshalType T.DBusObjectPath = unmarshalText >>= fromMaybeU' "object path" T.mkObjectPath -unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature -unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t + +#line 679 "src/wire.anansi" +unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature + +#line 695 "src/wire.anansi" +unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t + +#line 777 "src/wire.anansi" unmarshalType (T.DBusDictionary kt vt) = do let pairType = T.DBusStructure [kt, vt] array <- unmarshalArray pairType fromMaybeU' "dictionary" T.arrayToDictionary array + +#line 796 "src/wire.anansi" unmarshalType (T.DBusStructure ts) = do skipPadding 8 - fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts + +#line 818 "src/wire.anansi" unmarshalType T.DBusVariant = do let getType sig = case T.signatureTypes sig of [t] -> Just t _ -> Nothing t <- fromMaybeU "variant signature" getType =<< unmarshalSignature - T.toVariant `fmap` unmarshalType t -consume :: Word64 -> Unmarshal L.ByteString -consume count = do - (UnmarshalState e bytes offset) <- State.get - let (x, bytes') = L.splitAt (fromIntegral count) bytes - unless (L.length x == fromIntegral count) $ - E.throwError $ UnexpectedEOF offset - - State.put $ UnmarshalState e bytes' (offset + count) - return x + T.toVariant `liftM` unmarshalType t + +#line 322 "src/wire.anansi" +{-# INLINE consume #-} +consume :: Word64 -> Unmarshal BL.ByteString +consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let + count' = fromIntegral count + (x, bytes') = BL.splitAt count' bytes + in if BL.length x == count' + then UnmarshalRR x (UnmarshalState bytes' (offset + count)) + else UnmarshalRL $ UnexpectedEOF offset + +#line 333 "src/wire.anansi" skipPadding :: Word8 -> Unmarshal () skipPadding count = do - (UnmarshalState _ _ offset) <- State.get + (UnmarshalState _ offset) <- getState bytes <- consume $ padding offset count - unless (L.all (== 0) bytes) $ - E.throwError $ InvalidPadding offset + unless (BL.all (== 0) bytes) $ + throwError $ InvalidPadding offset + +#line 342 "src/wire.anansi" skipTerminator :: Unmarshal () skipTerminator = do - (UnmarshalState _ _ offset) <- State.get + (UnmarshalState _ offset) <- getState bytes <- consume 1 - unless (L.all (== 0) bytes) $ - E.throwError $ MissingTerminator offset + unless (BL.all (== 0) bytes) $ + throwError $ MissingTerminator offset + +#line 351 "src/wire.anansi" fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of Just x' -> return x' - Nothing -> E.throwError . Invalid label . TL.pack . show $ x + Nothing -> throwError . Invalid label . TL.pack . show $ x fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a -> Unmarshal T.Variant fromMaybeU' label f x = do x' <- fromMaybeU label f x return $ T.toVariant x' + +#line 368 "src/wire.anansi" unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do skipPadding count - (UnmarshalState e _ _) <- State.get bs <- consume . fromIntegral $ count - let get' = case e of - BigEndian -> be - LittleEndian -> le - return $ G.runGet get' bs + + Unmarshal $ \e s -> let + get = case e of + BigEndian -> be + LittleEndian -> le + in UnmarshalRR (G.runGet get bs) s unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a -> Unmarshal T.Variant -unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le +unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le + +#line 385 "src/wire.anansi" untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do done <- test @@ -139,6 +234,8 @@ x <- comp xs <- untilM test comp return $ x:xs + +#line 412 "src/wire.anansi" data UnmarshalError = UnsupportedProtocolVersion Word8 | UnexpectedEOF Word64 @@ -166,46 +263,60 @@ show (MissingTerminator pos) = concat ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" + +#line 478 "src/wire.anansi" unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le + +#line 620 "src/wire.anansi" unmarshalText :: Unmarshal Text unmarshalText = do byteCount <- unmarshalWord32 bytes <- consume . fromIntegral $ byteCount skipTerminator fromMaybeU "text" maybeDecodeUtf8 bytes + +#line 661 "src/wire.anansi" unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do - byteCount <- L.head `fmap` consume 1 - bytes <- consume $ fromIntegral byteCount - sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes + byteCount <- BL.head `liftM` consume 1 + lazy <- consume $ fromIntegral byteCount skipTerminator - fromMaybeU "signature" T.mkSignature sigText + let bytes = B.concat $ BL.toChunks lazy + fromMaybeU "signature" T.mkBytesSignature bytes + +#line 744 "src/wire.anansi" unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do byteCount <- unmarshalWord32 - T.arrayFromBytes `fmap` consume (fromIntegral byteCount) + T.arrayFromBytes `liftM` consume (fromIntegral byteCount) + +#line 751 "src/wire.anansi" unmarshalArray itemType = do let getOffset = do - (UnmarshalState _ _ o) <- State.get + (UnmarshalState _ o) <- getState return o byteCount <- unmarshalWord32 skipPadding (alignment itemType) start <- getOffset let end = start + fromIntegral byteCount - vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + vs <- untilM (liftM (>= end) getOffset) (unmarshalType itemType) end' <- getOffset when (end' > end) $ - E.throwError ArraySizeMismatch + throwError ArraySizeMismatch fromMaybeU "array" (T.arrayFromItems itemType) vs + +#line 857 "src/wire.anansi" 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 :: Monad m => T.Structure - -> E.ErrorT UnmarshalError m [M.HeaderField] + +#line 886 "src/wire.anansi" +decodeField :: T.Structure + -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of (1, x) -> decodeField' x M.Path "path" (2, x) -> decodeField' x M.Interface "interface" @@ -217,68 +328,106 @@ (8, x) -> decodeField' x M.Signature "signature" _ -> return [] -decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text - -> E.ErrorT UnmarshalError m [b] +decodeField' :: T.Variable a => T.Variant -> (a -> b) -> Text + -> E.ErrorM UnmarshalError [b] decodeField' x f label = case T.fromVariant x of Just x' -> return [f x'] - Nothing -> E.throwError $ InvalidHeaderField label x + Nothing -> E.throwErrorM $ InvalidHeaderField label x + +#line 907 "src/wire.anansi" 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 + +#line 995 "src/wire.anansi" + +#line 169 "src/api-docs.anansi" -- | Read bytes from a monad until a complete message has been received. -unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) + +#line 996 "src/wire.anansi" +unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do - let getBytes = lift . getBytes' + let getBytes = E.ErrorT . liftM Right . getBytes' + +#line 1011 "src/wire.anansi" let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16 - let messageVersion = L.index fixedBytes 3 + +#line 1020 "src/wire.anansi" + let messageVersion = BL.index fixedBytes 3 when (messageVersion /= C.protocolVersion) $ - E.throwError $ UnsupportedProtocolVersion messageVersion - let eByte = L.index fixedBytes 0 + E.throwErrorT $ UnsupportedProtocolVersion messageVersion + +#line 1028 "src/wire.anansi" + let eByte = BL.index fixedBytes 0 endianness <- case decodeEndianness eByte of Just x' -> return x' - Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte + Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte + +#line 1038 "src/wire.anansi" let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of Right x' -> return x' - Left e -> E.throwError e + Left e -> E.throwErrorT e fixed <- unmarshal' fixedSig fixedBytes let typeCode = fromJust . T.fromVariant $ fixed !! 1 let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 let bodyLength = fromJust . T.fromVariant $ fixed !! 4 let serial = fromJust . T.fromVariant $ fixed !! 5 + +#line 1053 "src/wire.anansi" let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 + +#line 1002 "src/wire.anansi" + +#line 1060 "src/wire.anansi" let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount - let headerBytes = L.append fixedBytes fieldBytes + let headerBytes = BL.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes + +#line 1069 "src/wire.anansi" let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray - fields <- concat `liftM` mapM decodeField fieldStructures + fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of + Left err -> E.throwErrorT err + Right x -> return x + +#line 1003 "src/wire.anansi" + +#line 1080 "src/wire.anansi" let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 getBytes . fromIntegral $ bodyPadding + +#line 1091 "src/wire.anansi" let bodySig = findBodySignature fields + +#line 1097 "src/wire.anansi" bodyBytes <- getBytes bodyLength body <- unmarshal' bodySig bodyBytes - y <- case buildReceivedMessage typeCode fields of - EitherM (Right x) -> return x - EitherM (Left x) -> E.throwError $ MissingHeaderField x + +#line 1004 "src/wire.anansi" + +#line 1105 "src/wire.anansi" + y <- case E.runErrorM $ buildReceivedMessage typeCode fields of + Right x -> return x + Left err -> E.throwErrorT $ MissingHeaderField err return $ y serial flags body + +#line 1085 "src/wire.anansi" findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where signature = listToMaybe [x | M.Signature x <- fields] -newtype EitherM a b = EitherM (Either a b) -instance Monad (EitherM a) where - return = EitherM . Right - (EitherM (Left x)) >>= _ = EitherM (Left x) - (EitherM (Right x)) >>= k = k x -buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text +#line 1114 "src/wire.anansi" +buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) + +#line 1122 "src/wire.anansi" buildReceivedMessage 1 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -288,6 +437,8 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodCall path member iface dest flags body in M.ReceivedMethodCall serial sender msg + +#line 1136 "src/wire.anansi" buildReceivedMessage 2 fields = do replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] return $ \serial _ body -> let @@ -295,6 +446,8 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.MethodReturn replySerial dest body in M.ReceivedMethodReturn serial sender msg + +#line 1148 "src/wire.anansi" buildReceivedMessage 3 fields = do name <- require "error name" [x | M.ErrorName x <- fields] replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] @@ -303,6 +456,8 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Error name replySerial dest body in M.ReceivedError serial sender msg + +#line 1161 "src/wire.anansi" buildReceivedMessage 4 fields = do path <- require "path" [x | M.Path x <- fields] member <- require "member name" [x | M.Member x <- fields] @@ -312,10 +467,14 @@ sender = listToMaybe [x | M.Sender x <- fields] msg = M.Signal path member iface dest body in M.ReceivedSignal serial sender msg + +#line 1175 "src/wire.anansi" 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] -> EitherM Text a + +#line 1182 "src/wire.anansi" +require :: Text -> [a] -> E.ErrorM Text a require _ (x:_) = return x -require label _ = EitherM $ Left label +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,7 @@ + +#line 64 "src/introduction.anansi" + +#line 30 "src/introduction.anansi" -- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,8 +16,16 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + +#line 65 "src/introduction.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} + +#line 66 "src/introduction.anansi" module Main (tests, main) where + +#line 159 "src/util.anansi" import Test.QuickCheck import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -40,8 +52,12 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I +#line 68 "src/introduction.anansi" + tests :: [F.Test] tests = [ F.testGroup "dummy" [] + +#line 384 "src/types.anansi" , F.testGroup "String" [ testProperty "String -> strict Text" $ funEq (fromVariant . toVariant) (Just . T.pack) @@ -56,19 +72,27 @@ , testProperty "Strict Text <- lazy Text" $ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) ] + +#line 736 "src/types.anansi" , F.testGroup "Signature" [ testProperty "Signature identity" $ funEq (mkSignature . strSignature) Just ] + +#line 806 "src/types.anansi" , F.testGroup "ObjectPath" [ testProperty "ObjectPath identity" $ funEq (mkObjectPath . strObjectPath) Just ] + +#line 942 "src/types.anansi" , F.testGroup "Array" [ testProperty "Array identity" $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) , testProperty "Array homogeneity" prop_ArrayHomogeneous ] + +#line 1071 "src/types.anansi" , F.testGroup "Dictionary" [ testProperty "Dictionary identity" $ \x -> Just x == dictionaryFromItems @@ -82,22 +106,32 @@ , testProperty "Dictionary <-> Array conversion" $ funEq (arrayToDictionary . dictionaryToArray) Just ] + +#line 1232 "src/types.anansi" , F.testGroup "BusName" [ testProperty "BusName identity" $ funEq (mkBusName . strBusName) Just ] + +#line 1279 "src/types.anansi" , F.testGroup "InterfaceName" [ testProperty "InterfaceName identity" $ funEq (mkInterfaceName . strInterfaceName) Just ] + +#line 1311 "src/types.anansi" , F.testGroup "ErrorName" [ testProperty "ErrorName identity" $ funEq (mkErrorName . strErrorName) Just ] + +#line 1354 "src/types.anansi" , F.testGroup "MemberName" [ testProperty "MemberName identity" $ funEq (mkMemberName . strMemberName) Just ] + +#line 1223 "src/wire.anansi" , F.testGroup "Wire format" [ testProperty "Marshal -> Ummarshal" prop_Unmarshal , F.testGroup "Messages" @@ -107,6 +141,8 @@ , testProperty "Signals" prop_WireSignal ] ] + +#line 177 "src/addresses.anansi" , F.testGroup "Addresses" [ testProperty "Address identity" $ \x -> mkAddresses (strAddress x) == Just [x] @@ -137,6 +173,8 @@ , test "no param" $ isNothing . mkAddresses $ "a:," ] ] + +#line 508 "src/introspection.anansi" , F.testGroup "Introspection" [ testProperty "Generate -> Parse" $ \x@(I.Object path _ _) -> let @@ -145,10 +183,14 @@ parsed = I.fromXML path xml' in isJust xml ==> I.fromXML path xml' == Just x ] + +#line 72 "src/introduction.anansi" ] main :: IO () main = F.defaultMain tests + +#line 106 "src/types.anansi" instance Arbitrary Type where arbitrary = oneof [atomicType, containerType] @@ -179,6 +221,8 @@ return $ DBusDictionary kt vt 2 -> fmap DBusStructure $ halfSized arbitrary 3 -> return DBusVariant + +#line 272 "src/types.anansi" instance Arbitrary Variant where arbitrary = arbitrary >>= genVariant @@ -200,14 +244,20 @@ (DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) (DBusStructure _) -> fmap toVariant (arbitrary :: Gen Structure) DBusVariant -> fmap toVariant (arbitrary :: Gen Variant) + +#line 731 "src/types.anansi" instance Arbitrary Signature where arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary + +#line 797 "src/types.anansi" 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)) + +#line 926 "src/types.anansi" instance Arbitrary Array where arbitrary = do t <- atomicType @@ -221,6 +271,8 @@ firstType = if null types then DBusByte else head types + +#line 1053 "src/types.anansi" instance Arbitrary Dictionary where arbitrary = do kt <- atomicType @@ -236,8 +288,12 @@ vType = dictionaryValueType x correctType (k, v) = variantType k == kType && variantType v == vType + +#line 1138 "src/types.anansi" instance Arbitrary Structure where arbitrary = fmap Structure $ halfSized arbitrary + +#line 1212 "src/types.anansi" instance Arbitrary BusName where arbitrary = sizedText 255 (oneof [unique, wellKnown]) where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" @@ -255,6 +311,8 @@ x <- elements start xs <- atLeast 0 (elements c') return (x:xs) + +#line 1265 "src/types.anansi" instance Arbitrary InterfaceName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -266,8 +324,12 @@ x <- elements c xs <- atLeast 0 (elements c') return (x:xs) + +#line 1306 "src/types.anansi" instance Arbitrary ErrorName where arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary + +#line 1342 "src/types.anansi" instance Arbitrary MemberName where arbitrary = sizedText 255 genName where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" @@ -277,10 +339,16 @@ x <- elements c xs <- atLeast 0 (elements c') return . TL.pack $ (x:xs) + +#line 73 "src/messages.anansi" instance Arbitrary Flag where arbitrary = elements [NoReplyExpected, NoAutoStart] + +#line 131 "src/messages.anansi" instance Arbitrary Serial where arbitrary = fmap Serial arbitrary + +#line 173 "src/messages.anansi" instance Arbitrary MethodCall where arbitrary = do path <- arbitrary @@ -290,12 +358,16 @@ flags <- fmap Set.fromList arbitrary Structure body <- arbitrary return $ MethodCall path member iface dest flags body + +#line 210 "src/messages.anansi" instance Arbitrary MethodReturn where arbitrary = do serial <- arbitrary dest <- arbitrary Structure body <- arbitrary return $ MethodReturn serial dest body + +#line 261 "src/messages.anansi" instance Arbitrary Error where arbitrary = do name <- arbitrary @@ -303,6 +375,8 @@ dest <- arbitrary Structure body <- arbitrary return $ Error name serial dest body + +#line 300 "src/messages.anansi" instance Arbitrary Signal where arbitrary = do path <- arbitrary @@ -311,8 +385,12 @@ dest <- arbitrary Structure body <- arbitrary return $ Signal path member iface dest body + +#line 58 "src/wire.anansi" instance Arbitrary Endianness where arbitrary = elements [LittleEndian, BigEndian] + +#line 1188 "src/wire.anansi" prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where sig = mkSignature . typeCode . variantType $ x @@ -345,6 +423,8 @@ prop_WireSignal e serial msg = prop_MarshalMessage e serial msg $ ReceivedSignal serial Nothing msg + +#line 138 "src/addresses.anansi" instance Arbitrary Address where arbitrary = genAddress where optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." @@ -381,6 +461,8 @@ let addrStr = concat [m, ":", params, extraSemicolon] let Just [addr] = mkAddresses $ TL.pack addrStr return addr + +#line 443 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do @@ -443,6 +525,8 @@ [[], [I.Read], [I.Write], [I.Read, I.Write]] return $ I.Property (TL.pack name) sig access + +#line 187 "src/util.anansi" halfSized :: Gen a -> Gen a halfSized gen = sized $ \n -> if n > 0 then resize (n `div` 2) gen @@ -466,9 +550,13 @@ isRight :: Either a b -> Bool isRight = either (const False) (const True) + +#line 216 "src/util.anansi" 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 + +#line 225 "src/util.anansi" instance Arbitrary Word8 where arbitrary = arbitraryBoundedIntegral shrink = shrinkIntegral diff --git a/src/addresses.anansi b/src/addresses.anansi --- a/src/addresses.anansi +++ b/src/addresses.anansi @@ -30,8 +30,8 @@ import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf) -import qualified Text.Parsec as P -import Text.Parsec ((<|>)) +import qualified Text.ParserCombinators.Parsec as P +import Text.ParserCombinators.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe) : diff --git a/src/authentication.anansi b/src/authentication.anansi --- a/src/authentication.anansi +++ b/src/authentication.anansi @@ -44,6 +44,7 @@ :d authentication imports import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString +import Data.ByteString.Lazy.Char8 () import qualified DBus.UUID as UUID : diff --git a/src/connections.anansi b/src/connections.anansi --- a/src/connections.anansi +++ b/src/connections.anansi @@ -190,7 +190,7 @@ value must be converted from host order using {\tt Data.Binary}. :d connection imports -import qualified Text.Parsec as P +import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) @@ -202,7 +202,10 @@ P.eof let value = read chars :: Integer unless (value > 0 && value <= 65535) $ - P.parserFail "bad port" >> return () + -- Calling 'fail' is acceptable here, because Parsec 2 + -- offers no other error reporting mechanism, and + -- implements 'fail'. + fail "bad port" let word = fromIntegral value return $ runGet getWord16host (runPut (putWord16be word)) : diff --git a/src/introspection.anansi b/src/introspection.anansi --- a/src/introspection.anansi +++ b/src/introspection.anansi @@ -25,18 +25,18 @@ - - - - - - - - - - - - + + + + + + + + + + + + \end{verbatim} @@ -59,13 +59,6 @@ import qualified DBus.Types as T : -HaXml is used to do the heavy lifting of XML parsing because HXT cannot -be combined with Parsec 3. - -:d introspection imports -import qualified Text.XML.HaXml as H -: - \subsection{Data types} :f DBus/Introspection.hs @@ -93,37 +86,71 @@ \subsection{Parsing XML} -The root {\tt node} is special, in that it's the only {\tt node} which is -not required to have a {\tt name} attribute. If the root has no {\tt name}, -its path will default to the path of the introspected object. - If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the elements directly accessed by the parser, no effort is made to check the document's validity because there is no DTD as of yet. -:d introspection imports -import Text.XML.HaXml.Parse (xmlParse') -import DBus.Util (eitherToMaybe) -: - :f DBus/Introspection.hs fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do - doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text - let (H.Document _ _ root _) = doc + root <- parseElement text parseRoot path root : +LibXML's event-based parsing is used to convert the input into a list of +events. DBus's introspection format doesn't use any character data, so only +the element attributes and nesting are preserved. + +:d introspection imports +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 Data.Text.Encoding (encodeUtf8) +: + +:f DBus/Introspection.hs +parseElement :: Text -> Maybe X.Element +parseElement text = runST $ do + stackRef <- ST.newSTRef [([], [])] + let callbacks = SAX.ParserCallbacks + { SAX.parsedBeginElement = \_ attrs -> do + ST.modifySTRef stackRef ((attrs, []):) + , SAX.parsedEndElement = \name -> do + stack <- ST.readSTRef stackRef + let (attrs, children'):stack' = stack + let e = X.Element name attrs (map X.NodeElement (reverse children')) + let (pAttrs, pChildren):stack'' = stack' + let parent = (pAttrs, e:pChildren) + ST.writeSTRef stackRef (parent:stack'') + , SAX.parsedCharacters = \_ -> return () + , SAX.parsedComment = \_ -> return () + , SAX.parsedProcessingInstruction = \_ -> return () + } + let onError _ = ST.writeSTRef stackRef [] + p <- SAX.newParser callbacks onError Nothing + mapM_ (SAX.parse p . encodeUtf8) $ TL.toChunks text + SAX.parseComplete p + stack <- ST.readSTRef stackRef + return $ case stack of + [] -> Nothing + (_, children'):_ -> Just $ head children' +: + +The root {\tt node} is special, in that it's the only {\tt node} which is +not required to have a {\tt name} attribute. If the root has no {\tt name}, +its path will default to the path of the introspected object. + Even though the root object's {\tt name} is optional, if present, it must still be a valid object path. :f DBus/Introspection.hs -parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object +parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do - path <- case getAttr "name" e of + path <- case getattrM "name" e of Nothing -> Just defaultPath Just x -> T.mkObjectPath x - parseObject' path e + parseObject path e : Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name} @@ -131,37 +158,37 @@ the root object's path. :f DBus/Introspection.hs -parseChild :: T.ObjectPath -> H.Element a -> Maybe Object +parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do let parentPath' = case T.strObjectPath parentPath of "/" -> "/" x -> TL.append x "/" - pathSegment <- getAttr "name" e + pathSegment <- getattrM "name" e path <- T.mkObjectPath $ TL.append parentPath' pathSegment - parseObject' path e + parseObject path e : Other than the name, both root and non-root {\tt nodes} have identical contents. They may contain interface definitions, and child {\tt node}s. :f DBus/Introspection.hs -parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object -parseObject' path e@(H.Elem "node" _ _) = do - interfaces <- children parseInterface (H.tag "interface") e - children' <- children (parseChild path) (H.tag "node") 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 +parseObject _ _ = Nothing : Interfaces may contain methods, signals, and properties. :f DBus/Introspection.hs -parseInterface :: H.Element a -> Maybe Interface +parseInterface :: X.Element -> Maybe Interface parseInterface e = do - name <- T.mkInterfaceName =<< getAttr "name" e - methods <- children parseMethod (H.tag "method") e - signals <- children parseSignal (H.tag "signal") e - properties <- children parseProperty (H.tag "property") e + name <- T.mkInterfaceName =<< getattrM "name" e + methods <- children parseMethod (named "method") e + signals <- children parseSignal (named "signal") e + properties <- children parseProperty (named "property") e return $ Interface name methods signals properties : @@ -169,9 +196,9 @@ if no direction is specified. :f DBus/Introspection.hs -parseMethod :: H.Element a -> Maybe Method +parseMethod :: X.Element -> Maybe Method parseMethod e = do - name <- T.mkMemberName =<< getAttr "name" e + name <- T.mkMemberName =<< getattrM "name" e paramsIn <- children parseParameter (isParam ["in", ""]) e paramsOut <- children parseParameter (isParam ["out"]) e return $ Method name paramsIn paramsOut @@ -180,9 +207,9 @@ Signals are similar to methods, except they have no ``in'' parameters. :f DBus/Introspection.hs -parseSignal :: H.Element a -> Maybe Signal +parseSignal :: X.Element -> Maybe Signal parseSignal e = do - name <- T.mkMemberName =<< getAttr "name" e + name <- T.mkMemberName =<< getattrM "name" e params <- children parseParameter (isParam ["out", ""]) e return $ Signal name params : @@ -190,17 +217,17 @@ A parameter has a free-form name, and a single valid type. :f DBus/Introspection.hs -parseParameter :: H.Element a -> Maybe Parameter +parseParameter :: X.Element -> Maybe Parameter parseParameter e = do - let name = getAttr' "name" e + let name = getattr "name" e sig <- parseType e return $ Parameter name sig : :f DBus/Introspection.hs -parseType :: H.Element a -> Maybe T.Signature +parseType :: X.Element -> Maybe T.Signature parseType e = do - sig <- T.mkSignature =<< getAttr "type" e + sig <- T.mkSignature =<< getattrM "type" e case T.signatureTypes sig of [_] -> Just sig _ -> Nothing @@ -210,11 +237,11 @@ Each property may be read, written, or both, and has an associated type. :f DBus/Introspection.hs -parseProperty :: H.Element a -> Maybe Property +parseProperty :: X.Element -> Maybe Property parseProperty e = do - let name = getAttr' "name" e + let name = getattr "name" e sig <- parseType e - access <- case getAttr' "access" e of + access <- case getattr "access" e of "" -> Just [] "read" -> Just [Read] "write" -> Just [Write] @@ -223,182 +250,191 @@ return $ Property name sig access : -HaXml doesn't seem to have any way to retrieve the ``real'' value of an -attribute, so {\tt attrValue} implements this. - :d introspection imports -import Data.Char (chr) +import Control.Monad ((>=>)) +import Data.Maybe (fromMaybe, listToMaybe) : :f DBus/Introspection.hs -attrValue :: H.AttValue -> Maybe Text -attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where - (H.AttValue parts) = attr - - unescape (Left x) = Just x - unescape (Right (H.RefEntity x)) = lookup x namedRefs - unescape (Right (H.RefChar x)) = Just [chr x] - - namedRefs = - [ ("lt", "<") - , ("gt", ">") - , ("amp", "&") - , ("apos", "'") - , ("quot", "\"") - ] -: - -Some helper functions for dealing with HaXml filters +getattrM :: Text -> X.Element -> Maybe Text +getattrM name = fmap attrText . listToMaybe . attrs where + attrText = textContent . X.attributeContent + attrs = X.elementAttributes >=> X.isNamed (toName name) + textContent cs = TL.concat [t | X.ContentText t <- cs] -:d introspection imports -import Data.Maybe (fromMaybe) -: +getattr :: Text -> X.Element -> Text +getattr = (fromMaybe "" .) . getattrM -:f DBus/Introspection.hs -getAttr :: String -> H.Element a -> Maybe Text -getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue +isParam :: [Text] -> X.Element -> [X.Element] +isParam dirs = named "arg" >=> checkDir where + checkDir e = [e | getattr "direction" e `elem` dirs] -getAttr' :: String -> H.Element a -> Text -getAttr' = (fromMaybe "" .) . getAttr +children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b] +children f p = mapM f . concatMap p . X.elementChildren -isParam :: [Text] -> H.CFilter a -isParam dirs content = do - arg@(H.CElem e _) <- H.tag "arg" content - let direction = getAttr' "direction" e - [arg | direction `elem` dirs] +named :: X.Named a => Text -> a -> [a] +named = X.isNamed . toName -children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] -children f filt (H.Elem _ _ contents) = - mapM f [x | (H.CElem x _) <- concatMap filt contents] +toName :: Text -> X.Name +toName t = X.Name t Nothing Nothing : \subsection{Generating XML} -:f DBus/Introspection.hs -dtdPublicID, dtdSystemID :: String -dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" -dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" -: +Generating XML can fail; if a child object's path is not a sub-path of the +parent, {\tt toXML} will return {\tt Nothing}. -HaXml punts to the {\tt pretty} package for serialising XML. +To simplify XML serialization, a variant of {\tt Writer} is used to combine +text fragments with optional failure. This would be {\tt WriterT Text Maybe}, +except I didn't want to drag in a dependency on {\tt transformers} for such +a little thing. -:d introspection imports -import Text.XML.HaXml.Pretty (document) -import Text.PrettyPrint.HughesPJ (render) +:f DBus/Introspection.hs +newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) } + +instance Monad XmlWriter where + return a = XmlWriter $ Just (a, TL.empty) + m >>= f = XmlWriter $ do + (a, w) <- runXmlWriter m + (b, w') <- runXmlWriter (f a) + return (b, TL.append w w') : -Generating XML can fail; if a child object's path is not a sub-path of the -parent, {\tt toXML} will return {\tt Nothing}. +:f DBus/Introspection.hs +tell :: Text -> XmlWriter () +tell t = XmlWriter $ Just ((), t) +: :f DBus/Introspection.hs toXML :: Object -> Maybe Text -toXML obj = fmap (TL.pack . render . document) doc where - prolog = H.Prolog Nothing [] (Just doctype) [] - doctype = H.DTD "node" (Just (H.PUBLIC - (H.PubidLiteral dtdPublicID) - (H.SystemLiteral dtdSystemID))) [] - doc = do - root <- xmlRoot obj - return $ H.Document prolog H.emptyST root [] +toXML obj = do + (_, text) <- runXmlWriter (writeRoot obj) + return text : -When writing objects to {\tt node}s, the root object must have an absolute -path, and children must have paths relative to their parent. - :f DBus/Introspection.hs -xmlRoot :: Object -> Maybe (H.Element a) -xmlRoot obj@(Object path _ _) = do - (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj - return root +writeRoot :: Object -> XmlWriter () +writeRoot obj@(Object path _ _) = do + tell "\n" + writeObject (T.strObjectPath path) obj : :f DBus/Introspection.hs -xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) -xmlObject parentPath obj@(Object path _ _) = do - let path' = T.strObjectPath path - parent' = T.strObjectPath parentPath - relpath <- if TL.isPrefixOf parent' path' +writeChild :: T.ObjectPath -> Object -> XmlWriter () +writeChild parentPath obj@(Object path _ _) = write where + path' = T.strObjectPath path + parent' = T.strObjectPath parentPath + relpathM = if TL.isPrefixOf parent' path' then Just $ if parent' == "/" then TL.drop 1 path' else TL.drop (TL.length parent' + 1) path' else Nothing - xmlObject' relpath obj + + write = case relpathM of + Just relpath -> writeObject relpath obj + Nothing -> XmlWriter Nothing : :f DBus/Introspection.hs -xmlObject' :: Text -> Object -> Maybe (H.Content a) -xmlObject' path (Object fullPath interfaces children') = do - children'' <- mapM (xmlObject fullPath) children' - return $ mkElement "node" - [mkAttr "name" $ TL.unpack path] - $ concat - [ map xmlInterface interfaces - , children'' - ] +writeObject :: Text -> Object -> XmlWriter () +writeObject path (Object fullPath interfaces children') = writeElement "node" + [("name", path)] $ do + mapM_ writeInterface interfaces + mapM_ (writeChild fullPath) children' : :f DBus/Introspection.hs -xmlInterface :: Interface -> H.Content a -xmlInterface (Interface name methods signals properties) = - mkElement "interface" - [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] - $ concat - [ map xmlMethod methods - , map xmlSignal signals - , map xmlProperty properties - ] +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 : :f DBus/Introspection.hs -xmlMethod :: Method -> H.Content a -xmlMethod (Method name inParams outParams) = mkElement "method" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ concat - [ map (xmlParameter "in") inParams - , map (xmlParameter "out") outParams - ] +writeMethod :: Method -> XmlWriter () +writeMethod (Method name inParams outParams) = writeElement "method" + [("name", T.strMemberName name)] $ do + mapM_ (writeParameter "in") inParams + mapM_ (writeParameter "out") outParams : :f DBus/Introspection.hs -xmlSignal :: Signal -> H.Content a -xmlSignal (Signal name params) = mkElement "signal" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ map (xmlParameter "out") params +writeSignal :: Signal -> XmlWriter () +writeSignal (Signal name params) = writeElement "signal" + [("name", T.strMemberName name)] $ do + mapM_ (writeParameter "out") params : :f DBus/Introspection.hs -xmlParameter :: String -> Parameter -> H.Content a -xmlParameter direction (Parameter name sig) = mkElement "arg" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "direction" direction - ] [] +writeParameter :: Text -> Parameter -> XmlWriter () +writeParameter direction (Parameter name sig) = writeEmptyElement "arg" + [ ("name", name) + , ("type", T.strSignature sig) + , ("direction", direction) + ] : :f DBus/Introspection.hs -xmlProperty :: Property -> H.Content a -xmlProperty (Property name sig access) = mkElement "property" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "access" $ xmlAccess access - ] [] +writeProperty :: Property -> XmlWriter () +writeProperty (Property name sig access) = writeEmptyElement "property" + [ ("name", name) + , ("type", T.strSignature sig) + , ("access", strAccess access) + ] : :f DBus/Introspection.hs -xmlAccess :: [PropertyAccess] -> String -xmlAccess access = readS ++ writeS where +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 "" : :f DBus/Introspection.hs -mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a -mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined +writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter () +writeElement name attrs content = do + tell "<" + tell name + mapM_ writeAttribute attrs + tell ">" + content + tell "" +: -mkAttr :: String -> String -> H.Attribute -mkAttr name value = (name, H.AttValue [Left escaped]) where - raw = H.CString True value () - escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] +:f DBus/Introspection.hs +writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter () +writeEmptyElement name attrs = do + tell "<" + tell name + mapM_ writeAttribute attrs + tell "/>" +: + +:f DBus/Introspection.hs +writeAttribute :: (Text, Text) -> XmlWriter () +writeAttribute (name, content) = do + tell " " + tell name + tell "='" + tell (escape content) + tell "'" +: + +:f DBus/Introspection.hs +escape :: Text -> Text +escape = TL.concatMap escapeChar where + escapeChar c = case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> TL.singleton c : \subsection{Test support} diff --git a/src/types.anansi b/src/types.anansi --- a/src/types.anansi +++ b/src/types.anansi @@ -16,17 +16,28 @@ \section{Types} The {\tt DBus.Types module} defines interfaces for storing, building, and -deconstructing D-Bus values. +deconstructing D-Bus values. Everything is defined in an internal module, and +then exported via the public interface. -:f DBus/Types.cpphs +:f DBus/Types.hs |copyright| -|text extensions| -|type extensions| module DBus.Types ( |type exports| ) where +import DBus.Types.Internal +: + +:f DBus/Types/Internal.cpphs +|copyright| +|text extensions| +|type extensions| +module DBus.Types.Internal where |text imports| |type imports| +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 : D-Bus types are divided into two categories, ``atomic'' and ``container'' @@ -37,7 +48,7 @@ Internally, types are represented using an enumeration. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs data Type = DBusBoolean | DBusByte @@ -58,7 +69,7 @@ deriving (Show, Eq) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs |apidoc isAtomicType| isAtomicType :: Type -> Bool isAtomicType DBusBoolean = True @@ -79,7 +90,7 @@ Each type can be converted to a textual representation, used in ``type signatures'' or for debugging. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs |apidoc typeCode| typeCode :: Type -> Text |type codes| @@ -135,7 +146,7 @@ outside of this module, {\tt Variant}s can only be constructed from pre-defined types. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs |apidoc Variant| data Variant = VarBoxBool Bool @@ -171,7 +182,7 @@ be parsed or inspected or anything like that, since the output format might change drastically. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Show Variant where showsPrec d var = showParen (d > 10) full where full = s "Variant " . shows code . s " " . valueStr @@ -203,7 +214,7 @@ {\tt variantType} is used to retrieve which type is actually stored within a {\tt Variant}. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs |apidoc variantType| variantType :: Variant -> Type variantType var = case var of @@ -228,6 +239,9 @@ (VarBoxStructure x) -> let Structure items = x in DBusStructure (map variantType items) + +variantSignature :: Variant -> Maybe Signature +variantSignature = mkBytesSignature . typeCodeB . variantType : :d type exports @@ -237,7 +251,7 @@ A macro is useful for reducing verbosity in simple {\tt Variable} instances. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs #define INSTANCE_VARIABLE(TYPE) \ instance Variable TYPE where \ { toVariant = VarBox/**/TYPE \ @@ -248,7 +262,7 @@ Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Variant) : @@ -312,7 +326,7 @@ import Data.Int (Int16, Int32, Int64) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Bool) INSTANCE_VARIABLE(Word8) INSTANCE_VARIABLE(Int16) @@ -330,7 +344,7 @@ inefficent. To provide better performance for large strings, packed Unicode strings defined in {\tt Data.Text} are used internally. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Variable TL.Text where toVariant = VarBoxString fromVariant (VarBoxString x) = Just x @@ -345,7 +359,7 @@ import qualified Data.Text as T : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Variable T.Text where toVariant = toVariant . TL.fromChunks . (:[]) fromVariant = fmap (T.concat . TL.toChunks) . fromVariant @@ -358,7 +372,7 @@ {-# LANGUAGE TypeSynonymInstances #-} : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Variable String where toVariant = toVariant . TL.pack fromVariant = fmap TL.unpack . fromVariant @@ -391,7 +405,7 @@ one requires using the {\tt mkSignature} function, which will convert a valid D-Bus signature string into a {\tt Signature}. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Signature) data Signature = Signature { signatureTypes :: [Type] } deriving (Eq) @@ -404,7 +418,10 @@ Signatures can also be converted back into text, by concatenating the type codes of their contained types. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs +bytesSignature :: Signature -> B.ByteString +bytesSignature (Signature ts) = B.concat $ map typeCodeB ts + strSignature :: Signature -> Text strSignature (Signature ts) = TL.concat $ map typeCode ts : @@ -416,7 +433,7 @@ import Data.Ord (comparing) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Ord Signature where compare = comparing strSignature : @@ -433,34 +450,41 @@ For atomic types, the type code is a single letter. Arrays, structures, and dictionary types are multiple characters. +:d type imports +import Data.Text.Encoding (decodeUtf8) +: + :d type codes -typeCode DBusBoolean = "b" -typeCode DBusByte = "y" -typeCode DBusInt16 = "n" -typeCode DBusInt32 = "i" -typeCode DBusInt64 = "x" -typeCode DBusWord16 = "q" -typeCode DBusWord32 = "u" -typeCode DBusWord64 = "t" -typeCode DBusDouble = "d" -typeCode DBusString = "s" -typeCode DBusSignature = "g" -typeCode DBusObjectPath = "o" -typeCode DBusVariant = "v" +typeCode t = TL.fromChunks [decodeUtf8 $ typeCodeB t] + +typeCodeB :: Type -> B.ByteString +typeCodeB DBusBoolean = "b" +typeCodeB DBusByte = "y" +typeCodeB DBusInt16 = "n" +typeCodeB DBusInt32 = "i" +typeCodeB DBusInt64 = "x" +typeCodeB DBusWord16 = "q" +typeCodeB DBusWord32 = "u" +typeCodeB DBusWord64 = "t" +typeCodeB DBusDouble = "d" +typeCodeB DBusString = "s" +typeCodeB DBusSignature = "g" +typeCodeB DBusObjectPath = "o" +typeCodeB DBusVariant = "v" : An array's type code is ``a'' followed by the type it contains. For example, an array of booleans would have the type string ``ab''. :d type codes -typeCode (DBusArray t) = TL.cons 'a' $ typeCode t +typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t : A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example, a dictionary of bytes to booleans would have the type string ``a\{yb\}''. :d type codes -typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] +typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"] : A structure's type code is the concatenation of its contained types, @@ -468,112 +492,201 @@ type code is simply ``()''. :d type codes -typeCode (DBusStructure ts) = TL.concat $ - ["("] ++ map typeCode ts ++ [")"] +typeCodeB (DBusStructure ts) = B.concat $ + ["("] ++ map typeCodeB ts ++ [")"] : \subsubsection{Parsing} When parsing, additional restrictions apply which are not inherent to the -D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is -valid according to D-Bus rules. +D-Bus type system. The signature parsing functions guarantee that any +{\tt Signature} is valid according to D-Bus rules. -:f DBus/Types.cpphs -mkSignature :: Text -> Maybe Signature -mkSignature text = parsed where - |fast signature parser| - |slow signature parser| - parsed = case TL.length text of - 0 -> Just $ Signature [] - 1 -> fast - _ -> slow +Signature parsing is the most common operation when unmarshaling messages; +therefore, an efficient parsing implementation is essential. + +Since all valid signatures as entirely ASCII, it's possible to parse them +using byte-based parsers for better performance. These aren't exported from +the public interface, but are still used within {\tt DBus.Wire} modules. + +:d type imports +import qualified Data.ByteString.Unsafe as B +import qualified Foreign as F +import System.IO.Unsafe (unsafePerformIO) : -Since single-type and empty signatures are very common, they are -special-cased for performance. +There are three special cases which can be optimized: -:d fast signature parser -just t = Just $ Signature [t] -fast = case TL.head text of - 'b' -> just DBusBoolean - 'y' -> just DBusByte - 'n' -> just DBusInt16 - 'i' -> just DBusInt32 - 'x' -> just DBusInt64 - 'q' -> just DBusWord16 - 'u' -> just DBusWord32 - 't' -> just DBusWord64 - 'd' -> just DBusDouble - 's' -> just DBusString - 'g' -> just DBusSignature - 'o' -> just DBusObjectPath - 'v' -> just DBusVariant - _ -> Nothing +\begin{enumerate} +\item Empty signatures occur when messages have no body, and can use a constant + result. +\item Single-character signatures occur when parsing variants, and can use a + faster atom-only parser. +\item Signatures larger than 255 characters are invalid. +\end{enumerate} + +:f DBus/Types/Internal.cpphs +mkBytesSignature :: B.ByteString -> Maybe Signature +mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where + |fast signature parser| + |slow signature parser| + + 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 : -Parsec is used to parse more complex signatures. +:d fast signature parser +parseAtom c yes no = case c of + 0x62 -> yes DBusBoolean + 0x79 -> yes DBusByte + 0x6E -> yes DBusInt16 + 0x69 -> yes DBusInt32 + 0x78 -> yes DBusInt64 + 0x71 -> yes DBusWord16 + 0x75 -> yes DBusWord32 + 0x74 -> yes DBusWord64 + 0x64 -> yes DBusDouble + 0x73 -> yes DBusString + 0x67 -> yes DBusSignature + 0x6F -> yes DBusObjectPath + _ -> no -:d type imports -import Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import DBus.Util (checkLength, parseMaybe) +fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of + 0x76 -> Just (Signature [DBusVariant]) + _ -> Nothing : :d slow signature parser -slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text -sigParser = do - types <- P.many parseType - P.eof - return $ Signature types +slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature) +slow buf len = loop [] 0 where + loop acc ii | ii >= len = return . Just . Signature $ reverse acc + loop acc ii = do + c <- F.peekElemOff buf ii + let next t = loop (t : acc) (ii + 1) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + _ -> return Nothing : -Types may be either containers or atoms. Containers can't be dictionary -keys. +:d slow signature parser +structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) +structure buf len = loop [] where + loop _ ii | ii >= len = return Nothing + loop acc ii = do + c <- F.peekElemOff buf ii + let next t = loop (t : acc) (ii + 1) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + -- ')' + 0x29 -> return $ Just $ (ii + 1, DBusStructure (reverse acc)) + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> loop (t : acc) ii' + Nothing -> return Nothing + + _ -> return Nothing +: :d slow signature parser -parseType = parseAtom <|> parseContainer -parseContainer = - parseArray - <|> parseStruct - <|> (P.char 'v' >> return DBusVariant) +array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) +array _ len ii | ii >= len = return Nothing +array buf len ii = do + c <- F.peekElemOff buf ii + let next t = return $ Just (ii + 1, DBusArray t) + parseAtom c next $ case c of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> do + mt <- structure buf len (ii + 1) + case mt of + Just (ii', t) -> return $ Just (ii', DBusArray t) + Nothing -> return Nothing + + -- '{' + 0x7B -> dict buf len (ii + 1) + + -- 'a' + 0x61 -> do + mt <- array buf len (ii + 1) + case mt of + Just (ii', t) -> return $ Just (ii', DBusArray t) + Nothing -> return Nothing + + _ -> return Nothing : :d slow signature parser -parseArray = do - P.char 'a' - parseDict <|> fmap DBusArray parseType -parseDict = do - P.char '{' - keyType <- parseAtom - valueType <- parseType - P.char '}' - return $ DBusDictionary keyType valueType +dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) +dict _ len ii | ii + 1 >= len = return Nothing +dict buf len ii = do + c1 <- F.peekElemOff buf ii + c2 <- F.peekElemOff buf (ii + 1) + + let mt1 = parseAtom c1 Just Nothing + + let next t = return $ Just (ii + 2, t) + mt2 <- parseAtom c2 next $ case c2 of + 0x76 -> next DBusVariant + + -- '(' + 0x28 -> structure buf len (ii + 2) + + -- 'a' + 0x61 -> array buf len (ii + 2) + + _ -> return Nothing + + case mt2 of + Nothing -> return Nothing + Just (ii', t2) -> if ii' >= len + then return Nothing + else do + c3 <- F.peekElemOff buf ii' + return $ do + if c3 == 0x7D then Just () else Nothing + t1 <- mt1 + Just (ii' + 1, DBusDictionary t1 t2) : -Structures can contain any types. +The public interface for building signatures is {\tt Text}-based. -:d slow signature parser -parseStruct = do - P.char '(' - types <- P.many parseType - P.char ')' - return $ DBusStructure types +:d type imports +import Data.Text.Lazy.Encoding (encodeUtf8) : -:d slow signature parser -parseAtom = - (P.char 'b' >> return DBusBoolean) - <|> (P.char 'y' >> return DBusByte) - <|> (P.char 'n' >> return DBusInt16) - <|> (P.char 'i' >> return DBusInt32) - <|> (P.char 'x' >> return DBusInt64) - <|> (P.char 'q' >> return DBusWord16) - <|> (P.char 'u' >> return DBusWord32) - <|> (P.char 't' >> return DBusWord64) - <|> (P.char 'd' >> return DBusDouble) - <|> (P.char 's' >> return DBusString) - <|> (P.char 'g' >> return DBusSignature) - <|> (P.char 'o' >> return DBusObjectPath) +:f DBus/Types/Internal.cpphs +mkSignature :: Text -> Maybe Signature +mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8 : Since many signatures are defined as string literals, it's useful to @@ -585,12 +698,12 @@ import qualified Data.String as String : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature instance String.IsString Signature where - fromString = mkSignature_ . TL.pack + fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack : Most signature-related functions are exposed to clients, except the @@ -602,6 +715,18 @@ , mkSignature_ : +Checking if a type is valid according to signature rules is common, and if +performed through the signature parser, slow. Since such types are already +guaranteed to be structurally valid, the only test needed is whether their +size is within bounds. + +:f DBus/Types/Internal.cpphs +maybeValidType :: Type -> Maybe () +maybeValidType t = if B.length (typeCodeB t) > 255 + then Nothing + else Just () +: + :f Tests.hs instance Arbitrary Signature where arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary @@ -616,7 +741,7 @@ \subsection{Object paths} -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath { strObjectPath :: Text @@ -643,7 +768,13 @@ Element names are separated by {\tt '/'}, and the path may not end in {\tt '/'} unless it is the root path. -:f DBus/Types.cpphs +:d type imports +import Text.ParserCombinators.Parsec ((<|>)) +import qualified Text.ParserCombinators.Parsec as P +import DBus.Util (checkLength, parseMaybe) +: + +:f DBus/Types/Internal.cpphs mkObjectPath :: Text -> Maybe ObjectPath mkObjectPath s = parseMaybe path' (TL.unpack s) where c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" @@ -687,16 +818,11 @@ Many D-Bus APIs represent binary data using an array of bytes; therefore, there is a special constructor for {\tt ByteString}-based arrays. -:d type imports -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString -: - -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Array) data Array = VariantArray Type [Variant] - | ByteArray ByteString + | ByteArray BL.ByteString deriving (Eq) |apidoc arrayType| @@ -706,7 +832,7 @@ arrayItems :: Array -> [Variant] arrayItems (VariantArray _ xs) = xs -arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs +arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs : :d type exports @@ -719,7 +845,7 @@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly just useful for debugging. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Show Array where showsPrec d array = showParen (d > 10) $ s "Array " . showSig . s " [" . s valueString . s "]" where @@ -733,12 +859,12 @@ will be checked for validity. Every item in the array will be checked against the item type, to ensure the array is homogenous. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs arrayFromItems :: Type -> [Variant] -> Maybe Array -arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) +arrayFromItems DBusByte vs = fmap (ByteArray . BL.pack) (mapM fromVariant vs) arrayFromItems t vs = do - mkSignature (typeCode t) + maybeValidType t if all (\x -> variantType x == t) vs then Just $ VariantArray t vs else Nothing @@ -747,7 +873,7 @@ Additionally, for ease of use, an {\tt Array} can be converted directly to/from lists of {\tt Variable} values. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs toArray :: Variable a => Type -> [a] -> Maybe Array toArray t = arrayFromItems t . map toVariant @@ -764,12 +890,12 @@ To provide a more efficient interface for byte array literals, these functions bypass the conversions in {\tt toArray} and {\tt fromArray} -:f DBus/Types.cpphs -arrayToBytes :: Array -> Maybe ByteString +:f DBus/Types/Internal.cpphs +arrayToBytes :: Array -> Maybe BL.ByteString arrayToBytes (ByteArray x) = Just x arrayToBytes _ = Nothing -arrayFromBytes :: ByteString -> Array +arrayFromBytes :: BL.ByteString -> Array arrayFromBytes = ByteArray : @@ -781,22 +907,16 @@ And to simplify inclusion of {\tt ByteString}s in message, instances of {\tt Variable} exist for both strict and lazy {\tt ByteString}. -:f DBus/Types.cpphs -instance Variable ByteString where +:f DBus/Types/Internal.cpphs +instance Variable BL.ByteString where toVariant = toVariant . arrayFromBytes fromVariant x = fromVariant x >>= arrayToBytes : -:d type imports -import qualified Data.ByteString as StrictByteString -: - -:f DBus/Types.cpphs -instance Variable StrictByteString.ByteString where - toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] - fromVariant x = do - chunks <- ByteString.toChunks `fmap` fromVariant x - return $ StrictByteString.concat chunks +:f DBus/Types/Internal.cpphs +instance Variable B.ByteString where + toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x] + fromVariant = fmap (B.concat . BL.toChunks) . fromVariant : When generating random arrays for testing, only atomic values are used. @@ -832,8 +952,9 @@ key type must be atomic. Values may be of any valid D-Bus type. Like {\tt Array}, {\tt Dictionary} stores its contained types. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Dictionary) + data Dictionary = Dictionary { dictionaryKeyType :: Type , dictionaryValueType :: Type @@ -857,7 +978,7 @@ import Data.List (intercalate) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs instance Show Dictionary where showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ s "Dictionary " . showSig . s " {" . s valueString . s "}" where @@ -874,12 +995,12 @@ import Control.Monad (unless) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary dictionaryFromItems kt vt pairs = do unless (isAtomicType kt) Nothing - mkSignature (typeCode kt) - mkSignature (typeCode vt) + maybeValidType kt + maybeValidType vt let sameType (k, v) = variantType k == kt && variantType v == vt @@ -897,7 +1018,7 @@ import qualified Data.Map as Map : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b -> Maybe Dictionary toDictionary kt vt = dictionaryFromItems kt vt . pairs where @@ -908,7 +1029,7 @@ import Control.Monad (forM) : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary -> Maybe (Map.Map a b) fromDictionary (Dictionary _ _ vs) = do @@ -968,7 +1089,7 @@ (un)marshaling -- dictionaries can be thought of as arrays of two-element structures, much as a {\tt Map} is a list of pairs. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs dictionaryToArray :: Dictionary -> Array dictionaryToArray (Dictionary kt vt items) = array where Just array = toArray itemType structs @@ -976,7 +1097,7 @@ structs = [Structure [k, v] | (k, v) <- items] : -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs arrayToDictionary :: Array -> Maybe Dictionary arrayToDictionary array = do let toPair x = do @@ -1001,8 +1122,9 @@ A heterogeneous, fixed-length container; equivalent in purpose to a Haskell tuple. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs INSTANCE_VARIABLE(Structure) + data Structure = Structure [Variant] deriving (Show, Eq) : @@ -1027,7 +1149,7 @@ declaration and some helper functions), I define a macro to automate the definitions. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs #define NAME_TYPE(TYPE, NAME) \ newtype TYPE = TYPE {str/**/TYPE :: Text} \ deriving (Eq, Ord); \ @@ -1064,7 +1186,7 @@ element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must not start with a digit. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs NAME_TYPE(BusName, "bus name") mkBusName :: Text -> Maybe BusName @@ -1119,7 +1241,7 @@ element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not start with a digit, and must have at least one character. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs NAME_TYPE(InterfaceName, "interface name") mkInterfaceName :: Text -> Maybe InterfaceName @@ -1165,7 +1287,7 @@ Error names have the same format as interface names, so the parser logic can just be re-purposed. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs NAME_TYPE(ErrorName, "error name") mkErrorName :: Text -> Maybe ErrorName @@ -1197,7 +1319,7 @@ Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]}, may not begin with a digit, and must be at least one character long. -:f DBus/Types.cpphs +:f DBus/Types/Internal.cpphs NAME_TYPE(MemberName, "member name") mkMemberName :: Text -> Maybe MemberName diff --git a/src/util.anansi b/src/util.anansi --- a/src/util.anansi +++ b/src/util.anansi @@ -57,7 +57,7 @@ :f DBus/Util.hs |copyright| module DBus.Util where -import Text.Parsec (Parsec, parse) +import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt) import Data.List (isPrefixOf) @@ -65,7 +65,7 @@ checkLength length' s | length s <= length' = Just s checkLength _ _ = Nothing -parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe :: Parser a -> String -> Maybe a parseMaybe p = either (const Nothing) Just . parse p "" mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b @@ -115,20 +115,30 @@ :f DBus/Util/MonadError.hs |copyright| -{-# LANGUAGE TypeFamilies #-} module DBus.Util.MonadError - ( ErrorT (..) - , throwError + ( ErrorM (..) + , ErrorT (..) + , throwErrorM + , throwErrorT ) where -import Control.Monad.Trans.Class -import Control.Monad.State -import Control.Monad.Error.Class +newtype ErrorM e a = ErrorM { runErrorM :: Either e a } -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } +instance Functor (ErrorM e) where + fmap f m = ErrorM $ case runErrorM m of + Left err -> Left err + Right x -> Right $ f x -instance Functor m => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT +instance Monad (ErrorM e) where + return = ErrorM . Right + (>>=) m k = case runErrorM m of + Left err -> ErrorM $ Left err + Right x -> k x +throwErrorM :: e -> ErrorM e a +throwErrorM = ErrorM . Left + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + instance Monad m => Monad (ErrorT e m) where return = ErrorT . return . Right (>>=) m k = ErrorT $ do @@ -137,22 +147,8 @@ Left l -> return $ Left l Right r -> runErrorT $ k r -instance MonadTrans (ErrorT e) where - lift = ErrorT . liftM Right - -instance Monad m => MonadError (ErrorT e m) where - type ErrorType (ErrorT e m) = e - throwError = ErrorT . return . Left - catchError m h = ErrorT $ do - x <- runErrorT m - case x of - Left l -> runErrorT $ h l - Right r -> return $ Right r - -instance MonadState m => MonadState (ErrorT e m) where - type StateType (ErrorT e m) = StateType m - get = lift get - put = lift . put +throwErrorT :: Monad m => e -> ErrorT e m a +throwErrorT = ErrorT . return . Left : \subsection{Extra test support} diff --git a/src/wire.anansi b/src/wire.anansi --- a/src/wire.anansi +++ b/src/wire.anansi @@ -95,22 +95,50 @@ import Control.Monad (when) import Data.Maybe (fromJust) import Data.Word (Word8, Word32, Word64) -import Data.Int (Int16, Int32, Int64) +import Data.Int (Int64) import qualified DBus.Types as T +import qualified DBus.Types.Internal as T : :d marshal imports -import qualified Control.Monad.State as State -import qualified DBus.Util.MonadError as E +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B : :f DBus/Wire/Marshal.hs -data MarshalState = MarshalState Endianness B.Builder !Word64 -type MarshalM = E.ErrorT MarshalError (State.State MarshalState) +data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64 + +data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState + type Marshal = MarshalM () +newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a } + +instance Monad MarshalM where + {-# INLINE return #-} + return a = MarshalM $ \_ s -> MarshalRR a s + + {-# INLINE (>>=) #-} + m >>= k = MarshalM $ \e s -> case unMarshalM m e s of + MarshalRL err -> MarshalRL err + MarshalRR a s' -> unMarshalM (k a) e s' + + {-# INLINE (>>) #-} + m >> k = MarshalM $ \e s -> case unMarshalM m e s of + MarshalRL err -> MarshalRL err + MarshalRR _ s' -> unMarshalM k e s' + +throwError :: MarshalError -> MarshalM a +throwError err = MarshalM $ \_ _ -> MarshalRL err + +{-# INLINE getState #-} +getState :: MarshalM MarshalState +getState = MarshalM $ \_ s -> MarshalRR s s + +{-# INLINE putState #-} +putState :: MarshalState -> MarshalM () +putState s = MarshalM $ \_ _ -> MarshalRR () s : Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, @@ -118,38 +146,41 @@ :f DBus/Wire/Marshal.hs runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString -runMarshal m e = case State.runState (E.runErrorT m) initialState of - (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) - (Left x, _) -> Left x - where initialState = MarshalState e B.empty 0 +runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of + MarshalRL err -> Left err + MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder : :f DBus/Wire/Marshal.hs marshal :: T.Variant -> Marshal -marshal v = marshalType (T.variantType v) where - x :: T.Variable a => a - x = fromJust . T.fromVariant $ v - marshalType :: T.Type -> Marshal +marshal v = case v of |marshalers| : TODO: describe these functions :f DBus/Wire/Marshal.hs -append :: L.ByteString -> Marshal -append bytes = do - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ B.fromLazyByteString bytes - count' = count + fromIntegral (L.length bytes) - State.put $ MarshalState e builder' count' +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') : :f DBus/Wire/Marshal.hs +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') +: + +:f DBus/Wire/Marshal.hs pad :: Word8 -> Marshal -pad count = do - (MarshalState _ _ existing) <- State.get - let padding' = fromIntegral $ padding existing count - append $ L.replicate padding' 0 +pad count = MarshalM $ \e s@(MarshalState _ existing) -> let + padding' = fromIntegral $ padding existing count + bytes = BS.replicate padding' 0 + in unMarshalM (appendS bytes) e s : Most numeric values already have marshalers implemented in the @@ -159,12 +190,12 @@ marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do pad size - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ case e of - BigEndian -> be x - LittleEndian -> le x - let count' = count + fromIntegral size - State.put $ MarshalState e builder' count' + MarshalM $ \e (MarshalState builder count) -> let + builder' = B.append builder $ case e of + BigEndian -> be x + LittleEndian -> le x + size' = fromIntegral size + in MarshalRR () (MarshalState builder' (count + size')) : \subsubsection{Errors} @@ -218,31 +249,63 @@ module DBus.Wire.Unmarshal where |text imports| |unmarshal imports| -import Control.Monad (when, unless, liftM) +import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64) import DBus.Wire.Internal -import qualified DBus.Types as T +import qualified DBus.Types.Internal as T : :d unmarshal imports -import qualified Control.Monad.State as State -import Control.Monad.Trans.Class (lift) +import Control.Monad (liftM) import qualified DBus.Util.MonadError as E -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL : +A specialised, state-like monad is used for performance reasons. This is +equivalent to {\tt State.StateT UnmarshalState (E.ErrorM UnmarshalError)}. + :f DBus/Wire/Unmarshal.hs -data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 -type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) +data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64 + +data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState + +newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a } + +instance Monad Unmarshal where + {-# INLINE return #-} + return a = Unmarshal $ \_ s -> UnmarshalRR a s + + {-# INLINE (>>=) #-} + m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of + UnmarshalRL err -> UnmarshalRL err + UnmarshalRR a s' -> unUnmarshal (k a) e s' + + {-# INLINE (>>) #-} + m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of + UnmarshalRL err -> UnmarshalRL err + UnmarshalRR _ s' -> unUnmarshal k e s' + +throwError :: UnmarshalError -> Unmarshal a +throwError err = Unmarshal $ \_ _ -> UnmarshalRL err + +{-# INLINE getState #-} +getState :: Unmarshal UnmarshalState +getState = Unmarshal $ \_ s -> UnmarshalRR s s + +{-# INLINE putState #-} +putState :: UnmarshalState -> Unmarshal () +putState s = Unmarshal $ \_ _ -> UnmarshalRR () s : :f DBus/Wire/Unmarshal.hs -runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a -runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where - state = UnmarshalState e bytes 0 +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 : :f DBus/Wire/Unmarshal.hs @@ -256,40 +319,39 @@ TODO: describe these functions :f DBus/Wire/Unmarshal.hs -consume :: Word64 -> Unmarshal L.ByteString -consume count = do - (UnmarshalState e bytes offset) <- State.get - let (x, bytes') = L.splitAt (fromIntegral count) bytes - unless (L.length x == fromIntegral count) $ - E.throwError $ UnexpectedEOF offset - - State.put $ UnmarshalState e bytes' (offset + count) - return x +{-# INLINE consume #-} +consume :: Word64 -> Unmarshal BL.ByteString +consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let + count' = fromIntegral count + (x, bytes') = BL.splitAt count' bytes + in if BL.length x == count' + then UnmarshalRR x (UnmarshalState bytes' (offset + count)) + else UnmarshalRL $ UnexpectedEOF offset : :f DBus/Wire/Unmarshal.hs skipPadding :: Word8 -> Unmarshal () skipPadding count = do - (UnmarshalState _ _ offset) <- State.get + (UnmarshalState _ offset) <- getState bytes <- consume $ padding offset count - unless (L.all (== 0) bytes) $ - E.throwError $ InvalidPadding offset + unless (BL.all (== 0) bytes) $ + throwError $ InvalidPadding offset : :f DBus/Wire/Unmarshal.hs skipTerminator :: Unmarshal () skipTerminator = do - (UnmarshalState _ _ offset) <- State.get + (UnmarshalState _ offset) <- getState bytes <- consume 1 - unless (L.all (== 0) bytes) $ - E.throwError $ MissingTerminator offset + unless (BL.all (== 0) bytes) $ + throwError $ MissingTerminator offset : :f DBus/Wire/Unmarshal.hs fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of Just x' -> return x' - Nothing -> E.throwError . Invalid label . TL.pack . show $ x + Nothing -> throwError . Invalid label . TL.pack . show $ x fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a -> Unmarshal T.Variant @@ -306,16 +368,17 @@ unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do skipPadding count - (UnmarshalState e _ _) <- State.get bs <- consume . fromIntegral $ count - let get' = case e of - BigEndian -> be - LittleEndian -> le - return $ G.runGet get' bs + + Unmarshal $ \e s -> let + get = case e of + BigEndian -> be + LittleEndian -> le + in UnmarshalRR (G.runGet get bs) s unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a -> Unmarshal T.Variant -unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le +unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le : :f DBus/Wire/Unmarshal.hs @@ -395,31 +458,39 @@ alignment T.DBusDouble = 8 : -Because {\tt Word32}s are often used for other types, there's -separate functions for handling them. +Because some integral types are often used as components of other values, +there's separate functions for handling them. :f DBus/Wire/Marshal.hs marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le : +:f DBus/Wire/Marshal.hs +{-# 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)) +: + :f DBus/Wire/Unmarshal.hs unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le : :d marshalers -marshalType T.DBusByte = append $ L.singleton x -marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x -marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x -marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x -marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) -marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) -marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) +T.VarBoxWord8 x -> marshalWord8 x +T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x +T.VarBoxWord32 x -> marshalWord32 x +T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x +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 : :d unmarshalers -unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 +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 unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le @@ -449,14 +520,19 @@ : :d marshalers -marshalType T.DBusDouble = do +T.VarBoxDouble x -> marshalDouble x +: + +:f DBus/Wire/Marshal.hs +marshalDouble :: Double -> Marshal +marshalDouble x = do pad 8 - (MarshalState e _ _) <- State.get - let put = case e of - BigEndian -> IEEE.putFloat64be - LittleEndian -> IEEE.putFloat64le - let bytes = runPut $ put x - append bytes + MarshalM $ \e s -> let + put = case e of + BigEndian -> IEEE.putFloat64be + LittleEndian -> IEEE.putFloat64le + bytes = runPut $ put x + in unMarshalM (appendL bytes) e s : :d unmarshalers @@ -473,7 +549,7 @@ : :d marshalers -marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 +T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0 : :d unmarshalers @@ -528,12 +604,12 @@ marshalText x = do bytes <- case maybeEncodeUtf8 x of Just x' -> return x' - Nothing -> E.throwError $ InvalidText x + Nothing -> throwError $ InvalidText x when (L.any (== 0) bytes) $ - E.throwError $ InvalidText x + throwError $ InvalidText x marshalWord32 . fromIntegral . L.length $ bytes - append bytes - append (L.singleton 0) + appendL bytes + marshalWord8 0 : :d unmarshal imports @@ -555,12 +631,12 @@ : :d marshalers -marshalType T.DBusString = marshalText x -marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x +T.VarBoxString x -> marshalText x +T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x : :d unmarshalers -unmarshalType T.DBusString = fmap T.toVariant unmarshalText +unmarshalType T.DBusString = liftM T.toVariant unmarshalText unmarshalType T.DBusObjectPath = unmarshalText >>= fromMaybeU' "object path" T.mkObjectPath @@ -571,28 +647,24 @@ Signatures are similar to strings, except their length is limited to 255 characters and is therefore stored as a single byte. -:d marshal imports -import Data.Text.Lazy.Encoding (encodeUtf8) -: - :f DBus/Wire/Marshal.hs marshalSignature :: T.Signature -> Marshal marshalSignature x = do - let bytes = encodeUtf8 . T.strSignature $ x - let size = fromIntegral . L.length $ bytes - append (L.singleton size) - append bytes - append (L.singleton 0) + let bytes = T.bytesSignature x + let size = fromIntegral . BS.length $ bytes + marshalWord8 size + appendS bytes + marshalWord8 0 : :f DBus/Wire/Unmarshal.hs unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do - byteCount <- L.head `fmap` consume 1 - bytes <- consume $ fromIntegral byteCount - sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes + byteCount <- BL.head `liftM` consume 1 + lazy <- consume $ fromIntegral byteCount skipTerminator - fromMaybeU "signature" T.mkSignature sigText + let bytes = B.concat $ BL.toChunks lazy + fromMaybeU "signature" T.mkBytesSignature bytes : :d alignments @@ -600,11 +672,11 @@ : :d marshalers -marshalType T.DBusSignature = marshalSignature x +T.VarBoxSignature x -> marshalSignature x : :d unmarshalers -unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature +unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature : \subsection{Containers} @@ -616,11 +688,11 @@ : :d marshalers -marshalType (T.DBusArray _) = marshalArray x +T.VarBoxArray x -> marshalArray x : :d unmarshalers -unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t +unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t : Marshaling arrays is complicated, because the array body must be marshaled @@ -637,10 +709,10 @@ (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x let arrayLen = L.length arrayBytes when (arrayLen > fromIntegral C.arrayMaximumLength) - (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + (throwError $ ArrayTooLong $ fromIntegral arrayLen) marshalWord32 $ fromIntegral arrayLen - append $ L.replicate arrayPadding 0 - append arrayBytes + appendL $ L.replicate arrayPadding 0 + appendL arrayBytes : :f DBus/Wire/Marshal.hs @@ -652,17 +724,17 @@ :f DBus/Wire/Marshal.hs getArrayBytes itemType x = do let vs = T.arrayItems x - s <- State.get - (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get - (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get + s <- getState + (MarshalState _ afterLength) <- marshalWord32 0 >> getState + (MarshalState _ afterPadding) <- pad (alignment itemType) >> getState - State.put $ MarshalState e B.empty afterPadding - (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get + putState $ MarshalState B.empty afterPadding + (MarshalState itemBuilder _) <- mapM_ marshal vs >> getState let itemBytes = B.toLazyByteString itemBuilder paddingSize = fromIntegral $ afterPadding - afterLength - State.put s + putState s return (paddingSize, itemBytes) : @@ -672,22 +744,22 @@ unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do byteCount <- unmarshalWord32 - T.arrayFromBytes `fmap` consume (fromIntegral byteCount) + T.arrayFromBytes `liftM` consume (fromIntegral byteCount) : :f DBus/Wire/Unmarshal.hs unmarshalArray itemType = do let getOffset = do - (UnmarshalState _ _ o) <- State.get + (UnmarshalState _ o) <- getState return o byteCount <- unmarshalWord32 skipPadding (alignment itemType) start <- getOffset let end = start + fromIntegral byteCount - vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + vs <- untilM (liftM (>= end) getOffset) (unmarshalType itemType) end' <- getOffset when (end' > end) $ - E.throwError ArraySizeMismatch + throwError ArraySizeMismatch fromMaybeU "array" (T.arrayFromItems itemType) vs : @@ -698,7 +770,7 @@ : :d marshalers -marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) +T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x) : :d unmarshalers @@ -715,8 +787,7 @@ : :d marshalers -marshalType (T.DBusStructure _) = do - let T.Structure vs = x +T.VarBoxStructure (T.Structure vs) -> do pad 8 mapM_ marshal vs : @@ -724,7 +795,7 @@ :d unmarshalers unmarshalType (T.DBusStructure ts) = do skipPadding 8 - fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts : \subsubsection{Variants} @@ -734,11 +805,11 @@ : :d marshalers -marshalType T.DBusVariant = do - let rawSig = T.typeCode . T.variantType $ x - sig <- case T.mkSignature rawSig of +T.VarBoxVariant x -> do + let textSig = T.typeCode . T.variantType $ x + sig <- case T.variantSignature x of Just x' -> return x' - Nothing -> E.throwError $ InvalidVariantSignature rawSig + Nothing -> throwError $ InvalidVariantSignature textSig marshalSignature sig marshal x : @@ -750,7 +821,7 @@ _ -> Nothing t <- fromMaybeU "variant signature" getType =<< unmarshalSignature - T.toVariant `fmap` unmarshalType t + T.toVariant `liftM` unmarshalType t : \subsection{Messages} @@ -812,8 +883,8 @@ : :f DBus/Wire/Unmarshal.hs -decodeField :: Monad m => T.Structure - -> E.ErrorT UnmarshalError m [M.HeaderField] +decodeField :: T.Structure + -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of (1, x) -> decodeField' x M.Path "path" (2, x) -> decodeField' x M.Interface "interface" @@ -825,11 +896,11 @@ (8, x) -> decodeField' x M.Signature "signature" _ -> return [] -decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text - -> E.ErrorT UnmarshalError m [b] +decodeField' :: T.Variable a => T.Variant -> (a -> b) -> Text + -> E.ErrorM UnmarshalError [b] decodeField' x f label = case T.fromVariant x of Just x' -> return [f x'] - Nothing -> E.throwError $ InvalidHeaderField label x + Nothing -> E.throwErrorM $ InvalidHeaderField label x : :f DBus/Wire/Unmarshal.hs @@ -858,25 +929,26 @@ body = M.messageBody msg marshaler = do sig <- checkBodySig body - empty <- State.get + empty <- getState mapM_ marshal body - (MarshalState _ bodyBytesB _) <- State.get - State.put empty + (MarshalState bodyBytesB _) <- getState + putState empty marshalEndianness e let bodyBytes = B.toLazyByteString bodyBytesB marshalHeader msg serial sig $ fromIntegral . L.length $ bodyBytes pad 8 - append bodyBytes + appendL bodyBytes checkMaximumSize : :f DBus/Wire/Marshal.hs checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let - sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs - invalid = E.throwError $ InvalidBodySignature sigStr - in case T.mkSignature sigStr of + textSig = TL.concat . map (T.typeCode . T.variantType) $ vs + bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs + invalid = throwError $ InvalidBodySignature textSig + in case T.mkBytesSignature bytesSig of Just x -> return x Nothing -> invalid : @@ -886,13 +958,13 @@ -> Marshal marshalHeader msg serial bodySig bodyLength = do let fields = M.Signature bodySig : M.messageHeaderFields msg - marshal . T.toVariant . M.messageTypeCode $ msg - marshal . T.toVariant . encodeFlags . M.messageFlags $ msg - marshal . T.toVariant $ C.protocolVersion + marshalWord8 . M.messageTypeCode $ msg + marshalWord8 . encodeFlags . M.messageFlags $ msg + marshalWord8 C.protocolVersion marshalWord32 bodyLength - marshal . T.toVariant $ serial + marshalWord32 . M.serialValue $ serial let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] - marshal . T.toVariant . fromJust . T.toArray fieldType + marshalArray . fromJust . T.toArray fieldType $ map encodeField fields : @@ -904,9 +976,9 @@ :f DBus/Wire/Marshal.hs checkMaximumSize :: Marshal checkMaximumSize = do - (MarshalState _ _ messageLength) <- State.get + (MarshalState _ messageLength) <- getState when (messageLength > fromIntegral C.messageMaximumLength) - (E.throwError $ MessageTooLong $ fromIntegral messageLength) + (throwError $ MessageTooLong $ fromIntegral messageLength) : \subsubsection{Unmarshaling} @@ -921,10 +993,10 @@ :f DBus/Wire/Unmarshal.hs |apidoc unmarshalMessage| -unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) +unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do - let getBytes = lift . getBytes' + let getBytes = E.ErrorT . liftM Right . getBytes' |read fixed-length header| |read full header| @@ -945,18 +1017,18 @@ parsed. :d read fixed-length header -let messageVersion = L.index fixedBytes 3 +let messageVersion = BL.index fixedBytes 3 when (messageVersion /= C.protocolVersion) $ - E.throwError $ UnsupportedProtocolVersion messageVersion + E.throwErrorT $ UnsupportedProtocolVersion messageVersion : Next is the endianness, used for parsing pretty much every other field. :d read fixed-length header -let eByte = L.index fixedBytes 0 +let eByte = BL.index fixedBytes 0 endianness <- case decodeEndianness eByte of Just x' -> return x' - Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte + Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte : With the endianness out of the way, the rest of the fixed header @@ -965,7 +1037,7 @@ :d read fixed-length header let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of Right x' -> return x' - Left e -> E.throwError e + Left e -> E.throwErrorT e fixed <- unmarshal' fixedSig fixedBytes let typeCode = fromJust . T.fromVariant $ fixed !! 1 let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 @@ -987,7 +1059,7 @@ :d read full header let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount -let headerBytes = L.append fixedBytes fieldBytes +let headerBytes = BL.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes : @@ -996,7 +1068,9 @@ :d read full header let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray -fields <- concat `liftM` mapM decodeField fieldStructures +fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of + Left err -> E.throwErrorT err + Right x -> return x : The body is always aligned to 8 bytes, so pull out the padding before @@ -1027,29 +1101,17 @@ Even if the received message was structurally valid, building the {\tt ReceivedMessage} can still fail due to missing header fields. -Slightly ugly; to avoid orphan instances of either {\tt Text} or -{\tt Either}, a newtype is used to turn {\tt Either} into a monad. - -:f DBus/Wire/Unmarshal.hs -newtype EitherM a b = EitherM (Either a b) - -instance Monad (EitherM a) where - return = EitherM . Right - (EitherM (Left x)) >>= _ = EitherM (Left x) - (EitherM (Right x)) >>= k = k x -: - :d build message -y <- case buildReceivedMessage typeCode fields of - EitherM (Right x) -> return x - EitherM (Left x) -> E.throwError $ MissingHeaderField x +y <- case E.runErrorM $ buildReceivedMessage typeCode fields of + Right x -> return x + Left err -> E.throwErrorT $ MissingHeaderField err return $ y serial flags body : This really belongs in the Message section... :f DBus/Wire/Unmarshal.hs -buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text +buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) : @@ -1117,9 +1179,9 @@ : :f DBus/Wire/Unmarshal.hs -require :: Text -> [a] -> EitherM Text a +require :: Text -> [a] -> E.ErrorM Text a require _ (x:_) = return x -require label _ = EitherM $ Left label +require label _ = E.throwErrorM label : :f Tests.hs