diff --git a/DBus/Address.lhs b/DBus/Address.lhs deleted file mode 100644 --- a/DBus/Address.lhs +++ /dev/null @@ -1,137 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Address - ( Address - , addressMethod - , addressParameters - , strAddress - , parseAddresses - ) where - -import Data.Char (ord, chr) -import qualified Data.Map as M -import Data.List (intercalate) -import Text.Printf (printf) -import qualified Text.Parsec as P -import Text.Parsec ((<|>)) -import DBus.Util (hexToInt, eitherToMaybe) -\end{code} -} - -\clearpage -\section{Addresses} - -\subsection{Address syntax} - -A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...} -where the method may be empty and parameters are optional. An address's -parameter list, if present, may end with a comma. Addresses in environment -variables are separated by semicolons, and the full address list may end -in a semicolon. Multiple parameters may have the same key; in this case, -only the first parameter for each key will be stored. - -The bytes allowed in each component of the address are given by the following -chart, where each character is understood to be its ASCII value: - -\begin{table}[h] -\begin{center} -\begin{tabular}{ll} -\toprule -Component & Allowed Characters \\ -\midrule -Method & Any except {\tt `;'} and {\tt `:'} \\ -Param key & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\ -Param value & {\tt `0'} to {\tt `9'} \\ - & {\tt `a'} to {\tt `z'} \\ - & {\tt `A'} to {\tt `Z'} \\ - & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\ -\bottomrule -\end{tabular} -\end{center} -\end{table} - -In parameter values, any byte may be encoded by prepending the \% character -to its value in hexadecimal. \% is not allowed to appear unless it is -followed by two hexadecimal digits. Every other allowed byte is termed -an ``optionally encoded'' byte, and may appear unescaped in parameter -values. - -\begin{code} -optionallyEncoded :: String -optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." -\end{code} - -The address simply stores its method and parameter map, with a custom -{\tt Show} instance to provide easier debugging. - -\begin{code} -data Address = Address - { addressMethod :: String - , addressParameters :: M.Map String String - } deriving (Eq) - -instance Show Address where - showsPrec d x = showParen (d> 10) $ - showString' ["Address \"", strAddress x, "\""] where - showString' = foldr (.) id . map showString -\end{code} - -Parsing is straightforward; the input string is divided into addresses by -semicolons, then further by colons and commas. Parsing will fail if any -of the addresses in the input failed to parse. - -\begin{code} -parseAddresses :: String -> Maybe [Address] -parseAddresses s = eitherToMaybe $ P.parse parser "" s where - address = do - method <- P.many (P.noneOf ":;") - P.char ':' - params <- P.sepEndBy param (P.char ',') - return $ Address method (M.fromList params) - - param = do - key <- P.many1 (P.noneOf "=;,") - P.char '=' - value <- P.many1 (encodedValue <|> unencodedValue) - return (key, value) - - parser = do - as <- P.sepEndBy1 address (P.char ';') - P.eof - return as - - unencodedValue = P.oneOf optionallyEncoded - encodedValue = do - P.char '%' - hex <- P.count 2 P.hexDigit - return . chr . hexToInt $ hex -\end{code} - -Converting an {\tt Address} back to a {\tt String} is just the reverse -operation. Note that because the original parameter order is not preserved, -the string produced might differ from the original input. - -\begin{code} -strAddress :: Address -> String -strAddress (Address t ps) = t ++ ":" ++ ps' where - ps' = intercalate "," $ do - (k, v) <- M.toList ps - [k ++ "=" ++ (v >>= encode)] - encode c | elem c optionallyEncoded = [c] - | otherwise = printf "%%%02X" (ord c) -\end{code} diff --git a/DBus/Authentication.lhs b/DBus/Authentication.lhs deleted file mode 100644 --- a/DBus/Authentication.lhs +++ /dev/null @@ -1,70 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Authentication (authenticate) where - -import Data.Char (ord) -import Data.Word (Word32) -import Data.List (isPrefixOf) -import System.Posix.User (getRealUserID) -import Text.Printf (printf) -\end{code} -} - -\section{Authentication} - -\begin{code} -authenticate :: (String -> IO ()) -> (Word32 -> IO String) - -> IO () -authenticate put get = do - put "\x00" -\end{code} - -{\tt EXTERNAL} authentication is performed using the process's real user -ID, converted to a string, and then hex-encoded. - -\begin{code} - uid <- getRealUserID - let authToken = concatMap (printf "%02X" . ord) (show uid) - put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" -\end{code} - -If authentication was successful, the server responds with {\tt OK -}. The GUID is intended to enable connection sharing, which -is currently unimplemented, so it's ignored. - -\begin{code} - response <- readUntil '\n' get - if "OK" `isPrefixOf` response - then put "BEGIN\r\n" - else do - putStrLn $ "response = " ++ show response - error "Server rejected authentication token." -\end{code} - -\begin{code} -readUntil :: Monad m => Char -> (Word32 -> m String) -> m String -readUntil = readUntil' "" - -readUntil' :: Monad m => String -> Char -> (Word32 -> m String) -> m String -readUntil' xs c f = do - [x] <- f 1 - let xs' = xs ++ [x] - if x == c - then return xs' - else readUntil' xs' c f -\end{code} diff --git a/DBus/Bus.lhs b/DBus/Bus.lhs deleted file mode 100644 --- a/DBus/Bus.lhs +++ /dev/null @@ -1,131 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Bus - ( getSystemBus - , getSessionBus - , getFirstBus - , getBus - ) where - -import qualified Control.Exception as E -import Control.Monad (when) -import Data.Maybe (fromJust, isNothing) -import qualified Data.Set as Set -import System.Environment (getEnv) - -import qualified DBus.Address as A -import qualified DBus.Connection as C -import DBus.Constants (dbusName, dbusPath, dbusInterface) -import qualified DBus.Message as M -import qualified DBus.Types as T -\end{code} -} - -\clearpage -\section{Connecting to a message bus} - -Connecting to a message bus is a bit more involved than just connecting -over an app-to-app connection: the bus must be notified of the new client, -using a "hello message", before it will begin forwarding messages. - -\begin{code} -getBus :: A.Address -> IO (C.Connection, T.BusName) -getBus addr = do - c <- C.connect addr - name <- sendHello c - return (c, name) -\end{code} - -Optionally, multiple addresses may be provided. The first successfully -connected bus will be returned. - -\begin{code} -getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) -getFirstBus as = getFirstBus' as as - -getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName) -getFirstBus' orig [] = E.throwIO $ C.NoWorkingAddress orig -getFirstBus' orig (a:as) = E.catch (getBus a) onError where - onError :: E.SomeException -> IO (C.Connection, T.BusName) - onError _ = getFirstBus' orig as -\end{code} - -\subsection{Default connections} - -Two default buses are defined, the ``system'' and ``session'' buses. The system -bus is global for the OS, while the session bus runs only for the duration -of the user's session. - -\begin{code} -getSystemBus :: IO (C.Connection, T.BusName) -getSystemBus = getBus addr where - systemBusPath = "unix:path=/var/run/dbus/system_bus_socket" - Just [addr] = A.parseAddresses systemBusPath -\end{code} - -\begin{code} -getSessionBus :: IO (C.Connection, T.BusName) -getSessionBus = do - env <- getEnv "DBUS_SESSION_BUS_ADDRESS" - - case A.parseAddresses env of - Just [x] -> getBus x - Just x -> getFirstBus x - _ -> E.throwIO $ C.InvalidAddress env -\end{code} - -\subsection{Sending the ``hello'' message} - -\begin{code} -hello :: M.MethodCall -hello = M.MethodCall dbusPath - (T.mkMemberName' "Hello") - (Just dbusInterface) - (Just dbusName) - Set.empty - [] -\end{code} - -\begin{code} -sendHello :: C.Connection -> IO T.BusName -sendHello c = do - serial <- C.send c return hello - reply <- waitForReply c serial - let name = case M.methodReturnBody reply of - [x] -> T.fromVariant x - _ -> Nothing - - when (isNothing name) - (E.throwIO . C.ProtocolException $ - "Received inappropriate reply to Hello().") - - return . fromJust $ name -\end{code} - -\begin{code} -waitForReply :: C.Connection -> T.Serial -> IO M.MethodReturn -waitForReply c serial = do - msg <- C.receive c - case msg of - (M.ReceivedMethodReturn _ _ reply) -> - if M.methodReturnSerial reply == serial - then return reply - else waitForReply c serial - _ -> waitForReply c serial -\end{code} - diff --git a/DBus/Connection.lhs b/DBus/Connection.lhs deleted file mode 100644 --- a/DBus/Connection.lhs +++ /dev/null @@ -1,237 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Connection - ( Connection - , ConnectionException (..) - , ProtocolException (..) - , connect - , send - , receive - ) where - -import qualified Control.Concurrent as C -import qualified Control.Exception as E - -import Data.Word (Word32) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.UTF8 (toString, fromString) -import qualified Data.Map as Map -import Data.Typeable (Typeable) - -import qualified Network as N -import qualified System.IO as I - -import qualified DBus.Address as A -import qualified DBus.Types as T -import DBus.Message (Message, ReceivedMessage, marshal, unmarshal) -import DBus.Authentication (authenticate) -\end{code} -} - -\clearpage -\section{Connections} - -A {\tt Connection} is an opaque handle to an open DBus channel, with -an internal state for maintaining the current message serial. - -\begin{code} -data Connection = Connection A.Address Transport (C.MVar T.Serial) -\end{code} - -While not particularly useful for other functions, being able to {\tt show} -a {\tt Connection} is useful when debugging. - -\begin{code} -instance Show Connection where - showsPrec d (Connection a _ _) = showParen (d > 10) $ - showString' [""] where - showString' = foldr (.) id . map showString -\end{code} - -A connection can be opened to any valid address, though actually connecting -might fail due to external factors. - -\begin{code} -connect :: A.Address -> IO Connection -connect a = do - t <- connectTransport a - let putS = transportSend t . fromString - let getS = fmap toString . transportRecv t - authenticate putS getS - serialMVar <- C.newMVar T.firstSerial - return $ Connection a t serialMVar -\end{code} - -Sending a message will increment the connection's internal serial state. -The second parameter is present to allow registration of a callback before -the message has actually been sent, which avoids race conditions in -multi-threaded clients. - -\begin{code} -send :: Message a => Connection -> (T.Serial -> IO b) -> a -> IO b -send (Connection _ t mvar) io msg = withSerial mvar $ \serial -> do - x <- io serial - transportSend t . marshal T.LittleEndian serial $ msg - return x - -withSerial :: C.MVar T.Serial -> (T.Serial -> IO a) -> IO a -withSerial m io = E.block $ do - s <- C.takeMVar m - let s' = T.nextSerial s - x <- E.unblock (io s) `E.onException` C.putMVar m s' - C.putMVar m s' - return x -\end{code} - -Messages are received wrapped in a {\tt ReceivedMessage} value. If an error -is encountered while unmarshaling, an exception will be thrown. - -\begin{code} -receive :: Connection -> IO ReceivedMessage -receive (Connection _ t _) = do - either' <- unmarshal $ transportRecv t - case either' of - Right x -> return x - Left err -> E.throwIO . ProtocolException $ err -\end{code} - -\section{Transports} - -A transport is anything which can send and receive bytestrings, typically -over a socket. - -\begin{code} -data Transport = Transport - { transportSend :: L.ByteString -> IO () - , transportRecv :: Word32 -> IO L.ByteString - } -\end{code} - -\begin{code} -connectTransport :: A.Address -> IO Transport -connectTransport a = transport' (A.addressMethod a) a where - transport' "unix" = unix - transport' _ = unknownTransport -\end{code} - -\subsection{UNIX} - -The {\sc unix} transport accepts two parameters: {\tt path}, which is a -simple filesystem path, and {\tt abstract}, which is a path in the -Linux-specific abstract domain. One, and only one, of these parameters must -be specified. - -\begin{code} -unix :: A.Address -> IO Transport -unix a = handleTransport . N.connectTo "localhost" =<< port where - params = A.addressParameters a - path = Map.lookup "path" params - abstract = Map.lookup "abstract" params - - tooMany = "Only one of `path' or `abstract' may be specified for the" - ++ " `unix' method." - tooFew = "One of `path' or `abstract' must be specified for the" - ++ " `unix' transport." - - port = fmap N.UnixSocket path' - path' = case (path, abstract) of - (Just _, Just _) -> E.throwIO $ BadParameters a tooMany - (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew - (Just x, Nothing) -> return x - (Nothing, Just x) -> return $ '\x00':x -\end{code} - -\subsection{TCP} - -known parameters: - -\begin{itemize} -\item {\tt host} (optional, default "{\tt localhost}") -\item {\tt port} -\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}" -\end{itemize} - -TCP support is TODO - -\begin{otherCode} -tcp :: A.Address -> IO Transport -tcp a@(A.Address _ params) = handleTransport a connect' where - host = lookup "host" params - port = parsePort =<< lookup "post" params - family = parseFamily =<< lookup "family" params - connect' = do - -- check host - -- check port - -- check family - -- return handle -parsePort :: String -> Maybe PortNumber - -parseFamily :: String -> Maybe Family -\end{otherCode} - -\subsection{Generic handle-based transport} - -Both UNIX and TCP are backed by standard handles, and can therefore use -a shared handle-based transport backend. - -\begin{code} -handleTransport :: IO I.Handle -> IO Transport -handleTransport io = do - h <- io - I.hSetBuffering h I.NoBuffering - I.hSetBinaryMode h True - return $ Transport (L.hPut h) (L.hGet h . fromIntegral) -\end{code} - -\subsection{Unknown transports} - -If a method has no known transport, attempting to connect using it will -just result in an exception. - -\begin{code} -unknownTransport :: A.Address -> IO Transport -unknownTransport = E.throwIO . UnknownMethod -\end{code} - -\subsection{Errors} - -If connecting to DBus fails, a {\tt ConnectionException} will be thrown. -The constructor describes which exception occurred. - -\begin{code} -data ConnectionException - = InvalidAddress String - | BadParameters A.Address String - | UnknownMethod A.Address - | NoWorkingAddress [A.Address] - deriving (Show, Typeable) - -instance E.Exception ConnectionException -\end{code} - -If a message cannot be unmarshaled --- for example, due to malformed or -truncated input --- a {\tt ProtocolException} will be thrown. - -\begin{code} -data ProtocolException = ProtocolException String - deriving (Show, Typeable) - -instance E.Exception ProtocolException -\end{code} - diff --git a/DBus/Constants.lhs b/DBus/Constants.lhs deleted file mode 100644 --- a/DBus/Constants.lhs +++ /dev/null @@ -1,271 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Constants where -import qualified DBus.Types as T -import Data.Word (Word8) -\end{code} -} - -\clearpage -\section{Constants} - -\begin{code} -protocolVersion :: Word8 -protocolVersion = 1 -\end{code} - -\subsection{Main bus location} - -\begin{code} -dbusName :: T.BusName -dbusName = T.mkBusName' "org.freedesktop.DBus" -\end{code} - -\begin{code} -dbusPath :: T.ObjectPath -dbusPath = T.mkObjectPath' "/org/freedesktop/DBus" -\end{code} - -\begin{code} -dbusInterface :: T.InterfaceName -dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus" -\end{code} - -\subsection{Other pre-defined interfaces} - -\begin{code} -interfaceIntrospectable :: T.InterfaceName -interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" -\end{code} - -\begin{code} -interfaceProperties :: T.InterfaceName -interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties" -\end{code} - -\begin{code} -interfacePeer :: T.InterfaceName -interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer" -\end{code} - -\subsection{Pre-defined error names} - -\begin{code} -errorFailed :: T.ErrorName -errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed" -\end{code} - -\begin{code} -errorNoMemory :: T.ErrorName -errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory" -\end{code} - -\begin{code} -errorServiceUnknown :: T.ErrorName -errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown" -\end{code} - -\begin{code} -errorNameHasNoOwner :: T.ErrorName -errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner" -\end{code} - -\begin{code} -errorNoReply :: T.ErrorName -errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply" -\end{code} - -\begin{code} -errorIOError :: T.ErrorName -errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError" -\end{code} - -\begin{code} -errorBadAddress :: T.ErrorName -errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress" -\end{code} - -\begin{code} -errorNotSupported :: T.ErrorName -errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported" -\end{code} - -\begin{code} -errorLimitsExceeded :: T.ErrorName -errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded" -\end{code} - -\begin{code} -errorAccessDenied :: T.ErrorName -errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied" -\end{code} - -\begin{code} -errorAuthFailed :: T.ErrorName -errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed" -\end{code} - -\begin{code} -errorNoServer :: T.ErrorName -errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer" -\end{code} - -\begin{code} -errorTimeout :: T.ErrorName -errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout" -\end{code} - -\begin{code} -errorNoNetwork :: T.ErrorName -errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork" -\end{code} - -\begin{code} -errorAddressInUse :: T.ErrorName -errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse" -\end{code} - -\begin{code} -errorDisconnected :: T.ErrorName -errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected" -\end{code} - -\begin{code} -errorInvalidArgs :: T.ErrorName -errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs" -\end{code} - -\begin{code} -errorFileNotFound :: T.ErrorName -errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound" -\end{code} - -\begin{code} -errorFileExists :: T.ErrorName -errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists" -\end{code} - -\begin{code} -errorUnknownMethod :: T.ErrorName -errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod" -\end{code} - -\begin{code} -errorTimedOut :: T.ErrorName -errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut" -\end{code} - -\begin{code} -errorMatchRuleNotFound :: T.ErrorName -errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound" -\end{code} - -\begin{code} -errorMatchRuleInvalid :: T.ErrorName -errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid" -\end{code} - -\begin{code} -errorSpawnExecFailed :: T.ErrorName -errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed" -\end{code} - -\begin{code} -errorSpawnForkFailed :: T.ErrorName -errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed" -\end{code} - -\begin{code} -errorSpawnChildExited :: T.ErrorName -errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited" -\end{code} - -\begin{code} -errorSpawnChildSignaled :: T.ErrorName -errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled" -\end{code} - -\begin{code} -errorSpawnFailed :: T.ErrorName -errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed" -\end{code} - -\begin{code} -errorSpawnFailedToSetup :: T.ErrorName -errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup" -\end{code} - -\begin{code} -errorSpawnConfigInvalid :: T.ErrorName -errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" -\end{code} - -\begin{code} -errorSpawnServiceNotValid :: T.ErrorName -errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" -\end{code} - -\begin{code} -errorSpawnServiceNotFound :: T.ErrorName -errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" -\end{code} - -\begin{code} -errorSpawnPermissionsInvalid :: T.ErrorName -errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" -\end{code} - -\begin{code} -errorSpawnFileInvalid :: T.ErrorName -errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid" -\end{code} - -\begin{code} -errorSpawnNoMemory :: T.ErrorName -errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory" -\end{code} - -\begin{code} -errorUnixProcessIdUnknown :: T.ErrorName -errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown" -\end{code} - -\begin{code} -errorInvalidFileContent :: T.ErrorName -errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent" -\end{code} - -\begin{code} -errorSELinuxSecurityContextUnknown :: T.ErrorName -errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" -\end{code} - -\begin{code} -errorAdtAuditDataUnknown :: T.ErrorName -errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown" -\end{code} - -\begin{code} -errorObjectPathInUse :: T.ErrorName -errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse" -\end{code} - -\begin{code} -errorInconsistentMessage :: T.ErrorName -errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage" -\end{code} diff --git a/DBus/Marshal.lhs b/DBus/Marshal.lhs deleted file mode 100644 --- a/DBus/Marshal.lhs +++ /dev/null @@ -1,242 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Marshal (marshal) where - -import Control.Arrow (first) -import Control.Monad (msum) -import qualified Control.Monad.State as S -import Data.Maybe (fromJust) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.UTF8 (fromString) -import qualified Data.Binary.Put as P -import qualified Data.Binary.IEEE754 as IEEE - -import DBus.Padding (padding, alignment) -import qualified DBus.Types as T -\end{code} -} - -\clearpage -\section{Marshaling} -\subsection{\tt marshal} - -\begin{code} -marshal :: T.Endianness -> [T.Variant] -> L.ByteString -marshal e vs = runMarshal (mapM_ marshalAny vs) e -\end{code} - -\begin{code} -marshalAny :: T.Variant -> Marshal -marshalAny x = marshal' (T.variantType x) x where - v :: T.Variable a => T.Variant -> a - v = fromJust . T.fromVariant - - marshal' T.BooleanT = bool . v - marshal' T.ByteT = word8 . v - marshal' T.UInt16T = word16 . v - marshal' T.UInt32T = word32 . v - marshal' T.UInt64T = word64 . v - marshal' T.Int16T = int16 . v - marshal' T.Int32T = int32 . v - marshal' T.Int64T = int64 . v - marshal' T.DoubleT = double . v - marshal' T.StringT = string . v - marshal' T.ObjectPathT = objectPath . v - marshal' T.SignatureT = signature . v - marshal' (T.ArrayT _) = array . v - marshal' (T.DictionaryT _ _) = dictionary . v - marshal' (T.StructureT _) = structure . v - marshal' T.VariantT = variant . v -\end{code} - -\subsection{Atoms} - -\begin{code} -bool :: Bool -> Marshal -bool x = word32 (if x then 1 else 0) -\end{code} - -\begin{code} -word8 :: Word8 -> Marshal -word8 x = append (L.pack [x]) -\end{code} - -\begin{code} -word16 :: Word16 -> Marshal -word16 = appendPut P.putWord16be -\end{code} - -\begin{code} -word32 :: Word32 -> Marshal -word32 = appendPut P.putWord32be -\end{code} - -\begin{code} -word64 :: Word64 -> Marshal -word64 = appendPut P.putWord64be -\end{code} - -\begin{code} -int16 :: Int16 -> Marshal -int16 = appendPut P.putWord16be . fromIntegral -\end{code} - -\begin{code} -int32 :: Int32 -> Marshal -int32 = appendPut P.putWord32be . fromIntegral -\end{code} - -\begin{code} -int64 :: Int64 -> Marshal -int64 = appendPut P.putWord64be . fromIntegral -\end{code} - -\begin{code} -double :: Double -> Marshal -double = appendPut IEEE.putFloat64be -\end{code} - -\begin{code} -string :: String -> Marshal -string x = do - let bytes = fromString x - word32 . fromIntegral . L.length $ bytes - append bytes - append (L.pack [0]) -\end{code} - -\begin{code} -objectPath :: T.ObjectPath -> Marshal -objectPath = string . T.strObjectPath -\end{code} - -\begin{code} -signature :: T.Signature -> Marshal -signature x = do - let bytes = fromString . T.strSignature $ x - word8 . fromIntegral . L.length $ bytes - append bytes - append (L.pack [0]) -\end{code} - -\subsection{Containers} - -\subsubsection{Arrays} - -Marshaling arrays is complicated, because the array body must be marshaled -\emph{first} to calculate the array length. This requires building a -temporary marshaler, to get the padding right. - -\begin{code} -array :: T.Array -> Marshal -array x = do - (arrayPadding, arrayBytes) <- getArrayBytes x - word32 . fromIntegral . L.length $ arrayBytes - append arrayPadding - append arrayBytes -\end{code} - -\begin{code} -getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString) -getArrayBytes x = do - let vs = T.arrayItems x - let [T.ArrayT itemType] = T.signatureTypes . T.arraySignature $ x - s <- S.get - (MarshalState _ afterLength) <- word32 0 >> S.get - (MarshalState _ afterPadding) <- pad (alignment itemType) >> S.get - (MarshalState _ afterItems) <- mapM_ marshalAny vs >> S.get - - let paddingBytes = L.drop (L.length afterLength) afterPadding - let itemBytes = L.drop (L.length afterPadding) afterItems - - S.put s - return (paddingBytes, itemBytes) -\end{code} - -\subsubsection{Dictionaries} - -\begin{code} -dictionary :: T.Dictionary -> Marshal -dictionary x = array x' where - pairs = map (first T.atomToVariant) (T.dictionaryItems x) - structs = [T.Structure [k,v] | (k,v) <- pairs] - x' = fromJust . T.toArray $ structs -\end{code} - -\subsubsection{Structures} - -\begin{code} -structure :: T.Structure -> Marshal -structure (T.Structure xs) = pad 8 >> mapM_ marshalAny xs -\end{code} - -\subsubsection{Variants} - -\begin{code} -variant :: T.Variant -> Marshal -variant x = signature (T.variantSignature x) >> marshalAny x -\end{code} - -\subsection{The {\tt Marshal} monad} - -{\tt Marshal} implements stateful marshaling, which is required for padding -to be calculated properly. - -\begin{code} -data MarshalState = MarshalState T.Endianness L.ByteString -type MarshalM = S.State MarshalState -type Marshal = MarshalM () -\end{code} - -\begin{code} -runMarshal :: Marshal -> T.Endianness -> L.ByteString -runMarshal m e = bytes where - initialState = MarshalState e L.empty - (MarshalState _ bytes) = S.execState m initialState -\end{code} - -\begin{code} -append :: L.ByteString -> Marshal -append bs = do - (MarshalState e bs') <- S.get - S.put $ MarshalState e (L.append bs' bs) -\end{code} - -Add padding to the end of the marshaled bytes, until the length is a -multiple of {\tt count}. - -\begin{code} -pad :: Word8 -> Marshal -pad count = do - (MarshalState _ bytes) <- S.get - let padding' = padding (fromIntegral . L.length $ bytes) count - append $ L.replicate (fromIntegral padding') 0 -\end{code} - -\begin{code} -appendPut :: (a -> P.Put) -> a -> Marshal -appendPut put x = do - let bytes = P.runPut $ put x - (MarshalState e _) <- S.get - pad . fromIntegral . L.length $ bytes - append $ case e of - T.BigEndian -> bytes - T.LittleEndian -> L.reverse bytes -\end{code} diff --git a/DBus/Message.lhs b/DBus/Message.lhs deleted file mode 100644 --- a/DBus/Message.lhs +++ /dev/null @@ -1,536 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Message - ( -- * Message structure and fields - Message (..) - , Flag (..) - , HeaderField (..) - - -- * Message types - -- ** Method calls - , MethodCall (..) - - -- ** Method returns - , MethodReturn (..) - - -- ** Errors - , Error (..) - - -- ** Signals - , Signal (..) - - -- * Received messages - , ReceivedMessage (..) - , receivedSerial - , receivedSender - - -- * (Un)marshaling - , marshal - , unmarshal - ) where - -import Control.Monad (unless) -import qualified Control.Monad.Error as E -import Data.Bits ((.|.), (.&.)) -import Data.Word (Word8, Word32) -import qualified Data.ByteString.Lazy as L -import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe) -import qualified Data.Set as S - -import qualified DBus.Marshal as M -import qualified DBus.Unmarshal as U -import DBus.Padding (padding) -import qualified DBus.Types as T -import DBus.Constants (protocolVersion) -\end{code} -} - -\clearpage -\section{Messages} - -A message represents a single message, with a header and body. Some parts -of the header, such as the serial, endianness, and body length, are not -included in the message --- instead, they are generated when a message is -marshalled. - -\begin{code} -class Message a where - messageTypeCode :: a -> Word8 - messageHeaderFields :: a -> [HeaderField] - messageFlags :: a -> S.Set Flag - messageBody :: a -> [T.Variant] -\end{code} - -\subsection{Flags} - -Flags are represented as the integral value of each flag OR'd into a single -byte. - -The instance of {\tt Ord} only exists for storing flags in a set. Flags have -no inherent ordering. - -\begin{code} -data Flag = NoReplyExpected - | NoAutoStart - deriving (Show, Eq, Ord) -\end{code} - -\begin{code} -encodeFlags :: [Flag] -> Word8 -encodeFlags flags = foldr (.|.) 0 $ map flagValue flags where - flagValue NoReplyExpected = 0x1 - flagValue NoAutoStart = 0x2 -\end{code} - -\begin{code} -decodeFlags :: Word8 -> [Flag] -decodeFlags flagsByte = flags where - flagSet = [(0x1, NoReplyExpected), (0x2, NoAutoStart)] - flags = flagSet >>= \(x, y) -> [y | flagsByte .&. x > 0] -\end{code} - -\subsection{Header fields} - -\begin{code} -data HeaderField - = Path T.ObjectPath - | Interface T.InterfaceName - | Member T.MemberName - | ErrorName T.ErrorName - | ReplySerial T.Serial - | Destination T.BusName - | Sender T.BusName - | Signature T.Signature - deriving (Show, Eq) -\end{code} - -\begin{code} -header' :: T.Variable a => Word8 -> a -> T.Variant -header' code x = T.toVariant $ T.Structure - [ T.toVariant code - , T.toVariant $ T.toVariant x - ] - -unheader :: T.Variant -> Maybe (Word8, T.Variant) -unheader structV = do - struct <- T.fromVariant structV - (c, v) <- case struct of - T.Structure [x, y] -> return (x, y) - _ -> Nothing - c' <- T.fromVariant c - v' <- T.fromVariant v - return (c', v') - -instance T.Variable HeaderField where - defaultSignature _ = T.mkSignature' "(yv)" - - toVariant (Path x) = header' 1 x - toVariant (Interface x) = header' 2 x - toVariant (Member x) = header' 3 x - toVariant (ErrorName x) = header' 4 x - toVariant (ReplySerial x) = header' 5 x - toVariant (Destination x) = header' 6 x - toVariant (Sender x) = header' 7 x - toVariant (Signature x) = header' 8 x - - fromVariant v = unheader v >>= \v' -> case v' of - (1, x) -> fmap Path $ T.fromVariant x - (2, x) -> fmap Interface $ T.fromVariant x - (3, x) -> fmap Member $ T.fromVariant x - (4, x) -> fmap ErrorName $ T.fromVariant x - (5, x) -> fmap ReplySerial $ T.fromVariant x - (6, x) -> fmap Destination $ T.fromVariant x - (7, x) -> fmap Sender $ T.fromVariant x - (8, x) -> fmap Signature $ T.fromVariant x - _ -> Nothing -\end{code} - -\subsection{Message types} - -\subsubsection{Method calls} - -\begin{code} -data MethodCall = MethodCall - { methodCallPath :: T.ObjectPath - , methodCallMember :: T.MemberName - , methodCallInterface :: Maybe T.InterfaceName - , methodCallDestination :: Maybe T.BusName - , methodCallFlags :: S.Set Flag - , methodCallBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message MethodCall where - messageTypeCode _ = 1 - messageFlags = methodCallFlags - messageBody = methodCallBody - messageHeaderFields m = concat - [ [ Path $ methodCallPath m - , Member $ methodCallMember m - ] - , maybe' Interface . methodCallInterface $ m - , maybe' Destination . methodCallDestination $ m - ] -\end{code} - -\subsubsection{Method returns} - -\begin{code} -data MethodReturn = MethodReturn - { methodReturnSerial :: T.Serial - , methodReturnDestination :: Maybe T.BusName - , methodReturnFlags :: S.Set Flag - , methodReturnBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message MethodReturn where - messageTypeCode _ = 2 - messageFlags = methodReturnFlags - messageBody = methodReturnBody - messageHeaderFields m = concat - [ [ ReplySerial $ methodReturnSerial m - ] - , maybe' Destination . methodReturnDestination $ m - ] -\end{code} - -\subsubsection{Errors} - -\begin{code} -data Error = Error - { errorName :: T.ErrorName - , errorSerial :: T.Serial - , errorDestination :: Maybe T.BusName - , errorFlags :: S.Set Flag - , errorBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message Error where - messageTypeCode _ = 3 - messageFlags = errorFlags - messageBody = errorBody - messageHeaderFields m = concat - [ [ ErrorName $ errorName m - , ReplySerial $ errorSerial m - ] - , maybe' Destination . errorDestination $ m - ] -\end{code} - -\subsubsection{Signals} - -\begin{code} -data Signal = Signal - { signalPath :: T.ObjectPath - , signalMember :: T.MemberName - , signalInterface :: T.InterfaceName - , signalFlags :: S.Set Flag - , signalBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message Signal where - messageTypeCode _ = 4 - messageFlags = signalFlags - messageBody = signalBody - messageHeaderFields m = - [ Path $ signalPath m - , Member $ signalMember m - , Interface $ signalInterface m - ] -\end{code} - -\begin{code} -maybe' :: (a -> b) -> Maybe a -> [b] -maybe' f = maybe [] (\x' -> [f x']) -\end{code} - -\subsection{Message headers} - -\begin{code} -data MessageHeader = MessageHeader - { headerEndianness :: T.Endianness - , headerTypeCode :: Word8 - , headerFlags :: S.Set Flag - , headerProtocol :: Word8 - , headerBodySize :: Word32 - , headerSerial :: T.Serial - , headerFields :: [HeaderField] - } deriving (Show, Eq) -\end{code} - -\begin{code} -buildHeader :: Message a => T.Endianness -> T.Serial -> a -> Word32 - -> MessageHeader -buildHeader endianness serial m bodyLen = header where - ts = map T.variantType $ messageBody m - bodySig = T.mkSignature' $ concatMap T.typeString ts - fields = Signature bodySig : messageHeaderFields m - header = MessageHeader - endianness - (messageTypeCode m) - (messageFlags m) - protocolVersion - bodyLen - serial - fields -\end{code} - -\subsection{Marshaling} - -{\tt marshal} converts a message into a byte string, suitable for sending -over the bus. - -\begin{code} -marshal :: Message a => T.Endianness -> T.Serial -> a -> L.ByteString -marshal e s m = L.append headerBytes bodyBytes where - bodyBytes = M.marshal e $ messageBody m - bodyLength = fromIntegral . L.length $ bodyBytes - header = marshalHeader (buildHeader e s m bodyLength) - headerBytes = M.marshal e $ header ++ [T.toVariant (T.Structure [])] -\end{code} - -Build the header struct for a message. Endianness, the serial, and body -length are provided. - -\begin{code} -marshalHeader :: MessageHeader -> [T.Variant] -marshalHeader h = map ($ h) - [ T.toVariant . headerEndianness - , T.toVariant . headerTypeCode - , T.toVariant . encodeFlags . S.toList . headerFlags - , T.toVariant . headerProtocol - , T.toVariant . headerBodySize - , T.toVariant . headerSerial - , T.toVariant . fromJust . T.toArray . headerFields - ] -\end{code} - -\subsection{Unmarshaling} - -\subsubsection{Received messages} - -Any messages parsed from the connection are stored in a -{\tt ReceivedMessage} value, so clients can know which type of message -was received, where it was sent from, and its serial. - -Unknown message types are parsed, but only to get the serial and bus name -(which might be useful for returning an {\tt Error}). Clients should ignore -unknown messages. - -\begin{code} -data ReceivedMessage - = ReceivedMethodCall T.Serial (Maybe T.BusName) MethodCall - | ReceivedMethodReturn T.Serial (Maybe T.BusName) MethodReturn - | ReceivedError T.Serial (Maybe T.BusName) Error - | ReceivedSignal T.Serial (Maybe T.BusName) Signal - | ReceivedUnknown T.Serial (Maybe T.BusName) - deriving (Show, Eq) - -receivedSerial :: ReceivedMessage -> T.Serial -receivedSerial (ReceivedMethodCall s _ _) = s -receivedSerial (ReceivedMethodReturn s _ _) = s -receivedSerial (ReceivedError s _ _) = s -receivedSerial (ReceivedSignal s _ _) = s -receivedSerial (ReceivedUnknown s _) = s - -receivedSender :: ReceivedMessage -> Maybe T.BusName -receivedSender (ReceivedMethodCall _ s _) = s -receivedSender (ReceivedMethodReturn _ s _) = s -receivedSender (ReceivedError _ s _) = s -receivedSender (ReceivedSignal _ s _) = s -receivedSender (ReceivedUnknown _ s) = s -\end{code} - -Unmarshaling is a three-step process: retrieve the raw bytes, parse the -header, then parse the body. With the header and body, it is possible to -construct a {\tt ReceivedMessage} of the proper type and attributes. - -\begin{code} -unmarshal :: Monad m => (Word32 -> m L.ByteString) - -> m (Either String ReceivedMessage) -unmarshal getBytes = E.runErrorT $ do - (endianness, headerBytes, bodyBytes) <- getRaw $ E.lift . getBytes - header <- parseHeader endianness headerBytes - let signature = findBodySignature . headerFields $ header - body <- U.unmarshal endianness signature bodyBytes - - mkReceived - (headerTypeCode header) - (headerSerial header) - (headerFields header) - (headerFlags header) - body -\end{code} - -First, some minimal parsing is required to retrieve the full byte buffer -from the input. This depends on the fixed structure of the message header to -pull in every required byte without fully parsing the header fields. - -\begin{code} -type RawMessage = (T.Endianness, L.ByteString, L.ByteString) -getRaw :: (E.Error e, E.MonadError e m) => - (Word32 -> m L.ByteString) -> m RawMessage -getRaw get = do - let fixed'Sig = T.mkSignature' "yyyy" - let fixedSig = T.mkSignature' "yyyyuuu" - - -- Protocol version - fixedBytes <- get 16 - fixed' <- U.unmarshal T.LittleEndian fixed'Sig fixedBytes - checkMatchingVersion $ fixed' !! 3 - - -- Endianness - endianness <- getEndianness $ fixed' !! 0 - - -- Header field bytes - fixed <- U.unmarshal endianness fixedSig fixedBytes - let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 - fieldBytes <- get fieldByteCount - - -- Post-field padding - let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 - get . fromIntegral $ bodyPadding - - -- Body bytes - let bodyByteCount = fromJust . T.fromVariant $ fixed !! 4 - bodyBytes <- get bodyByteCount - return (endianness, L.append fixedBytes fieldBytes, bodyBytes) -\end{code} - -\begin{code} -checkMatchingVersion :: (E.Error e, E.MonadError e m) => T.Variant -> m () -checkMatchingVersion v = unless (messageVersion == protocolVersion) $ - E.throwError . E.strMsg . concat $ - [ "Protocol version mismatch: " - , show messageVersion - , " != " - , show protocolVersion - ] - where messageVersion = fromJust . T.fromVariant $ v -\end{code} - -\begin{code} -getEndianness :: (E.Error e, E.MonadError e m) => T.Variant -> m T.Endianness -getEndianness v = maybe bad return $ T.fromVariant v where - word = fromJust . T.fromVariant $ v :: Word8 - bad = E.throwError . E.strMsg - $ "Invalid endianness code: " ++ show word -\end{code} - -Next, the header is parsed into a proper {\tt MessageHeader}. - -\begin{code} -parseHeader :: (E.Error e, E.MonadError e m) - => T.Endianness -> L.ByteString -> m MessageHeader -parseHeader endianness bytes = do - let signature = T.mkSignature' "yyyyuua(yv)" - vs <- U.unmarshal endianness signature bytes - let fieldArray = fromJust . T.fromVariant $ vs !! 6 - let fields = mapMaybe T.fromVariant $ T.arrayItems fieldArray - let flagByte = fromJust . T.fromVariant $ vs !! 2 - return $ MessageHeader - endianness - (fromJust . T.fromVariant $ vs !! 1) - (S.fromList . decodeFlags $ flagByte) - (fromJust . T.fromVariant $ vs !! 3) - (fromJust . T.fromVariant $ vs !! 4) - (fromJust . T.fromVariant $ vs !! 5) - fields -\end{code} - -If the header fields contain a body signature, it should be used for -unmarshaling the body. Otherwise, the body is assumed to be empty. - -\begin{code} -findBodySignature :: [HeaderField] -> T.Signature -findBodySignature fields = fromMaybe empty signature where - empty = T.mkSignature' "" - signature = listToMaybe [x | Signature x <- fields] -\end{code} - -\begin{code} -mkReceived :: (E.Error e, E.MonadError e m) - => Word8 -> T.Serial -> [HeaderField] -> S.Set Flag - -> [T.Variant] -> m ReceivedMessage -mkReceived 1 = mkReceived' ReceivedMethodCall mkMethodCall -mkReceived 2 = mkReceived' ReceivedMethodReturn mkMethodReturn -mkReceived 3 = mkReceived' ReceivedError mkError -mkReceived 4 = mkReceived' ReceivedSignal mkSignal -mkReceived _ = undefined -- mkReceived' ReceivedUnknown mkUnknown -\end{code} - -\begin{code} -mkReceived' :: (E.Error e, E.MonadError e m) - => (T.Serial -> Maybe T.BusName -> a -> ReceivedMessage) - -> ([HeaderField] -> S.Set Flag -> [T.Variant] -> m a) - -> T.Serial -> [HeaderField] -> S.Set Flag -> [T.Variant] - -> m ReceivedMessage -mkReceived' mkRecv mkMsg serial fields flags body = do - msg <- mkMsg fields flags body - let sender = listToMaybe [x | Sender x <- fields] - return $ mkRecv serial sender msg -\end{code} - -\begin{code} -mkMethodCall :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag - -> [T.Variant] -> m MethodCall -mkMethodCall fields flags body = do - path <- require "path" [x | Path x <- fields] - member <- require "member name" [x | Member x <- fields] - let iface = listToMaybe [x | Interface x <- fields] - let dest = listToMaybe [x | Destination x <- fields] - return $ MethodCall path member iface dest flags body -\end{code} - -\begin{code} -mkMethodReturn :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag - -> [T.Variant] -> m MethodReturn -mkMethodReturn fields flags body = do - serial <- require "reply serial" [x | ReplySerial x <- fields] - let dest = listToMaybe [x | Destination x <- fields] - return $ MethodReturn serial dest flags body -\end{code} - -\begin{code} -mkError :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag - -> [T.Variant] -> m Error -mkError fields flags body = do - name <- require "error name" [x | ErrorName x <- fields] - serial <- require "reply serial" [x | ReplySerial x <- fields] - let dest = listToMaybe [x | Destination x <- fields] - return $ Error name serial dest flags body -\end{code} - -\begin{code} -mkSignal :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag - -> [T.Variant] -> m Signal -mkSignal fields flags body = do - path <- require "path" [x | Path x <- fields] - member <- require "member" [x | Member x <- fields] - iface <- require "interface" [x | Interface x <- fields] - return $ Signal path member iface flags body -\end{code} - -\begin{code} -require :: (E.Error e, E.MonadError e m) => String -> [a] -> m a -require _ (x:_) = return x -require label _ = E.throwError . E.strMsg $ "Required field " ++ show label ++ " is missing." -\end{code} diff --git a/DBus/Padding.lhs b/DBus/Padding.lhs deleted file mode 100644 --- a/DBus/Padding.lhs +++ /dev/null @@ -1,59 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Padding - ( padding - , alignment - ) where - -import Data.Word (Word8, Word64) -import qualified DBus.Types as T -\end{code} -} - -\section{Byte padding and alignment} - -\begin{code} -padding :: Word64 -> Word8 -> Word64 -padding current count = required where - count' = fromIntegral count - missing = mod current count' - required = if missing > 0 - then count' - missing - else 0 -\end{code} - -\begin{code} -alignment :: T.Type -> Word8 -alignment T.BooleanT = 4 -alignment T.ByteT = 1 -alignment T.UInt16T = 2 -alignment T.UInt32T = 4 -alignment T.UInt64T = 8 -alignment T.Int16T = 2 -alignment T.Int32T = 4 -alignment T.Int64T = 8 -alignment T.DoubleT = 8 -alignment T.StringT = 4 -alignment T.ObjectPathT = 4 -alignment T.SignatureT = 1 -alignment (T.ArrayT _) = 4 -alignment (T.DictionaryT _ _) = 4 -alignment (T.StructureT _) = 8 -alignment T.VariantT = 1 -\end{code} - diff --git a/DBus/Types.lhs b/DBus/Types.lhs deleted file mode 100644 --- a/DBus/Types.lhs +++ /dev/null @@ -1,47 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Types - ( module DBus.Types.Atom - , module DBus.Types.Containers - , module DBus.Types.Endianness - , module DBus.Types.Names - , module DBus.Types.ObjectPath - , module DBus.Types.Serial - , module DBus.Types.Signature - ) where - -import DBus.Types.Atom -import DBus.Types.Containers -import DBus.Types.Endianness -import DBus.Types.Names -import DBus.Types.ObjectPath -import DBus.Types.Serial -import DBus.Types.Signature -\end{code} -} - -\clearpage -\section{Types} - -\input{DBus/Types/Containers.lhs} -\input{DBus/Types/Atom.lhs} -\input{DBus/Types/Signature.lhs} -\input{DBus/Types/Names.lhs} -\input{DBus/Types/ObjectPath.lhs} -\input{DBus/Types/Serial.lhs} -\input{DBus/Types/Endianness.lhs} diff --git a/DBus/Types/Atom.lhs b/DBus/Types/Atom.lhs deleted file mode 100644 --- a/DBus/Types/Atom.lhs +++ /dev/null @@ -1,108 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -module DBus.Types.Atom - ( -- * Atoms - Atom - , Atomic - , toAtom - , fromAtom - , atomSignature - , atomType - , atomToVariant - , atomFromVariant - ) where - -import Control.Monad (msum) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import qualified DBus.Types.Signature as S -import qualified DBus.Types.ObjectPath as O -import qualified DBus.Types.Containers.Variant as V -\end{code} -} - -\subsection{Atoms} - -Any atomic value can be used as a dictionary key. Types which might be -used for dict keys should implement {\tt Atomic}. - -\begin{code} -newtype Atom = Atom V.Variant - deriving (Show, Eq) - -class V.Variable a => Atomic a where - toAtom :: a -> Atom - -atomToVariant :: Atom -> V.Variant -atomToVariant (Atom x) = x - -atomFromVariant :: V.Variant -> Maybe Atom -atomFromVariant v = msum as where - v' :: V.Variable a => Maybe a - v' = V.fromVariant v - fa :: (Atomic a, Functor f) => f a -> f Atom - fa = fmap toAtom - - as = [fa (v' :: Maybe Bool) - ,fa (v' :: Maybe Word8) - ,fa (v' :: Maybe Word16) - ,fa (v' :: Maybe Word32) - ,fa (v' :: Maybe Word64) - ,fa (v' :: Maybe Int16) - ,fa (v' :: Maybe Int32) - ,fa (v' :: Maybe Int64) - ,fa (v' :: Maybe Double) - ,fa (v' :: Maybe String) - ,fa (v' :: Maybe O.ObjectPath) - ,fa (v' :: Maybe S.Signature) - ] -\end{code} - -\begin{code} -fromAtom :: V.Variable a => Atom -> Maybe a -fromAtom (Atom x) = V.fromVariant x -\end{code} - -\begin{code} -atomSignature :: Atom -> S.Signature -atomSignature (Atom v) = V.variantSignature v -\end{code} - -\begin{code} -atomType :: Atom -> S.Type -atomType = head . S.signatureTypes . atomSignature -\end{code} - -\begin{code} -toAtom' :: Atomic a => a -> Atom -toAtom' = Atom . V.toVariant - -instance Atomic Bool where toAtom = toAtom' -instance Atomic Word8 where toAtom = toAtom' -instance Atomic Word16 where toAtom = toAtom' -instance Atomic Word32 where toAtom = toAtom' -instance Atomic Word64 where toAtom = toAtom' -instance Atomic Int16 where toAtom = toAtom' -instance Atomic Int32 where toAtom = toAtom' -instance Atomic Int64 where toAtom = toAtom' -instance Atomic Double where toAtom = toAtom' -instance Atomic String where toAtom = toAtom' -instance Atomic O.ObjectPath where toAtom = toAtom' -instance Atomic S.Signature where toAtom = toAtom' -\end{code} diff --git a/DBus/Types/Containers.lhs b/DBus/Types/Containers.lhs deleted file mode 100644 --- a/DBus/Types/Containers.lhs +++ /dev/null @@ -1,49 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Types.Containers - ( -- * Containers - - -- ** Variants - Variant - , Variable (..) - , variantSignature - , variantType - - -- ** Arrays - , module DBus.Types.Containers.Array - - -- ** Dictionaries - , module DBus.Types.Containers.Dictionary - - -- ** Structures - , module DBus.Types.Containers.Structure - ) where - -import DBus.Types.Containers.Variant -import DBus.Types.Containers.Array -import DBus.Types.Containers.Dictionary -import DBus.Types.Containers.Structure -\end{code} -} - -\subsection{Containers} - -\input{DBus/Types/Containers/Array.lhs} -\input{DBus/Types/Containers/Dictionary.lhs} -\input{DBus/Types/Containers/Structure.lhs} -\input{DBus/Types/Containers/Variant.lhs} diff --git a/DBus/Types/Containers/Array.lhs b/DBus/Types/Containers/Array.lhs deleted file mode 100644 --- a/DBus/Types/Containers/Array.lhs +++ /dev/null @@ -1,84 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.Containers.Array - ( Array - , toArray - , fromArray - , arrayItems - , arrayFromItems - , arraySignature - ) where - -import Data.Typeable (Typeable, cast) -import qualified DBus.Types.Signature as S -import qualified DBus.Types.Containers.Variant as V -\end{code} -} - -\subsubsection{Arrays} - -Arrays are homogeneous sequences of any valid type. They may be -converted to and from standard Haskell lists, where the list contains elements with -a valid type. - -\begin{code} -data Array = Array S.Signature [V.Variant] - deriving (Show, Eq, Typeable) -\end{code} - -\begin{code} -instance V.Variable Array where - defaultSignature _ = S.mkSignature' "ay" - toVariant x = V.Variant (arraySignature x) x - fromVariant (V.Variant _ x) = cast x -\end{code} - -\begin{code} -toArray :: V.Variable a => [a] -> Maybe Array -toArray vs = arrayFromItems sig variants where - variants = map V.toVariant vs - sig = case vs of - [] -> V.defaultSignature . head $ undefined : vs - _ -> V.variantSignature . head $ variants -\end{code} - -\begin{code} -arrayFromItems :: S.Signature -> [V.Variant] -> Maybe Array -arrayFromItems itemSig vs = array where - array = if sameSignature - then Just (Array sig vs) - else Nothing - sig = S.mkSignature' $ 'a' : S.strSignature itemSig - sameSignature = all (== itemSig) . map V.variantSignature $ vs -\end{code} - -\begin{code} -fromArray :: V.Variable a => Array -> Maybe [a] -fromArray (Array _ vs) = mapM V.fromVariant vs -\end{code} - -\begin{code} -arrayItems :: Array -> [V.Variant] -arrayItems (Array _ vs) = vs -\end{code} - -\begin{code} -arraySignature :: Array -> S.Signature -arraySignature (Array s _) = s -\end{code} diff --git a/DBus/Types/Containers/Dictionary.lhs b/DBus/Types/Containers/Dictionary.lhs deleted file mode 100644 --- a/DBus/Types/Containers/Dictionary.lhs +++ /dev/null @@ -1,110 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.Containers.Dictionary - ( Dictionary - , toDictionary - , fromDictionary - , dictionaryItems - , dictionaryFromItems - , dictionarySignature - ) where - -import Control.Arrow ((***)) -import Data.Typeable (Typeable, cast) -import qualified DBus.Types.Signature as S -import qualified DBus.Types.Atom as A -import qualified DBus.Types.Containers.Variant as V -\end{code} -} - -\subsubsection{Dictionaries} - -Dictionaries are a key $\rightarrow$ value mapping, where the keys must be of an -{\tt Atomic} type, and the values may be of any valid DBus type. - -\begin{code} -data Dictionary = Dictionary S.Signature [(A.Atom, V.Variant)] - deriving (Show, Eq, Typeable) -\end{code} - -\begin{code} -instance V.Variable Dictionary where - defaultSignature _ = S.mkSignature' "a{yy}" - toVariant x = V.Variant (dictionarySignature x) x - fromVariant (V.Variant _ x) = cast x -\end{code} - -\begin{code} -toDictionary :: (A.Atomic a, V.Variable b) => [(a, b)] -> Maybe Dictionary -toDictionary pairs = dictionaryFromItems kSig vSig pairs' where - fakePair = head $ (undefined, undefined) : pairs - kSigFake = V.defaultSignature . fst $ fakePair - vSigFake = V.defaultSignature . snd $ fakePair - - pairs' = map (A.toAtom *** V.toVariant) pairs - kSigReal = A.atomSignature . fst . head $ pairs' - vSigReal = V.variantSignature . snd . head $ pairs' - - (kSig, vSig) = case pairs of - [] -> (kSigFake, vSigFake) - _ -> (kSigReal, vSigReal) -\end{code} - -\begin{code} -dictionaryFromItems :: S.Signature -> S.Signature -> [(A.Atom, V.Variant)] - -> Maybe Dictionary -dictionaryFromItems kSig vSig pairs = maybeDict where - maybeDict = if hasSignature kSig ks && hasSignature vSig vs - then Just (Dictionary sig pairs) - else Nothing - - ks = map (A.atomToVariant . fst) pairs - vs = map snd pairs - - kSig' = S.strSignature kSig - vSig' = S.strSignature vSig - sig = S.mkSignature' $ "a{" ++ kSig' ++ vSig' ++ "}" -\end{code} - -\begin{code} -fromDictionary :: (A.Atomic a, V.Variable b) => Dictionary -> Maybe [(a, b)] -fromDictionary (Dictionary _ vs) = mapM fromVariant' vs where - fromVariant' (k, v) = do - k' <- A.fromAtom k - v' <- V.fromVariant v - return (k', v') -\end{code} - -\begin{code} -dictionaryItems :: Dictionary -> [(A.Atom, V.Variant)] -dictionaryItems (Dictionary _ vs) = vs -\end{code} - -\begin{code} -dictionarySignature :: Dictionary -> S.Signature -dictionarySignature (Dictionary s _) = s -\end{code} - -\subsubsection*{Helper functions} - -\begin{code} -hasSignature :: S.Signature -> [V.Variant] -> Bool -hasSignature _ [] = True -hasSignature sig vs = all (== sig) . map V.variantSignature $ vs -\end{code} diff --git a/DBus/Types/Containers/Structure.lhs b/DBus/Types/Containers/Structure.lhs deleted file mode 100644 --- a/DBus/Types/Containers/Structure.lhs +++ /dev/null @@ -1,48 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.Containers.Structure - ( Structure (..) - , structureSignature - ) where - -import Data.Typeable (Typeable, cast) -import qualified DBus.Types.Signature as S -import qualified DBus.Types.Containers.Variant as V -\end{code} -} - -\subsubsection{Structures} - -Structures contain a heterogenous list of DBus values. Any value may be -contained within a structure. - -\begin{code} -data Structure = Structure [V.Variant] - deriving (Show, Eq, Typeable) - -instance V.Variable Structure where - defaultSignature _ = S.mkSignature' "()" - toVariant x = V.Variant (structureSignature x) x - fromVariant (V.Variant _ x) = cast x - -structureSignature :: Structure -> S.Signature -structureSignature (Structure vs) = sig where - sigs = [s | (V.Variant s _) <- vs] - sig = S.mkSignature' $ "(" ++ concatMap S.strSignature sigs ++ ")" -\end{code} diff --git a/DBus/Types/Containers/Variant.lhs b/DBus/Types/Containers/Variant.lhs deleted file mode 100644 --- a/DBus/Types/Containers/Variant.lhs +++ /dev/null @@ -1,186 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.Containers.Variant - ( Variant (..) - , Variable (..) - , variantSignature - , variantType - ) where - -import Data.Typeable (Typeable, cast) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import qualified DBus.Types.Signature as S -import qualified DBus.Types.ObjectPath as O -\end{code} -} - -\subsubsection{Variants} - -Any value which can be converted to a {\tt Variant} can be stored in D-Bus -containers or marshaled. Additionally, external types may implement the -{\tt Variable} interface to provide custom conversion to/from built-in D-Bus -types. - -The {\tt defaultSignature} function will be passed {\tt unknown} to determine -the signature an empty array or dictionary. - -\begin{code} -class Variable a where - defaultSignature :: a -> S.Signature - toVariant :: a -> Variant - fromVariant :: Variant -> Maybe a -\end{code} - -\begin{code} -data Variant = forall a. (Variable a, Typeable a, Show a) => - Variant S.Signature a - deriving (Typeable) - -instance Show Variant where - showsPrec d (Variant sig x) = showParen (d > 10) $ - s "Variant " . s sigStr . s " " . showsPrec 11 x - where sigStr = show . S.strSignature $ sig - s = showString -\end{code} - -Ghetto Eq instance -- the types contained in variants are known to have -fixed {\tt show} representations, so this works well enough. - -It might not work right for {\tt Double}, though. - -\begin{code} -instance Eq Variant where - x == y = show x == show y -\end{code} - -Variants are themselves variables. - -\begin{code} -instance Variable Variant where - defaultSignature _ = S.mkSignature' "v" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -variantSignature :: Variant -> S.Signature -variantSignature (Variant s _) = s -\end{code} - -\begin{code} -variantType :: Variant -> S.Type -variantType = head . S.signatureTypes . variantSignature -\end{code} - -\begin{code} -instance Variable Bool where - defaultSignature _ = S.mkSignature' "b" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Word8 where - defaultSignature _ = S.mkSignature' "y" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Word16 where - defaultSignature _ = S.mkSignature' "q" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Word32 where - defaultSignature _ = S.mkSignature' "u" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Word64 where - defaultSignature _ = S.mkSignature' "t" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Int16 where - defaultSignature _ = S.mkSignature' "n" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Int32 where - defaultSignature _ = S.mkSignature' "i" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Int64 where - defaultSignature _ = S.mkSignature' "x" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable Double where - defaultSignature _ = S.mkSignature' "d" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable String where - defaultSignature _ = S.mkSignature' "s" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable O.ObjectPath where - defaultSignature _ = S.mkSignature' "o" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\begin{code} -instance Variable S.Signature where - defaultSignature _ = S.mkSignature' "g" - toVariant = toVariant' - fromVariant = fromVariant' -\end{code} - -\subsubsection*{Helper functions} - -\begin{code} -toVariant' :: (Variable a, Typeable a, Show a) => a -> Variant -toVariant' x = Variant (defaultSignature x) x - -fromVariant' :: Typeable a => Variant -> Maybe a -fromVariant' (Variant _ x) = cast x -\end{code} diff --git a/DBus/Types/Endianness.lhs b/DBus/Types/Endianness.lhs deleted file mode 100644 --- a/DBus/Types/Endianness.lhs +++ /dev/null @@ -1,51 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Types.Endianness - ( -- * Endianness - Endianness (..) - ) where - -import Data.Word (Word8) -import qualified DBus.Types.Containers as C -import DBus.Types.Signature (mkSignature') -\end{code} -} - -\subsubsection{Endianness} - -\begin{code} -data Endianness = LittleEndian | BigEndian - deriving (Show, Eq) -\end{code} - -Endianness is encoded in the header as a single ASCII character, either -{\tt 'l'} ({\tt 0x6C}) for little-endian or {\tt 'B'} ({\tt 0x42}) for -big-endian. - -\begin{code} -instance C.Variable Endianness where - defaultSignature _ = mkSignature' "y" - toVariant LittleEndian = C.toVariant (0x6C :: Word8) - toVariant BigEndian = C.toVariant (0x42 :: Word8) - fromVariant v = do - b <- C.fromVariant v :: Maybe Word8 - case b of - 0x6C -> Just LittleEndian - 0x42 -> Just BigEndian - _ -> Nothing -\end{code} diff --git a/DBus/Types/Names.lhs b/DBus/Types/Names.lhs deleted file mode 100644 --- a/DBus/Types/Names.lhs +++ /dev/null @@ -1,202 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Types.Names - ( -- * Names - - -- ** Interface names - InterfaceName - , mkInterfaceName - , mkInterfaceName' - , strInterfaceName - - -- ** Bus names - , BusName - , mkBusName - , mkBusName' - , strBusName - - -- ** Member names - , MemberName - , mkMemberName - , mkMemberName' - , strMemberName - - -- ** Error names - , ErrorName - , mkErrorName - , mkErrorName' - , strErrorName - ) where - -import Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import qualified DBus.Types.Atom as A -import qualified DBus.Types.Containers as C -import DBus.Types.Signature (mkSignature') -import DBus.Util (checkLength, parseMaybe, mkUnsafe) -\end{code} -} - -All names have a length limit of 255 characters. - -\subsubsection{Interface names} - -An interface name consists of two or more {\tt '.'}-separated elements. Each -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. - -\begin{code} -newtype InterfaceName = InterfaceName String - deriving (Show, Eq, Ord) -\end{code} - -\begin{code} -instance C.Variable InterfaceName where - defaultSignature _ = mkSignature' "s" - toVariant = A.atomToVariant . A.toAtom - fromVariant = (mkInterfaceName =<<) . C.fromVariant -instance A.Atomic InterfaceName where - toAtom = A.toAtom . strInterfaceName -\end{code} - -\begin{code} -mkInterfaceName :: String -> Maybe InterfaceName -mkInterfaceName s = checkLength 255 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) -\end{code} - -\begin{code} -mkInterfaceName' :: String -> InterfaceName -mkInterfaceName' = mkUnsafe "interface name" mkInterfaceName -\end{code} - -\begin{code} -strInterfaceName :: InterfaceName -> String -strInterfaceName (InterfaceName x) = x -\end{code} - -\subsubsection{Error names} - -Error names have the same rules as interface names, so just re-use that -validation logic. - -\begin{code} -newtype ErrorName = ErrorName String - deriving (Show, Eq, Ord) -\end{code} - -\begin{code} -instance C.Variable ErrorName where - defaultSignature _ = mkSignature' "s" - toVariant = A.atomToVariant . A.toAtom - fromVariant = (mkErrorName =<<) . C.fromVariant -instance A.Atomic ErrorName where - toAtom = A.toAtom . strErrorName -\end{code} - -\begin{code} -mkErrorName :: String -> Maybe ErrorName -mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName -\end{code} - -\begin{code} -mkErrorName' :: String -> ErrorName -mkErrorName' = mkUnsafe "error name" mkErrorName -\end{code} - -\begin{code} -strErrorName :: ErrorName -> String -strErrorName (ErrorName x) = x -\end{code} - -\subsubsection{Bus names} - -\begin{code} -newtype BusName = BusName String - deriving (Show, Eq, Ord) -\end{code} - -\begin{code} -instance C.Variable BusName where - defaultSignature _ = mkSignature' "s" - toVariant = A.atomToVariant . A.toAtom - fromVariant = (mkBusName =<<) . C.fromVariant -instance A.Atomic BusName where - toAtom = A.toAtom . strBusName -\end{code} - -\begin{code} -mkBusName :: String -> Maybe BusName -mkBusName s = checkLength 255 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') -\end{code} - -\begin{code} -mkBusName' :: String -> BusName -mkBusName' = mkUnsafe "bus name" mkBusName -\end{code} - -\begin{code} -strBusName :: BusName -> String -strBusName (BusName x) = x -\end{code} - -\subsubsection{Member names} - -\begin{code} -newtype MemberName = MemberName String - deriving (Show, Eq, Ord) -\end{code} - -\begin{code} -instance C.Variable MemberName where - defaultSignature _ = mkSignature' "s" - toVariant = A.atomToVariant . A.toAtom - fromVariant = (mkMemberName =<<) . C.fromVariant -instance A.Atomic MemberName where - toAtom = A.toAtom . strMemberName -\end{code} - -\begin{code} -mkMemberName :: String -> Maybe MemberName -mkMemberName s = checkLength 255 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) -\end{code} - -\begin{code} -mkMemberName' :: String -> MemberName -mkMemberName' = mkUnsafe "member name" mkMemberName -\end{code} - -\begin{code} -strMemberName :: MemberName -> String -strMemberName (MemberName x) = x -\end{code} diff --git a/DBus/Types/ObjectPath.lhs b/DBus/Types/ObjectPath.lhs deleted file mode 100644 --- a/DBus/Types/ObjectPath.lhs +++ /dev/null @@ -1,62 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.ObjectPath - ( -- * Object paths - ObjectPath - , mkObjectPath - , mkObjectPath' - , strObjectPath - ) where - -import Data.Typeable (Typeable) -import qualified Text.Parsec as P -import DBus.Util (parseMaybe, mkUnsafe) -\end{code} -} - -\subsubsection{Object paths} - -An object path may be one of - -\begin{itemize} -\item The root path, {\tt "/"}. -\item {\tt '/'}, followed by one or more element names. Each element name - contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at - least one character. -\end{itemize} - -Element names are separated by {\tt '/'}, and the path may not end in -{\tt '/'} unless it is the root path. - -\begin{code} -newtype ObjectPath = ObjectPath String - deriving (Show, Eq, Ord, Typeable) - -mkObjectPath :: String -> Maybe ObjectPath -mkObjectPath s = parseMaybe path' 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' :: String -> ObjectPath -mkObjectPath' = mkUnsafe "object path" mkObjectPath - -strObjectPath :: ObjectPath -> String -strObjectPath (ObjectPath x) = x -\end{code} diff --git a/DBus/Types/Serial.lhs b/DBus/Types/Serial.lhs deleted file mode 100644 --- a/DBus/Types/Serial.lhs +++ /dev/null @@ -1,58 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -module DBus.Types.Serial - ( -- * Message serials - Serial (..) - , nextSerial - , firstSerial - ) where - -import Data.Word (Word32) -import qualified DBus.Types.Atom as A -import qualified DBus.Types.Containers as C -import DBus.Types.Signature (mkSignature') -\end{code} -} - -\subsubsection{Message Serials} - -\begin{code} -newtype Serial = Serial Word32 - deriving (Eq, Ord) - -instance Show Serial where - show (Serial x) = show x - -instance A.Atomic Serial where - toAtom (Serial x) = A.toAtom x - -instance C.Variable Serial where - defaultSignature _ = mkSignature' "u" - toVariant (Serial x) = C.toVariant x - fromVariant = fmap Serial . C.fromVariant -\end{code} - -\begin{code} -nextSerial :: Serial -> Serial -nextSerial (Serial x) = Serial (x + 1) -\end{code} - -\begin{code} -firstSerial :: Serial -firstSerial = Serial 1 -\end{code} diff --git a/DBus/Types/Signature.lhs b/DBus/Types/Signature.lhs deleted file mode 100644 --- a/DBus/Types/Signature.lhs +++ /dev/null @@ -1,157 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Types.Signature - ( -- * Signatures - Signature - , Type(..) - , signatureTypes - , mkSignature - , mkSignature' - , strSignature - , typeString - ) where - -import Data.Typeable (Typeable) -import Text.Parsec (char, (<|>), many, eof) -import DBus.Util (checkLength, parseMaybe, mkUnsafe) -\end{code} -} - -\subsubsection{Signatures} - -Valid DBus type signatures must obey certain rules, such as "dict entries -may only appear in arrays". A signature is guaranteed to be valid according -to these rules. Creating them requires using the {\tt parseSignature} -function, which will convert a valid DBus signature string into a -{\tt Signature}. - -\begin{code} -data Signature = Signature { signatureTypes :: [Type] } - deriving (Eq, Typeable) -\end{code} - -Use a custom {\tt Show} instance to avoid displaying signature types directly. - -\begin{code} -instance Show Signature where - showsPrec d s = showParen (d > 10) $ - showString' ["Signature \"", strSignature s, "\""] where - showString' = foldr (.) id . map showString -\end{code} - -Parse a signature string such as {\tt "yya{is}"} to a signature. If the -string is invalid, {\tt Nothing} will be returned instead. - -\begin{code} -mkSignature :: String -> Maybe Signature -mkSignature = (parseMaybe sigParser =<<) . checkLength 255 where - sigParser = do - types <- many parseType - eof - return $ Signature types - parseType = parseAtom <|> parseContainer - parseContainer = - parseArray - <|> parseStruct - <|> (char 'v' >> return VariantT) - parseAtom = - (char 'b' >> return BooleanT) - <|> (char 'y' >> return ByteT) - <|> (char 'n' >> return Int16T) - <|> (char 'q' >> return UInt16T) - <|> (char 'i' >> return Int32T) - <|> (char 'u' >> return UInt32T) - <|> (char 'x' >> return Int64T) - <|> (char 't' >> return UInt64T) - <|> (char 'd' >> return DoubleT) - <|> (char 's' >> return StringT) - <|> (char 'o' >> return ObjectPathT) - <|> (char 'g' >> return SignatureT) - parseArray = do - char 'a' - parseDict <|> do - t <- parseType - return $ ArrayT t - parseDict = do - char '{' - keyType <- parseAtom - valueType <- parseType - char '}' - return $ DictionaryT keyType valueType - parseStruct = do - char '(' - types <- many parseType - char ')' - return $ StructureT types -\end{code} - -\begin{code} -mkSignature' :: String -> Signature -mkSignature' = mkUnsafe "signature" mkSignature -\end{code} - -Convert a signature to a string, for marshaling over the bus or display. - -\begin{code} -strSignature :: Signature -> String -strSignature (Signature ts) = concatMap typeString ts -\end{code} - -Data types which may be contained in a signature. No checks are performed to -ensure correct nesting when using these, so all generation of signatures -must go through {\tt parseSignature}. - -\begin{code} -data Type - = BooleanT - | ByteT - | Int16T - | UInt16T - | Int32T - | UInt32T - | Int64T - | UInt64T - | DoubleT - | StringT - | ObjectPathT - | SignatureT - | ArrayT Type - | DictionaryT Type Type - | StructureT [Type] - | VariantT - deriving (Show, Eq) - -typeString :: Type -> String -typeString BooleanT = "b" -typeString ByteT = "y" -typeString Int16T = "n" -typeString UInt16T = "q" -typeString Int32T = "i" -typeString UInt32T = "u" -typeString Int64T = "x" -typeString UInt64T = "t" -typeString DoubleT = "d" -typeString StringT = "s" -typeString ObjectPathT = "o" -typeString SignatureT = "g" -typeString (ArrayT t) = 'a' : typeString t -typeString (DictionaryT kt vt) = "a{" ++ typeString kt ++ typeString vt ++ "}" -typeString (StructureT ts) = "(" ++ concatMap typeString ts ++ ")" -typeString VariantT = "v" -\end{code} diff --git a/DBus/Unmarshal.lhs b/DBus/Unmarshal.lhs deleted file mode 100644 --- a/DBus/Unmarshal.lhs +++ /dev/null @@ -1,312 +0,0 @@ -% Copyright (C) 2009 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 . - -\ignore{ -\begin{code} -{-# LANGUAGE ExistentialQuantification #-} -module DBus.Unmarshal (unmarshal) where - -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import qualified Control.Monad.State as S -import qualified Control.Monad.Error as E -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.UTF8 (toString) -import qualified Data.Binary.Get as G -import qualified Data.Binary.IEEE754 as IEEE - -import DBus.Padding (padding, alignment) -import qualified DBus.Types as T -\end{code} -} - -\clearpage -\section{Unmarshaling} -\subsection{\tt unmarshal} - -\begin{code} -unmarshal :: (E.Error e, E.MonadError e m) - => T.Endianness -> T.Signature -> L.ByteString - -> m [T.Variant] -unmarshal e sig bytes = either' where - either' = case runUnmarshal x e bytes of - Left y -> E.throwError . E.strMsg . show $ y - Right y -> return y - x = mapM unmarshal' $ T.signatureTypes sig -\end{code} - -\begin{code} -unmarshal' :: T.Type -> Unmarshal T.Variant -unmarshal' T.BooleanT = fmap T.toVariant bool -unmarshal' T.ByteT = fmap T.toVariant word8 -unmarshal' T.UInt16T = fmap T.toVariant word16 -unmarshal' T.UInt32T = fmap T.toVariant word32 -unmarshal' T.UInt64T = fmap T.toVariant word64 -unmarshal' T.Int16T = fmap T.toVariant int16 -unmarshal' T.Int32T = fmap T.toVariant int32 -unmarshal' T.Int64T = fmap T.toVariant int64 -unmarshal' T.DoubleT = fmap T.toVariant double -unmarshal' T.StringT = fmap T.toVariant string -unmarshal' T.ObjectPathT = fmap T.toVariant objectPath -unmarshal' T.SignatureT = fmap T.toVariant signature -unmarshal' (T.ArrayT t) = fmap T.toVariant $ array t -unmarshal' (T.DictionaryT kt vt) = fmap T.toVariant $ dictionary kt vt -unmarshal' (T.StructureT ts) = fmap T.toVariant $ structure ts -unmarshal' T.VariantT = fmap T.toVariant variant -\end{code} - -\subsection{Atoms} - -\begin{code} -bool :: Unmarshal Bool -bool = word32 >>= \x -> case x of - 0 -> return False - 1 -> return True - _ -> E.throwError $ Invalid "boolean" x -\end{code} - -\begin{code} -word8 :: Unmarshal Word8 -word8 = do - bs <- consume 1 - let [b] = L.unpack bs - return b -\end{code} - -\begin{code} -word16 :: Unmarshal Word16 -word16 = eitherEndian 2 G.getWord16be G.getWord16le -\end{code} - -\begin{code} -word32 :: Unmarshal Word32 -word32 = eitherEndian 4 G.getWord32be G.getWord32le -\end{code} - -\begin{code} -word64 :: Unmarshal Word64 -word64 = eitherEndian 8 G.getWord64be G.getWord64le -\end{code} - -\begin{code} -int16 :: Unmarshal Int16 -int16 = fmap fromIntegral $ eitherEndian 2 G.getWord16be G.getWord16le -\end{code} - -\begin{code} -int32 :: Unmarshal Int32 -int32 = fmap fromIntegral $ eitherEndian 4 G.getWord32be G.getWord32le -\end{code} - -\begin{code} -int64 :: Unmarshal Int64 -int64 = fmap fromIntegral $ eitherEndian 8 G.getWord64be G.getWord64le -\end{code} - -\begin{code} -double :: Unmarshal Double -double = eitherEndian 8 IEEE.getFloat64be IEEE.getFloat64le -\end{code} - -\begin{code} -string :: Unmarshal String -string = do - byteCount <- word32 - bytes <- consume . fromIntegral $ byteCount - skipNulls 1 - return . toString $ bytes -\end{code} - -\begin{code} -objectPath :: Unmarshal T.ObjectPath -objectPath = do - s <- string - fromMaybe T.mkObjectPath s "object path" -\end{code} - -\begin{code} -signature :: Unmarshal T.Signature -signature = do - byteCount <- word8 - bytes <- consume . fromIntegral $ byteCount - skipNulls 1 - fromMaybe T.mkSignature (toString bytes) "signature" -\end{code} - -\subsection{Containers} - -\subsubsection{Arrays} - -\begin{code} -array :: T.Type -> Unmarshal T.Array -array t = do - let getOffset = do - (UnmarshalState _ _ o) <- get - return o - let sig = T.mkSignature' . T.typeString $ t - - byteCount <- word32 - skipPadding (alignment t) - start <- getOffset - let end = start + fromIntegral byteCount - vs <- untilM (fmap (>= end) getOffset) (unmarshal' t) - end' <- getOffset - assert (end == end') "Array contained fewer bytes than expected." - fromMaybe (T.arrayFromItems sig) vs "array" -\end{code} - -\subsubsection{Dictionaries} - -\begin{code} -dictionary :: T.Type -> T.Type -> Unmarshal T.Dictionary -dictionary kt vt = do - arr <- array $ T.StructureT [kt, vt] - structs <- fromMaybe T.fromArray arr "dictionary" - pairs <- mapM mkPair structs - let kSig = T.mkSignature' . T.typeString $ kt - let vSig = T.mkSignature' . T.typeString $ vt - fromMaybe (T.dictionaryFromItems kSig vSig) pairs "dictionary" - -mkPair :: T.Structure -> Unmarshal (T.Atom, T.Variant) -mkPair (T.Structure [k, v]) = do - k' <- fromMaybe T.atomFromVariant k "dictionary key" - return (k', v) -mkPair s = E.throwError $ Invalid "dictionary item" s -\end{code} - -\subsubsection{Structures} - -\begin{code} -structure :: [T.Type] -> Unmarshal T.Structure -structure ts = do - skipPadding 8 - fmap T.Structure $ mapM unmarshal' ts -\end{code} - -\subsubsection{Variants} - -\begin{code} -variant :: Unmarshal T.Variant -variant = do - sig <- signature - t <- case T.signatureTypes sig of - [t'] -> return t' - _ -> E.throwError $ Invalid "variant signature" - $ T.strSignature sig - unmarshal' t -\end{code} - -\subsection{The {\tt Unmarshal} monad} - -\begin{code} -data UnmarshalState = UnmarshalState T.Endianness L.ByteString Word64 -type Unmarshal = E.ErrorT UnmarshalError (S.State UnmarshalState) -\end{code} - -\begin{code} -runUnmarshal :: Unmarshal a -> T.Endianness -> L.ByteString - -> Either UnmarshalError a -runUnmarshal x e bytes = S.evalState (E.runErrorT x) state where - state = UnmarshalState e bytes 0 -\end{code} - -\begin{code} -get :: Unmarshal UnmarshalState -get = E.lift S.get - -put :: UnmarshalState -> Unmarshal () -put = E.lift . S.put -\end{code} - -\begin{code} -consume :: Word64 -> Unmarshal L.ByteString -consume count = do - (UnmarshalState e bytes offset) <- get - let bytes' = L.drop (fromIntegral offset) bytes - let x = L.take (fromIntegral count) bytes' - if L.length x == fromIntegral count - then do - let offset' = offset + count - put $ UnmarshalState e bytes offset' - return x - else E.throwError $ UnexpectedEOF offset -\end{code} - -\begin{code} -skipPadding :: Word8 -> Unmarshal () -skipPadding count = do - (UnmarshalState _ _ offset) <- get - bytes <- consume $ padding offset count - assert (L.all (== 0) bytes) "Non-zero bytes in padding." -\end{code} - -\begin{code} -skipNulls :: Word8 -> Unmarshal () -skipNulls count = do - bytes <- consume $ fromIntegral count - assert (L.all (== 0) bytes) "Non-zero bytes in padding." -\end{code} - -\begin{code} -eitherEndian :: Word8 -> G.Get a -> G.Get a -> Unmarshal a -eitherEndian count be le = do - skipPadding count - (UnmarshalState e _ _) <- get - bs <- consume . fromIntegral $ count - let get' = case e of - T.BigEndian -> be - T.LittleEndian -> le - return $ G.runGet get' bs -\end{code} - -\begin{code} -untilM :: Monad m => m Bool -> m a -> m [a] -untilM test comp = do - done <- test - if done - then return [] - else do - x <- comp - xs <- untilM test comp - return $ x:xs -\end{code} - -\subsection{Errors} - -\begin{code} -data UnmarshalError - = UnexpectedEOF Word64 - | forall a. (Show a) => Invalid String a - | GenericError String - -instance E.Error UnmarshalError where - strMsg = GenericError - -instance Show UnmarshalError where - show (UnexpectedEOF pos) = "Unexpected EOF at position " ++ show pos - show (Invalid label x) = "Invalid " ++ label ++ ": " ++ show x - show (GenericError msg) = "Error unmarshaling: " ++ msg -\end{code} - -\begin{code} -assert :: Bool -> String -> Unmarshal () -assert True _ = return () -assert False msg = E.throwError $ E.strMsg msg -\end{code} - -\begin{code} -fromMaybe :: Show a => (a -> Maybe b) -> a -> String -> Unmarshal b -fromMaybe f x s = maybe (E.throwError $ Invalid s x) return $ f x -\end{code} diff --git a/DBus/Util.lhs b/DBus/Util.lhs deleted file mode 100644 --- a/DBus/Util.lhs +++ /dev/null @@ -1,61 +0,0 @@ -% Copyright (C) 2009 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 . - -\clearpage -\section{Misc. utility functions} - -\ignore{ -\begin{code} -module DBus.Util - ( checkLength - , parseMaybe - , mkUnsafe - , hexToInt - , eitherToMaybe - ) where - -import Text.Parsec (Parsec, parse) -import Data.Char (digitToInt) -\end{code} -} - -\begin{code} -checkLength :: Int -> String -> Maybe String -checkLength length' s | length s <= length' = Just s -checkLength _ _ = Nothing -\end{code} - -\begin{code} -parseMaybe :: Parsec String () a -> String -> Maybe a -parseMaybe p = either (const Nothing) Just . parse p "" -\end{code} - -\begin{code} -mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b -mkUnsafe label f x = case f x of - Just x' -> x' - Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x -\end{code} - -\begin{code} -hexToInt :: String -> Int -hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt -\end{code} - -\begin{code} -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe (Left _) = Nothing -eitherToMaybe (Right x) = Just x -\end{code} diff --git a/Examples/dbus-monitor.hs b/Examples/dbus-monitor.hs --- a/Examples/dbus-monitor.hs +++ b/Examples/dbus-monitor.hs @@ -15,6 +15,8 @@ along with this program. If not, see . -} +{-# LANGUAGE OverloadedStrings #-} + import DBus.Address import DBus.Bus import DBus.Connection @@ -28,6 +30,8 @@ import Data.Maybe import Data.Int import Data.Word +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL import System import System.IO import System.Console.GetOpt @@ -56,7 +60,7 @@ findBus (o:_) = case o of BusOption Session -> getSessionBus BusOption System -> getSystemBus - AddressOption addr -> case parseAddresses addr of + AddressOption addr -> case mkAddresses (TL.pack addr) of Just [x] -> getBus x Just x -> getFirstBus x _ -> error $ "Invalid address: " ++ show addr @@ -82,7 +86,7 @@ ] onMessage :: ReceivedMessage -> IO () -onMessage msg = putStrLn (formatMessage msg ++ "\n") +onMessage msg = putStrLn $ (TL.unpack $ formatMessage msg) ++ "\n" main :: IO () main = do @@ -107,17 +111,17 @@ -- Message formatting is verbose and mostly uninteresting, except as an -- excersise in string manipulation. -formatMessage :: ReceivedMessage -> String +formatMessage :: ReceivedMessage -> Text -- Method call -formatMessage (ReceivedMethodCall serial sender msg) = concat +formatMessage (ReceivedMethodCall serial sender msg) = TL.concat [ "method call" , " sender=" , fromMaybe "(null)" . fmap strBusName $ sender , " -> dest=" , fromMaybe "(null)" . fmap strBusName . methodCallDestination $ msg , " serial=" - , show serial + , TL.pack . show $ serial , " path=" , strObjectPath . methodCallPath $ msg , "; interface=" @@ -128,19 +132,19 @@ ] -- Method return -formatMessage (ReceivedMethodReturn _ sender msg) = concat +formatMessage (ReceivedMethodReturn _ sender msg) = TL.concat [ "method return" , " sender=" , fromMaybe "(null)" . fmap strBusName $ sender , " -> dest=" , fromMaybe "(null)" . fmap strBusName . methodReturnDestination $ msg , " reply_serial=" - , show . methodReturnSerial $ msg + , TL.pack . show . methodReturnSerial $ msg , formatBody msg ] -- Error -formatMessage (ReceivedError _ sender msg) = concat +formatMessage (ReceivedError _ sender msg) = TL.concat [ "error" , " sender=" , fromMaybe "(null)" . fmap strBusName $ sender @@ -149,17 +153,19 @@ , " error_name=" , strErrorName . errorName $ msg , " reply_serial=" - , show . errorSerial $ msg + , TL.pack . show . errorSerial $ msg , formatBody msg ] -- Signal -formatMessage (ReceivedSignal serial sender msg) = concat +formatMessage (ReceivedSignal serial sender msg) = TL.concat [ "signal" , " sender=" , fromMaybe "(null)" . fmap strBusName $ sender + , " -> dest=" + , fromMaybe "(null)" . fmap strBusName . signalDestination $ msg , " serial=" - , show serial + , TL.pack . show $ serial , " path=" , strObjectPath . signalPath $ msg , "; interface=" @@ -169,74 +175,76 @@ , formatBody msg ] -formatMessage (ReceivedUnknown serial sender) = concat +formatMessage (ReceivedUnknown serial sender _) = TL.concat [ "unknown" , " sender=" , fromMaybe "(null)" . fmap strBusName $ sender , " serial=" - , show serial + , TL.pack . show $ serial ] -formatBody :: Message a => a -> String +formatBody :: Message a => a -> Text formatBody msg = formatted where tree = Children $ map formatVariant body body = messageBody msg - formatted = intercalate "\n" ([] : collapseTree 1 tree) + formatted = TL.intercalate "\n" (TL.empty : collapseTree 1 tree) -- A string tree allows easy indentation of nested structures -data StringTree = Line String | MultiLine [StringTree] | Children [StringTree] +data StringTree = Line Text | MultiLine [StringTree] | Children [StringTree] deriving (Show) -collapseTree :: Int -> StringTree -> [String] -collapseTree d (Line x) = [concat (replicate d " ") ++ x] +collapseTree :: Int64 -> StringTree -> [Text] +collapseTree d (Line x) = [TL.append (TL.replicate d " ") x] collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs collapseTree d (Children xs) = concatMap (collapseTree (d + 1)) xs -- Formatting for various kinds of variants, keyed to their signature type. formatVariant :: Variant -> StringTree -formatVariant v = formatVariant' type' v where - [type'] = signatureTypes . variantSignature $ v +formatVariant v = formatVariant' (variantType v) v where +showT :: Show a => a -> Text +showT = TL.pack . show + formatVariant' :: Type -> Variant -> StringTree -formatVariant' BooleanT x = Line $ "boolean " ++ strX where +formatVariant' DBusBoolean x = Line $ TL.append "boolean " strX where x' = fromJust . fromVariant $ x :: Bool strX = if x' then "true" else "false" -formatVariant' ByteT x = Line $ "byte " ++ show x' where +formatVariant' DBusByte x = Line $ TL.append "byte " $ showT x' where x' = fromJust . fromVariant $ x :: Word8 -formatVariant' Int16T x = Line $ "int16 " ++ show x' where +formatVariant' DBusInt16 x = Line $ TL.append "int16 " $ showT x' where x' = fromJust . fromVariant $ x :: Int16 -formatVariant' Int32T x = Line $ "int32 " ++ show x' where +formatVariant' DBusInt32 x = Line $ TL.append "int32 " $ showT x' where x' = fromJust . fromVariant $ x :: Int32 -formatVariant' Int64T x = Line $ "int64 " ++ show x' where +formatVariant' DBusInt64 x = Line $ TL.append "int64 " $ showT x' where x' = fromJust . fromVariant $ x :: Int64 -formatVariant' UInt16T x = Line $ "uint16 " ++ show x' where +formatVariant' DBusWord16 x = Line $ TL.append "uint16 " $ showT x' where x' = fromJust . fromVariant $ x :: Word16 -formatVariant' UInt32T x = Line $ "uint32 " ++ show x' where +formatVariant' DBusWord32 x = Line $ TL.append "uint32 " $ showT x' where x' = fromJust . fromVariant $ x :: Word32 -formatVariant' UInt64T x = Line $ "uint64 " ++ show x' where +formatVariant' DBusWord64 x = Line $ TL.append "uint64 " $ showT x' where x' = fromJust . fromVariant $ x :: Word64 -formatVariant' DoubleT x = Line $ "double " ++ show x' where +formatVariant' DBusDouble x = Line $ TL.append "double " $ showT x' where x' = fromJust . fromVariant $ x :: Double -formatVariant' StringT x = Line $ "string " ++ show x' where +formatVariant' DBusString x = Line $ TL.append "string " $ showT x' where x' = fromJust . fromVariant $ x :: String -formatVariant' ObjectPathT x = Line $ "object path " ++ show x' where +formatVariant' DBusObjectPath x = Line $ TL.append "object path " $ showT x' where x' = strObjectPath . fromJust . fromVariant $ x -formatVariant' SignatureT x = Line $ "signature " ++ show x' where +formatVariant' DBusSignature x = Line $ TL.append "signature " $ showT x' where x' = strSignature . fromJust . fromVariant $ x -formatVariant' (ArrayT _) x = MultiLine lines' where +formatVariant' (DBusArray _) x = MultiLine lines' where items = arrayItems . fromJust . fromVariant $ x lines' = [ Line "array [" @@ -244,19 +252,20 @@ , Line "]" ] -formatVariant' (DictionaryT _ _) x = MultiLine lines' where +formatVariant' (DBusDictionary _ _) x = MultiLine lines' where items = dictionaryItems . fromJust . fromVariant $ x lines' = [ Line "dictionary {" , Children . map formatItem $ items , Line "}" ] - formatItem (k, v) = MultiLine $ [Line $ k' ++ " -> " ++ vHead] ++ vTail where - Line k' = formatVariant (atomToVariant k) + formatItem (k, v) = MultiLine $ firstLine : vTail where + Line k' = formatVariant k v' = collapseTree 0 (formatVariant v) vHead = head v' vTail = map Line $ tail v' + firstLine = Line $ TL.concat [k', " -> ", vHead] -formatVariant' (StructureT _) x = MultiLine lines' where +formatVariant' (DBusStructure _) x = MultiLine lines' where Structure items = fromJust . fromVariant $ x lines' = [ Line "struct (" @@ -264,4 +273,4 @@ , Line ")" ] -formatVariant' VariantT x = formatVariant . fromJust . fromVariant $ x +formatVariant' DBusVariant x = formatVariant . fromJust . fromVariant $ x diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,38 @@ +HS_SOURCES=\ + hs/DBus/Address.hs \ + hs/DBus/Bus.hs \ + hs/DBus/Connection.hs \ + hs/DBus/Constants.hs \ + hs/DBus/Introspection.hs \ + hs/DBus/Message.hs \ + hs/DBus/Message/Internal.hs \ + hs/DBus/Types.hs \ + hs/DBus/Util.hs \ + hs/DBus/Wire.hs \ + hs/Tests.hs + +all: $(HS_SOURCES) + +%.tex: %.nw + noweave -delay "$<" | cpif "$@" + +hs/%.hs: dbus-core.nw hs/DBus/Message + notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@" + +hs/Tests.hs: Tests.nw hs + notangle -R"Tests.hs" "$<" dbus-core.nw | cpphs --hashes --noline | cpif "$@" + +hs: + mkdir -p hs + +hs/DBus: + mkdir -p hs/DBus + +hs/DBus/Message: + mkdir -p hs/DBus/Message + +%.pdf: %.tex + xelatex "$<" + xelatex "$<" + +pdfs: dbus-core.pdf manual.pdf diff --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -1,40 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -import Test.QuickCheck.Batch -import Tests.Address (addressProperties) -import Tests.Signature (signatureProperties) -import Tests.Containers (containerProperties) -import Tests.Marshal (marshalProperties) -import Tests.Messages (messageProperties) -import Tests.MiscTypes (miscTypeProperties) - -options = TestOptions - { no_of_tests = 100 - , length_of_tests = 1 - , debug_tests = False - } - -main = do - runTests "simple" options . map run . concat $ - [ addressProperties - , containerProperties - , marshalProperties - , messageProperties - , miscTypeProperties - , signatureProperties - ] diff --git a/Tests.nw b/Tests.nw new file mode 100644 --- /dev/null +++ b/Tests.nw @@ -0,0 +1,682 @@ +% Copyright (C) 2009 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 #-} +module Main (tests) where + +import Test.QuickCheck +import Test.Framework (Test, testGroup) +import qualified Test.Framework as F +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Arrow ((&&&)) +import Control.Monad (replicateM) +import qualified Data.Binary.Get as G +import Data.Char (isPrint) +import Data.List (intercalate, isInfixOf) +import Data.Maybe (fromJust, isJust, isNothing) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import DBus.Address +import DBus.Message.Internal +import DBus.Types +import DBus.Wire +import qualified DBus.Introspection as I + +@ \section{Tests} + +<>= +tests :: [Test] +tests = [<> + ] + +main :: IO () +main = F.defaultMain tests + +@ \subsection{Types} + +<>= + testGroup "Types" + [ testGroup "Atomic types" + [<> + ] + , testGroup "Container types" + [<> + ] + ] + +<>= + +<>= + +@ \subsubsection{Atoms} + +<>= + testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool) +, testGroup "Word8" $ commonVariantTests (arbitrary :: Gen Word8) +, testGroup "Word16" $ commonVariantTests (arbitrary :: Gen Word16) +, testGroup "Word32" $ commonVariantTests (arbitrary :: Gen Word32) +, testGroup "Word64" $ commonVariantTests (arbitrary :: Gen Word64) +, testGroup "Int16" $ commonVariantTests (arbitrary :: Gen Int16) +, testGroup "Int32" $ commonVariantTests (arbitrary :: Gen Int32) +, testGroup "Int64" $ commonVariantTests (arbitrary :: Gen Int64) +, testGroup "Double" $ commonVariantTests (arbitrary :: Gen Double) +, testGroup "String" $ commonVariantTests (arbitrary :: Gen String) ++ + [ testProperty "String -> strict Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.pack x) + , testProperty "String <- strict Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x) + , testProperty "String -> lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x) + , testProperty "String <- lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x) + , testProperty "Strict Text -> lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x) + , testProperty "Strict Text <- lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x) + ] + +<>= +atomicType :: Gen Type +atomicType = elements + [ DBusBoolean + , DBusByte + , DBusWord16 + , DBusWord32 + , DBusWord64 + , DBusInt16 + , DBusInt32 + , DBusInt64 + , DBusDouble + , DBusString + , DBusObjectPath + , DBusSignature + ] + +containerType :: Gen Type +containerType = do + c <- choose (0,3) :: Gen Int + case c of + 0 -> fmap DBusArray arbitrary + 1 -> do + kt <- atomicType + vt <- arbitrary + return $ DBusDictionary kt vt + 2 -> fmap DBusStructure $ shrinkingGen arbitrary + 3 -> return DBusVariant + +instance Arbitrary Type where + arbitrary = oneof [atomicType, containerType] + +instance Arbitrary Signature where + arbitrary = clampedSize 255 genSig mkSignature' where + genSig = fmap (TL.concat . map typeCode) arbitrary + +<>= +, testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++ + [ testProperty "Signature identity" + $ \x -> (mkSignature . strSignature) x == Just x + , testProperty "Signature show" + $ \x -> show (strSignature x) `isInfixOf` show x + ] + +<>= +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 = sized' 1 (sized' 1 (elements c)) + +<>= +, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++ + [ testProperty "ObjectPath identity" + $ \x -> (mkObjectPath . strObjectPath) x == Just x + ] + +<>= +instance Arbitrary BusName where + arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + + unique = do + elems' <- sized' 2 $ elems c' + return . TL.pack $ ':' : intercalate "." elems' + + wellKnown = do + elems' <- sized' 2 $ elems c + return . TL.pack $ intercalate "." elems' + + elems start = do + x <- elements start + xs <- sized' 0 (elements c') + return (x:xs) + +<>= +, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++ + [ testProperty "BusName identity" + $ \x -> (mkBusName . strBusName) x == Just x + ] + +<>= +instance Arbitrary InterfaceName where + arbitrary = clampedSize 255 genName mkInterfaceName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = fmap (TL.pack . intercalate ".") genElements + genElements = sized' 2 genElement + genElement = do + x <- elements c + xs <- sized' 0 (elements c') + return (x:xs) + +<>= +, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++ + [ testProperty "InterfaceName identity" + $ \x -> (mkInterfaceName . strInterfaceName) x == Just x + ] + +<>= +instance Arbitrary ErrorName where + arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary + +<>= +, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++ + [ testProperty "ErrorName identity" + $ \x -> (mkErrorName . strErrorName) x == Just x + ] + +<>= +instance Arbitrary MemberName where + arbitrary = clampedSize 255 genName mkMemberName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = do + x <- elements c + xs <- sized' 0 (elements c') + return . TL.pack $ (x:xs) + +<>= +, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++ + [ testProperty "MemberName identity" + $ \x -> (mkMemberName . strMemberName) x == Just x + ] + +@ \subsubsection{Containers} + +@ All variable types must obey these properties. + +<>= +prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen + $ \x -> (fromVariant . toVariant) x == Just x + +prop_VariantEquality gen = testProperty "Variant equality" . forAll gen + $ \x y -> (x == y) == (toVariant x == toVariant y) + +@ Since all atomic types are also variable, the Variant properties are +added to the set of common Atom tests. + +<>= +, prop_VariantIdentity gen +, prop_VariantEquality gen + +<>= +commonVariantTests gen = + [ prop_VariantIdentity gen + , prop_VariantEquality gen + ] + +<>= +genVariant :: Type -> Gen Variant +genVariant DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) +genVariant DBusByte = fmap toVariant (arbitrary :: Gen Word8) +genVariant DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) +genVariant DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) +genVariant DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) +genVariant DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) +genVariant DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) +genVariant DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) +genVariant DBusDouble = fmap toVariant (arbitrary :: Gen Double) +genVariant DBusString = fmap toVariant (arbitrary :: Gen String) +genVariant DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) +genVariant DBusSignature = fmap toVariant (arbitrary :: Gen Signature) +genVariant (DBusArray _) = fmap toVariant (arbitrary :: Gen Array) +genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary) +genVariant (DBusStructure _) = fmap toVariant (arbitrary :: Gen Structure) +genVariant DBusVariant = fmap toVariant (arbitrary :: Gen Variant) + +instance Arbitrary Variant where + arbitrary = arbitrary >>= genVariant + +<>= +genAtom :: Type -> Gen Variant +genAtom DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) +genAtom DBusByte = fmap toVariant (arbitrary :: Gen Word8) +genAtom DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) +genAtom DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) +genAtom DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) +genAtom DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) +genAtom DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) +genAtom DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) +genAtom DBusDouble = fmap toVariant (arbitrary :: Gen Double) +genAtom DBusString = fmap toVariant (arbitrary :: Gen String) +genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) +genAtom DBusSignature = fmap toVariant (arbitrary :: Gen Signature) + +<>= + testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant) + +<>= +instance Arbitrary Array where + arbitrary = do + -- Only generate arrays of atomic values, as generating + -- containers randomly almost never results in a valid + -- array. + t <- atomicType + xs <- listOf $ genVariant t + return . fromJust $ arrayFromItems t xs + +prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where + array = arrayFromItems firstType vs + homogeneousTypes = all (== firstType) types + types = map variantType vs + firstType = if null types + then DBusByte + else head types + +<>= +, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++ + [ testProperty "Array identity" + $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) + , testProperty "Array homogeneity" prop_ArrayHomogeneous + ] + +<>= +instance Arbitrary Dictionary where + arbitrary = do + -- Only generate dictionaries of atomic values, as generating + -- containers randomly almost never results in a valid + -- dictionary. + kt <- atomicType + vt <- atomicType + ks <- listOf $ genAtom kt + vs <- vectorOf (length ks) $ genVariant vt + + return . fromJust $ dictionaryFromItems kt vt $ zip ks vs + +prop_DictionaryHomogeneous x = all correctType pairs where + pairs = dictionaryItems x + kType = dictionaryKeyType x + vType = dictionaryValueType x + correctType (k, v) = variantType k == kType && + variantType v == vType + +<>= +, testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++ + [ testProperty "Dictionary identity" + $ \x -> Just x == dictionaryFromItems + (dictionaryKeyType x) + (dictionaryValueType x) + (dictionaryItems x) + , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous + , testProperty "Dictionary must have atomic keys" + $ \vt -> forAll containerType $ \kt -> + isNothing (dictionaryFromItems kt vt []) + , testProperty "Dictionary <-> Array conversion" + $ \x -> arrayToDictionary (dictionaryToArray x) == Just x + ] + +<>= +instance Arbitrary Structure where + arbitrary = sized $ \n -> + fmap Structure $ shrinkingGen arbitrary + +<>= +, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure) + +@ \subsection{Addresses} + +<>= +singleTests :: Testable a => [a] -> [Test] +singleTests ts = singleTests' 1 ts where + singleTests' _ [] = [] + singleTests' n (t:ts') = plusOptions (testProperty (name n) t) + : singleTests' (n + 1) ts' + + total = length ts + options = F.TestOptions Nothing (Just 1) Nothing Nothing + plusOptions = F.plusTestOptions options + name n = "Test " ++ show n ++ "/" ++ show total + +<>= +, testGroup "Addresses" + [ testProperty "Address identity" + $ \x -> mkAddresses (strAddress x) == Just [x] + , testProperty "Multiple addresses" + $ \x y -> let + joined = TL.concat [strAddress x, ";", strAddress y] + in mkAddresses joined == Just [x, y] + , testProperty "Ignore trailing semicolon" + $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] + , testProperty "Ignore trailing comma" + $ \x -> let + hasParams = not . Map.null . addressParameters $ x + parsed = mkAddresses (TL.append (strAddress x) ",") + in hasParams ==> parsed == Just [x] + , testGroup "Valid addresses" $ singleTests + [ isJust . mkAddresses $ ":" + , isJust . mkAddresses $ "a:" + , isJust . mkAddresses $ "a:b=c" + , isJust . mkAddresses $ "a:;" + , isJust . mkAddresses $ "a:;b:" + , isJust . mkAddresses $ "a:b=c," + ] + , testGroup "Invalid addresses" $ singleTests + [ isNothing . mkAddresses $ "" + , isNothing . mkAddresses $ "a" + , isNothing . mkAddresses $ "a:b" + , isNothing . mkAddresses $ "a:b=" + , isNothing . mkAddresses $ "a:," + ] + ] + +<>= +instance Arbitrary Address where + arbitrary = genAddress where + optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + methodChars = filter (flip notElem ":;") ['!'..'~'] + keyChars = filter (flip notElem "=;,") ['!'..'~'] + + genMethod = sized' 0 $ elements methodChars + genParam = do + key <- genKey + value <- genValue + return . concat $ [key, "=", value] + + genKey = sized' 1 $ elements keyChars + genValue = oneof [encodedValue, plainValue] + genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] + encodedValue = do + x1 <- genHex + x2 <- genHex + return ['%', x1, x2] + plainValue = sized' 1 $ elements optional + + genParams = do + params <- sized' 0 genParam + let params' = intercalate "," params + extraComma <- if null params + then return "" + else elements ["", ","] + return $ concat [params', extraComma] + + genAddress = do + m <- genMethod + params <- genParams + extraSemicolon <- elements ["", ";"] + let addrStr = concat [m, ":", params, extraSemicolon] + let Just [addr] = mkAddresses $ TL.pack addrStr + return addr + +@ \subsection{Messages} + +<>= +instance Arbitrary Serial where + arbitrary = fmap Serial arbitrary + +instance Arbitrary Flag where + arbitrary = elements [NoReplyExpected, NoAutoStart] + +instance Arbitrary MethodCall where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodCall path member iface dest flags body + +instance Arbitrary MethodReturn where + arbitrary = do + serial <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodReturn serial dest flags body + +instance Arbitrary Error where + arbitrary = do + name <- arbitrary + serial <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ Error name serial dest flags body + +instance Arbitrary Signal where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ Signal path member iface dest flags body + +@ \subsection{Wire format} + +<>= +isRight :: Either a b -> Bool +isRight = either (const False) (const True) + +prop_Unmarshal :: Endianness -> Variant -> Property +prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where + sig = mkSignature . typeCode . variantType $ x + Just sig' = sig + + bytes = runMarshal (marshal x) e + Right bytes' = bytes + + valid = isJust sig && isRight bytes + unmarshaled = runUnmarshal (unmarshal sig') e bytes' + +prop_MarshalMessage e serial msg expected = valid ==> correct where + bytes = marshalMessage e serial msg + Right bytes' = bytes + + getBytes = G.getLazyByteString . fromIntegral + unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' + + valid = isRight bytes + correct = unmarshaled == Right expected + +prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodCall serial Nothing msg + +prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodReturn serial Nothing msg + +prop_WireError e serial msg = prop_MarshalMessage e serial msg + $ ReceivedError serial Nothing msg + +prop_WireSignal e serial msg = prop_MarshalMessage e serial msg + $ ReceivedSignal serial Nothing msg + +<>= +, testGroup "Wire format" + [ testProperty "Marshal -> Ummarshal" prop_Unmarshal + , testGroup "Messages" + [ testProperty "Method calls" prop_WireMethodCall + , testProperty "Method returns" prop_WireMethodReturn + , testProperty "Errors" prop_WireError + , testProperty "Signals" prop_WireSignal + ] + ] + +<>= +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian, BigEndian] + +@ \subsection{Introspection} + +<>= +, testGroup "Introspection" + [ testProperty "Generate -> Parse" + $ \x@(I.Object path _ _) -> let + xml = I.toXML x + Just xml' = xml + parsed = I.fromXML path xml' + in isJust xml ==> I.fromXML path xml' == Just x + ] + +<>= +subObject :: ObjectPath -> Gen I.Object +subObject parentPath = sized $ \n -> resize (min n 4) $ do + let nonRoot = do + x <- arbitrary + case strObjectPath x of + "/" -> nonRoot + x' -> return x' + + thisPath <- nonRoot + let path' = case strObjectPath parentPath of + "/" -> thisPath + x -> TL.append x thisPath + let path = mkObjectPath' path' + ifaces <- arbitrary + children <- shrinkingGen . listOf . subObject $ path + return $ I.Object path ifaces children + +instance Arbitrary I.Object where + arbitrary = arbitrary >>= subObject + +instance Arbitrary I.Interface where + arbitrary = do + name <- arbitrary + methods <- arbitrary + signals <- arbitrary + properties <- arbitrary + return $ I.Interface name methods signals properties + +instance Arbitrary I.Method where + arbitrary = do + name <- arbitrary + inParams <- arbitrary + outParams <- arbitrary + return $ I.Method name inParams outParams + +instance Arbitrary I.Signal where + arbitrary = do + name <- arbitrary + params <- arbitrary + return $ I.Signal name params + +singleType :: Gen Signature +singleType = do + t <- arbitrary + case mkSignature $ typeCode t of + Just x -> return x + Nothing -> singleType + +instance Arbitrary I.Parameter where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + return $ I.Parameter (TL.pack name) sig + +instance Arbitrary I.Property where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + access <- elements + [[], [I.Read], [I.Write], + [I.Read, I.Write]] + return $ I.Property (TL.pack name) sig access + +@ \subsection{Other instances} + +<>= +iexp :: Integral a => a -> a -> a +iexp x y = floor $ fromIntegral x ** fromIntegral y + +instance Arbitrary Word8 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 8 - 1 + +instance Arbitrary Word16 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 16 - 1 + +instance Arbitrary Word32 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 32 - 1 + +instance Arbitrary Word64 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 64 - 1 + +instance Arbitrary Int16 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 16 - 1 + +instance Arbitrary Int32 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 32 - 1 + +instance Arbitrary Int64 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 64 - 1 + +instance Arbitrary T.Text where + arbitrary = fmap T.pack arbitrary + +instance Arbitrary TL.Text where + arbitrary = fmap TL.pack arbitrary + +sized' :: Int -> Gen a -> Gen [a] +sized' atLeast g = sized $ \n -> do + n' <- choose (atLeast, max atLeast n) + replicateM n' g + +clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a +clampedSize maxSize gen f = do + s <- gen + if TL.length s > maxSize + then shrinkingGen arbitrary + else return . f $ s + +shrinkingGen :: Gen a -> Gen a +shrinkingGen gen = sized $ \n -> if n > 0 then + resize (n `div` 2) gen + else gen + diff --git a/Tests/Address.hs b/Tests/Address.hs deleted file mode 100644 --- a/Tests/Address.hs +++ /dev/null @@ -1,107 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -module Tests.Address (addressProperties) where - -import Control.Monad (replicateM) -import Data.List (intercalate) -import Data.Map (toList) -import Data.Maybe (isJust, isNothing) -import Test.QuickCheck -import Tests.Instances (sized') -import DBus.Address - -addressProperties = concat - [ prop_Valid - , prop_Invalid - , [ property prop_Identity - , property prop_MultipleAddresses - , property prop_IgnoreTrailingSemicolon - , property prop_IgnoreTrailingComma - ] - ] - --- Addresses can be converted to strings and back safely -prop_Identity x = parseAddresses (strAddress x) == Just [x] - --- Multiple addresses may be parsed -prop_MultipleAddresses x y = parseAddresses joined == Just [x, y] where - joined = concat [strAddress x, ";", strAddress y] - --- Trailing semicolons are ignored -prop_IgnoreTrailingSemicolon x = parseAddresses appended == Just [x] where - appended = strAddress x ++ ";" - --- Trailing commas are ignored -prop_IgnoreTrailingComma x = hasParams ==> ignoresComma where - hasParams = not . null $ params - ignoresComma = parseAddresses (strAddress x ++ ",") == Just [x] - params = toList . addressParameters $ x - -prop_Valid = let valid = property . isJust . parseAddresses in - [ valid ":" - , valid "a:" - , valid "a:b=c" - , valid "a:;" - , valid "a:;b:" - ] - -prop_Invalid = let invalid = property . isNothing . parseAddresses in - [ invalid "" - , invalid "a" - , invalid "a:b" - , invalid "a:b=" - ] - -instance Arbitrary Address where - coarbitrary = undefined - arbitrary = genAddress where - optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." - methodChars = filter (flip notElem ":;") ['!'..'~'] - keyChars = filter (flip notElem "=;,") ['!'..'~'] - - genMethod = sized' 0 $ elements methodChars - genParam = do - key <- genKey - value <- genValue - return . concat $ [key, "=", value] - - genKey = sized' 1 $ elements keyChars - genValue = oneof [encodedValue, plainValue] - genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] - encodedValue = do - x1 <- genHex - x2 <- genHex - return ['%', x1, x2] - plainValue = sized' 1 $ elements optional - - genParams = do - params <- sized' 0 genParam - let params' = intercalate "," params - extraComma <- if null params - then return "" - else elements ["", ","] - return $ concat [params', extraComma] - - genAddress = do - m <- genMethod - params <- genParams - extraSemicolon <- elements ["", ";"] - let addrStr = concat [m, ":", params, extraSemicolon] - let Just [addr] = parseAddresses addrStr - return addr - diff --git a/Tests/Containers.hs b/Tests/Containers.hs deleted file mode 100644 --- a/Tests/Containers.hs +++ /dev/null @@ -1,223 +0,0 @@ -{- - Copyright (C) 2009 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 RankNTypes #-} -module Tests.Containers (containerProperties) where - -import Control.Arrow ((&&&)) -import Data.Maybe (isJust, fromJust) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import Test.QuickCheck - -import Tests.Instances () - -import DBus.Types - -containerProperties = concat - [ forAllAtomic prop_AtomEquality - , forAllVariable prop_VariantEquality - - , forAllAtomic prop_AtomWrapping0 - , forAllAtomic prop_AtomWrapping1 - , forAllVariable prop_VariantWrapping - - , forAllAtomic prop_AtomSignature - , forAllAtomic prop_AtomDefaultSignature - , forAllVariable prop_DefaultSignature - , variantSignatureProperties - - , [ property prop_VariantSignatureLength - , property prop_VariantType - , property prop_AtomType - ] - - - , [ property prop_ArrayHomogeneous - , property prop_DictHomogeneous0 - , property prop_DictHomogeneous1 - ] - , props_EmptyArraySignature - , props_EmptyDictionarySignature - ] - --- Basic equality - -prop_AtomEquality gen = forAll gen $ \x y -> - (x == y) == (toAtom x == toAtom y) - -prop_VariantEquality gen = forAll gen $ \x y -> - (x == y) == (toVariant x == toVariant y) - --- Conversion to/from/between Atom and Variant - -prop_AtomWrapping0 gen = forAll gen $ \x -> - fromAtom (toAtom x) == Just x - -prop_AtomWrapping1 gen = forAll gen $ \x -> - atomToVariant (toAtom x) == toVariant x - -prop_VariantWrapping gen = forAll gen $ \x -> - fromVariant (toVariant x) == Just x - -prop_AtomSignature gen = forAll gen $ \x -> - atomSignature (toAtom x) == variantSignature (toVariant x) - -prop_AtomDefaultSignature gen = forAll gen $ \x -> - variantSignature (toVariant x) == defaultSignature x - -prop_DefaultSignature gen = forAll gen $ \x -> let - sig = strSignature . defaultSignature $ y - y = head [y, x] - in not . null $ sig - - --- Test that signatures are set properly -sameSig :: Variable a => a -> Type -> Bool -sameSig x t = t == (variantType . toVariant) x - -sameSig' :: Variable a => (a -> Signature) -> a -> Bool -sameSig' f x = f x == (variantSignature . toVariant) x - -variantSignatureProperties = - [ property $ \x -> sameSig (x :: Bool) BooleanT - , property $ \x -> sameSig (x :: Word8) ByteT - , property $ \x -> sameSig (x :: Word16) UInt16T - , property $ \x -> sameSig (x :: Word32) UInt32T - , property $ \x -> sameSig (x :: Word64) UInt64T - , property $ \x -> sameSig (x :: Int16) Int16T - , property $ \x -> sameSig (x :: Int32) Int32T - , property $ \x -> sameSig (x :: Int64) Int64T - , property $ \x -> sameSig (x :: Double) DoubleT - , property $ \x -> sameSig (x :: String) StringT - , property $ \x -> sameSig (x :: ObjectPath) ObjectPathT - , property $ \x -> sameSig (x :: Signature) SignatureT - , property $ sameSig' arraySignature - , property $ sameSig' dictionarySignature - , property $ sameSig' structureSignature - , property $ \x -> sameSig (x :: Variant) VariantT - ] - --- All variant signatures have one entry -prop_VariantSignatureLength x = length sig == 1 where - sig = signatureTypes . variantSignature $ x - --- variantType is a shortcut for getting the type in a variant's --- signature. -prop_VariantType x = variantType x == t where - t = head . signatureTypes . variantSignature $ x - --- Ditto atomType -prop_AtomType x = atomType x == t where - t = head . signatureTypes . atomSignature $ x - --- All items in an array have the same signature. If items do not have --- the same signature, the array can't be constructed -prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where - array = arrayFromItems sig vs - homogeneousTypes = if length vs > 0 - then all (== firstType) types - else True - types = map variantType vs - firstType = head types - sig = if length vs > 0 - then variantSignature (head vs) - else mkSignature' "y" - --- A dictionary must have homogeneous key and value types -prop_DictHomogeneous0 = homogeneousDict - -prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let - dict = dictionaryFromItems kSig vSig (zip ks vs) - (kSig, vSig) = if null ks - then (id &&& id) . mkSignature' $ "y" - else (atomSignature (head ks), variantSignature (head vs)) - in isJust dict ==> homogeneousDict (fromJust dict) - -homogeneousDict :: Dictionary -> Property -homogeneousDict x = length items > 0 ==> homogeneous where - items = dictionaryItems x - keys = [k | (k,_) <- items] - values = [v | (_,v) <- items] - - kTypes = map atomType keys - kFirst = head kTypes - - vTypes = map variantType values - vFirst = head vTypes - - homogeneous = all (== kFirst) kTypes && all (== vFirst) vTypes - -props_EmptyArraySignature = - [ check ([] :: [Word8]) "ay" - , check ([] :: [Bool]) "ab" - , check ([] :: [Array]) "aay" - , check ([] :: [Dictionary]) "aa{yy}" - , check ([] :: [Structure]) "a()" - , check ([] :: [Variant]) "av" - ] - where check xs sig = forAll (return sig) $ checkEmptyArray xs - -checkEmptyArray xs sig = arraySignature a == sig' where - sig' = mkSignature' sig - a = fromJust . toArray $ xs - -props_EmptyDictionarySignature = - [ check ([] :: [(Word8, Word8)]) "a{yy}" - , check ([] :: [(Bool, Word8)]) "a{by}" - , check ([] :: [(Bool, Array)]) "a{bay}" - , check ([] :: [(Bool, Dictionary)]) "a{ba{yy}}" - , check ([] :: [(Bool, Structure)]) "a{b()}" - , check ([] :: [(Bool, Variant)]) "a{bv}" - ] - where check xs sig = forAll (return sig) $ checkEmptyDict xs - -checkEmptyDict xs sig = dictionarySignature a == sig' where - sig' = mkSignature' sig - a = fromJust . toDictionary $ xs - --- TODO Conversion to/from array and dictionary - --- TODO: container signatures - --- Helper functions - -forAllAtomic :: (forall a. (Show a, Arbitrary a, Atomic a, Eq a) => - (Gen a -> Property)) -> [Property] -forAllAtomic t = - [ t (arbitrary :: Gen Bool) - , t (arbitrary :: Gen Word8) - , t (arbitrary :: Gen Word16) - , t (arbitrary :: Gen Word32) - , t (arbitrary :: Gen Word64) - , t (arbitrary :: Gen Int16) - , t (arbitrary :: Gen Int32) - , t (arbitrary :: Gen Int64) - , t (arbitrary :: Gen Double) - , t (arbitrary :: Gen String) - , t (arbitrary :: Gen ObjectPath) - , t (arbitrary :: Gen Signature) - ] - -forAllVariable :: (forall a. (Show a, Arbitrary a, Variable a, Eq a) => - (Gen a -> Property)) -> [Property] -forAllVariable t = forAllAtomic t ++ - [ t (arbitrary :: Gen Array) - , t (arbitrary :: Gen Dictionary) - , t (arbitrary :: Gen Structure) - , t (arbitrary :: Gen Variant) - ] diff --git a/Tests/Instances.hs b/Tests/Instances.hs deleted file mode 100644 --- a/Tests/Instances.hs +++ /dev/null @@ -1,289 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -module Tests.Instances (sized') where - -import Control.Monad (replicateM) -import Data.List (intercalate) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import Test.QuickCheck -import DBus.Types - -instance Arbitrary Char where - coarbitrary = undefined - arbitrary = choose ('!', '~') -- TODO: unicode? - -instance Arbitrary Word8 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 8 - 1 - -instance Arbitrary Word16 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 16 - 1 - -instance Arbitrary Word32 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 32 - 1 - -instance Arbitrary Word64 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 64 - 1 - -instance Arbitrary Int16 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 16 - 1 - -instance Arbitrary Int32 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 32 - 1 - -instance Arbitrary Int64 where - coarbitrary = undefined - arbitrary = gen where - gen = fmap fromIntegral (choose (0, max') :: Gen Integer) - max' = iexp 2 64 - 1 - -sized' :: Int -> Gen a -> Gen [a] -sized' atLeast g = sized $ \n -> do - n' <- choose (atLeast, max atLeast n) - replicateM n' g - -clampedSize :: Arbitrary a => Int -> Gen String -> (String -> a) -> Gen a -clampedSize maxSize gen f = do - s <- gen - if length s > maxSize - then sized (\n -> resize (n `div` 2) arbitrary) - else return . f $ s - -instance Arbitrary ObjectPath where - coarbitrary = undefined - arbitrary = fmap mkObjectPath' path' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - path = fmap (intercalate "/" . ([] :)) genElements - path' = frequency [(1, return "/"), (9, path)] - genElements = sized' 1 (sized' 1 (elements c)) - -instance Arbitrary InterfaceName where - coarbitrary = undefined - arbitrary = clampedSize 255 genName mkInterfaceName' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - - genName = fmap (intercalate ".") genElements - genElements = sized' 2 genElement - genElement = do - x <- elements c - xs <- sized' 0 (elements c') - return (x:xs) - - -instance Arbitrary BusName where - coarbitrary = undefined - arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" - c' = c ++ ['0'..'9'] - - unique = do - elems' <- sized' 2 $ elems c' - return $ ':' : intercalate "." elems' - - wellKnown = do - elems' <- sized' 2 $ elems c - return $ intercalate "." elems' - - elems start = do - x <- elements start - xs <- sized' 0 (elements c') - return (x:xs) - -instance Arbitrary MemberName where - coarbitrary = undefined - arbitrary = clampedSize 255 genName mkMemberName' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - - genName = do - x <- elements c - xs <- sized' 0 (elements c') - return (x:xs) - -instance Arbitrary ErrorName where - coarbitrary = undefined - arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary - -instance Arbitrary Type where - coarbitrary = undefined - arbitrary = oneof [atomicType, containerType] - -instance Arbitrary Signature where - coarbitrary = undefined - arbitrary = clampedSize 255 genSig mkSignature' where - genSig = fmap (concatMap typeString) arbitrary - -atomicType = elements - [ BooleanT - , ByteT - , UInt16T - , UInt32T - , UInt64T - , Int16T - , Int32T - , Int64T - , DoubleT - , StringT - , ObjectPathT - , SignatureT - ] - -containerType = do - c <- choose (0,3) :: Gen Int - case c of - 0 -> fmap ArrayT arbitrary - 1 -> do - kt <- atomicType - vt <- arbitrary - return $ DictionaryT kt vt - 2 -> sized structType - 3 -> return VariantT - -structType n | n >= 0 = fmap StructureT $ resize (n `div` 2) arbitrary - -instance Arbitrary Atom where - coarbitrary = undefined - arbitrary = atomicType >>= \t -> case t of - BooleanT -> fmap toAtom (arbitrary :: Gen Bool) - ByteT -> fmap toAtom (arbitrary :: Gen Word8) - UInt16T -> fmap toAtom (arbitrary :: Gen Word16) - UInt32T -> fmap toAtom (arbitrary :: Gen Word32) - UInt64T -> fmap toAtom (arbitrary :: Gen Word64) - Int16T -> fmap toAtom (arbitrary :: Gen Int16) - Int32T -> fmap toAtom (arbitrary :: Gen Int32) - Int64T -> fmap toAtom (arbitrary :: Gen Int64) - DoubleT -> fmap toAtom (arbitrary :: Gen Double) - StringT -> fmap toAtom (arbitrary :: Gen String) - ObjectPathT -> fmap toAtom (arbitrary :: Gen ObjectPath) - SignatureT -> fmap toAtom (arbitrary :: Gen Signature) - -instance Arbitrary Array where - coarbitrary = undefined - arbitrary = do - -- Only generate arrays of atomic values, as generating - -- containers randomly almost never results in a valid - -- array. - x <- atomicType >>= \t -> case t of - BooleanT -> fmap toArray (arbitrary :: Gen [Bool]) - ByteT -> fmap toArray (arbitrary :: Gen [Word8]) - UInt16T -> fmap toArray (arbitrary :: Gen [Word16]) - UInt32T -> fmap toArray (arbitrary :: Gen [Word32]) - UInt64T -> fmap toArray (arbitrary :: Gen [Word64]) - Int16T -> fmap toArray (arbitrary :: Gen [Int16]) - Int32T -> fmap toArray (arbitrary :: Gen [Int32]) - Int64T -> fmap toArray (arbitrary :: Gen [Int64]) - DoubleT -> fmap toArray (arbitrary :: Gen [Double]) - StringT -> fmap toArray (arbitrary :: Gen [String]) - ObjectPathT -> fmap toArray (arbitrary :: Gen [ObjectPath]) - SignatureT -> fmap toArray (arbitrary :: Gen [Signature]) - - maybe arbitrary return x - -instance Arbitrary Dictionary where - coarbitrary = undefined - arbitrary = do - -- Only generate dictionaries of atomic values, as generating - -- containers randomly almost never results in a valid - -- array. - kt <- atomicType - vt <- atomicType - ks <- case kt of - BooleanT -> fmap (map toAtom) (arbitrary :: Gen [Bool]) - ByteT -> fmap (map toAtom) (arbitrary :: Gen [Word8]) - UInt16T -> fmap (map toAtom) (arbitrary :: Gen [Word16]) - UInt32T -> fmap (map toAtom) (arbitrary :: Gen [Word32]) - UInt64T -> fmap (map toAtom) (arbitrary :: Gen [Word64]) - Int16T -> fmap (map toAtom) (arbitrary :: Gen [Int16]) - Int32T -> fmap (map toAtom) (arbitrary :: Gen [Int32]) - Int64T -> fmap (map toAtom) (arbitrary :: Gen [Int64]) - DoubleT -> fmap (map toAtom) (arbitrary :: Gen [Double]) - StringT -> fmap (map toAtom) (arbitrary :: Gen [String]) - ObjectPathT -> fmap (map toAtom) (arbitrary :: Gen [ObjectPath]) - SignatureT -> fmap (map toAtom) (arbitrary :: Gen [Signature]) - vs <- case vt of - BooleanT -> fmap (map toVariant) (arbitrary :: Gen [Bool]) - ByteT -> fmap (map toVariant) (arbitrary :: Gen [Word8]) - UInt16T -> fmap (map toVariant) (arbitrary :: Gen [Word16]) - UInt32T -> fmap (map toVariant) (arbitrary :: Gen [Word32]) - UInt64T -> fmap (map toVariant) (arbitrary :: Gen [Word64]) - Int16T -> fmap (map toVariant) (arbitrary :: Gen [Int16]) - Int32T -> fmap (map toVariant) (arbitrary :: Gen [Int32]) - Int64T -> fmap (map toVariant) (arbitrary :: Gen [Int64]) - DoubleT -> fmap (map toVariant) (arbitrary :: Gen [Double]) - StringT -> fmap (map toVariant) (arbitrary :: Gen [String]) - ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath]) - SignatureT -> fmap (map toVariant) (arbitrary :: Gen [Signature]) - - let kSig = mkSignature' . typeString $ kt - let vSig = mkSignature' . typeString $ vt - maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs)) - -instance Arbitrary Structure where - coarbitrary = undefined - arbitrary = sized $ \n -> - fmap Structure $ resize (n `div` 2) arbitrary - -instance Arbitrary Variant where - coarbitrary = undefined - arbitrary = arbitrary >>= \t -> case t of - BooleanT -> fmap toVariant (arbitrary :: Gen Bool) - ByteT -> fmap toVariant (arbitrary :: Gen Word8) - UInt16T -> fmap toVariant (arbitrary :: Gen Word16) - UInt32T -> fmap toVariant (arbitrary :: Gen Word32) - UInt64T -> fmap toVariant (arbitrary :: Gen Word64) - Int16T -> fmap toVariant (arbitrary :: Gen Int16) - Int32T -> fmap toVariant (arbitrary :: Gen Int32) - Int64T -> fmap toVariant (arbitrary :: Gen Int64) - DoubleT -> fmap toVariant (arbitrary :: Gen Double) - StringT -> fmap toVariant (arbitrary :: Gen String) - ObjectPathT -> fmap toVariant (arbitrary :: Gen ObjectPath) - SignatureT -> fmap toVariant (arbitrary :: Gen Signature) - ArrayT _ -> fmap toVariant (arbitrary :: Gen Array) - DictionaryT _ _ -> fmap toVariant (arbitrary :: Gen Dictionary) - StructureT _ -> fmap toVariant (arbitrary :: Gen Structure) - VariantT -> fmap toVariant (arbitrary :: Gen Variant) - -instance Arbitrary Endianness where - coarbitrary = undefined - arbitrary = elements [LittleEndian, BigEndian] - -instance Arbitrary Serial where - coarbitrary = undefined - arbitrary = fmap Serial arbitrary - -iexp :: Integral a => a -> a -> a -iexp x y = floor $ fromIntegral x ** fromIntegral y diff --git a/Tests/Marshal.hs b/Tests/Marshal.hs deleted file mode 100644 --- a/Tests/Marshal.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -module Tests.Marshal (marshalProperties) where - -import qualified Control.Exception as E -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString.Lazy as L -import Data.Word - -import Test.QuickCheck -import Tests.Instances () -import DBus.Types -import DBus.Marshal -import DBus.Unmarshal - -marshalProperties :: [Property] -marshalProperties = - [ property prop_MarshalAnyVariant - , property prop_MarshalAtom - , property prop_Unmarshal - ] - --- Check that any variant can be marshaled successfully. -prop_MarshalAnyVariant e x = noError $ marshal e [x] - --- Any atomic value should marshal to *something* -prop_MarshalAtom e x = not . L.null . marshal e $ [atomToVariant x] - --- TODO: test bytes of marshaled atoms - --- TODO: test bytes of marshaled containers - --- Any value, when marshaled, can be unmarshaled to the same value -prop_Unmarshal e x = unmarshaled == Right [x] where - bytes = marshal e [x] - unmarshaled :: Either String [Variant] - unmarshaled = unmarshal e (variantSignature x) bytes - --- Helper to determine whether the given pure function raised an exception. --- No exceptions should be raised during the normal process of marshaling. -noError :: a -> Bool -noError x = unsafePerformIO $ E.catch io onError where - onError :: E.SomeException -> IO Bool - onError = const (return False) - io = E.evaluate x >> return True diff --git a/Tests/Messages.hs b/Tests/Messages.hs deleted file mode 100644 --- a/Tests/Messages.hs +++ /dev/null @@ -1,131 +0,0 @@ -{- - Copyright (C) 2009 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 RankNTypes #-} -module Tests.Messages (messageProperties) where - -import Data.Set (fromList) -import Test.QuickCheck -import Tests.Instances () -import qualified Data.ByteString.Lazy as L -import DBus.Message -import DBus.Types - -import qualified Data.Binary.Get as G - -messageProperties = concat - [ headerFieldProperties - , forAllMessages prop_Marshal - , [ property prop_Unmarshal0 - , property prop_Unmarshal1 - , property prop_Unmarshal2 - , property prop_Unmarshal3 - ] - ] - -headerFieldProperties = - [ property prop_HeaderFieldVariable - ] - -prop_HeaderFieldVariable x = fromVariant (toVariant x) == Just x - where types = [x :: HeaderField] - -prop_Marshal gen = forAll arbitrary (\e s -> forAll gen (not . L.null . marshal e s)) - -prop_Unmarshal0 e s msg = checkUnmarshal expected e s msg where - expected = ReceivedMethodCall s Nothing msg - -prop_Unmarshal1 e s msg = checkUnmarshal expected e s msg where - expected = ReceivedMethodReturn s Nothing msg - -prop_Unmarshal2 e s msg = checkUnmarshal expected e s msg where - expected = ReceivedError s Nothing msg - -prop_Unmarshal3 e s msg = checkUnmarshal expected e s msg where - expected = ReceivedSignal s Nothing msg - -checkUnmarshal expected e s msg = unmarshaled == Right expected where - bytes = marshal e s msg - getBytes = G.getLazyByteString . fromIntegral - unmarshaled = G.runGet (unmarshal getBytes) bytes - -forAllMessages :: (forall a. (Show a, Arbitrary a, Message a, Eq a) => - (Gen a -> Property)) -> [Property] -forAllMessages t = - [ t (arbitrary :: Gen MethodCall) - , t (arbitrary :: Gen MethodReturn) - , t (arbitrary :: Gen Error) - , t (arbitrary :: Gen Signal) - ] - -instance Arbitrary Flag where - coarbitrary = undefined - arbitrary = elements [NoReplyExpected, NoAutoStart] - -instance Arbitrary HeaderField where - coarbitrary = undefined - arbitrary = do - x <- choose (1, 8) - case (x :: Int) of - 1 -> fmap Path arbitrary - 2 -> fmap Interface arbitrary - 3 -> fmap Member arbitrary - 4 -> fmap ErrorName arbitrary - 5 -> fmap ReplySerial arbitrary - 6 -> fmap Destination arbitrary - 7 -> fmap Sender arbitrary - 8 -> fmap Signature arbitrary - -instance Arbitrary MethodCall where - coarbitrary = undefined - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - dest <- arbitrary - flags <- fmap fromList arbitrary - body <- sized (\n -> resize (n `div` 2) arbitrary) - return $ MethodCall path member iface dest flags body - -instance Arbitrary MethodReturn where - coarbitrary = undefined - arbitrary = do - serial <- arbitrary - dest <- arbitrary - flags <- fmap fromList arbitrary - body <- sized (\n -> resize (n `div` 2) arbitrary) - return $ MethodReturn serial dest flags body - -instance Arbitrary Error where - coarbitrary = undefined - arbitrary = do - name <- arbitrary - serial <- arbitrary - dest <- arbitrary - flags <- fmap fromList arbitrary - body <- sized (\n -> resize (n `div` 2) arbitrary) - return $ Error name serial dest flags body - -instance Arbitrary Signal where - coarbitrary = undefined - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - flags <- fmap fromList arbitrary - body <- sized (\n -> resize (n `div` 2) arbitrary) - return $ Signal path member iface flags body diff --git a/Tests/MiscTypes.hs b/Tests/MiscTypes.hs deleted file mode 100644 --- a/Tests/MiscTypes.hs +++ /dev/null @@ -1,168 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -module Tests.MiscTypes (miscTypeProperties) where - -import Data.Maybe (isNothing) -import Data.Word (Word8) -import Test.QuickCheck -import Tests.Instances () -import DBus.Types - -miscTypeProperties = concat - [ objectPathProperties - , interfaceNameProperties - , busNameProperties - , memberNameProperties - , errorNameProperties - , endiannessProperties - , serialProperties - ] - -prop_Equality x = x == x - -prop_IsVariable x = fromVariant (toVariant x) == Just x - -prop_IsAtomic x = fromAtom (toAtom x) == Just x - --- Object paths - -objectPathProperties = - [ property (prop_Equality :: ObjectPath -> Bool) - , property (prop_IsVariable :: ObjectPath -> Bool) - , property (prop_IsAtomic :: ObjectPath -> Bool) - , property prop_ObjectPathIdentity - ] ++ map property prop_ObjectPathInvalid - -prop_ObjectPathIdentity x = mkObjectPath (strObjectPath x) == Just x - -prop_ObjectPathInvalid = let invalid = isNothing . mkObjectPath in - [ invalid "" - , invalid "a" - , invalid "/a/" - , invalid "/a/-" - ] - --- Endianness - -endiannessProperties = - [ property (prop_Equality :: Endianness -> Bool) - , property prop_EndianToVariant - , property prop_EndianFromVariant - ] - -prop_EndianToVariant x@(LittleEndian) = toVariant x == toVariant (0x6C :: Word8) -prop_EndianToVariant x@(BigEndian) = toVariant x == toVariant (0x42 :: Word8) - -endianWords :: Gen Word8 -endianWords = oneof [ return 0x6C , return 0x42 , arbitrary] - -prop_EndianFromVariant = forAll endianWords $ \x -> let - v = fromVariant (toVariant x) in case x of - 0x6C -> v == Just LittleEndian - 0x42 -> v == Just BigEndian - _ -> isNothing v - --- Interface names - -interfaceNameProperties = - [ property (prop_Equality :: InterfaceName -> Bool) - , property (prop_IsVariable :: InterfaceName -> Bool) - , property (prop_IsAtomic :: InterfaceName -> Bool) - , property prop_InterfaceNameIdentity - ] ++ map property prop_InterfaceNameInvalid - -prop_InterfaceNameIdentity x = mkInterfaceName (strInterfaceName x) == Just x - -prop_InterfaceNameInvalid = let invalid = isNothing . mkInterfaceName in - [ invalid "" - , invalid "0" - , invalid "a" - , invalid "a." - , invalid "a.1" - , invalid $ "a." ++ replicate 255 'b' - ] - --- Bus names - -busNameProperties = - [ property (prop_Equality :: BusName -> Bool) - , property (prop_IsVariable :: BusName -> Bool) - , property (prop_IsAtomic :: BusName -> Bool) - , property prop_BusNameIdentity - ] ++ map property prop_BusNameInvalid - -prop_BusNameIdentity x = mkBusName (strBusName x) == Just x - -prop_BusNameInvalid = let invalid = isNothing . mkBusName in - [ invalid "" - , invalid ":" - , invalid ":0" - , invalid ":a" - , invalid "0" - , invalid "a" - , invalid "a." - , invalid "a.1" - , invalid $ "a." ++ replicate 255 'b' - ] - --- Member names - -memberNameProperties = - [ property (prop_Equality :: MemberName -> Bool) - , property (prop_IsVariable :: MemberName -> Bool) - , property (prop_IsAtomic :: MemberName -> Bool) - , property prop_MemberNameIdentity - ] ++ map property prop_MemberNameInvalid - -prop_MemberNameIdentity x = mkMemberName (strMemberName x) == Just x - -prop_MemberNameInvalid = let invalid = isNothing . mkMemberName in - [ invalid "" - , invalid "0" - , invalid $ replicate 256 'a' - ] - --- Error names - -errorNameProperties = - [ property (prop_Equality :: ErrorName -> Bool) - , property (prop_IsVariable :: ErrorName -> Bool) - , property (prop_IsAtomic :: ErrorName -> Bool) - , property prop_ErrorNameIdentity - ] ++ map property prop_ErrorNameInvalid - -prop_ErrorNameIdentity x = mkErrorName (strErrorName x) == Just x - -prop_ErrorNameInvalid = let invalid = isNothing . mkErrorName in - [ invalid "" - , invalid "0" - , invalid "a" - , invalid "a." - , invalid "a.1" - , invalid $ "a." ++ replicate 255 'b' - ] - --- Serials - -serialProperties = - [ property (prop_IsVariable :: Serial -> Bool) - , property (prop_IsAtomic :: Serial -> Bool) - , property prop_SerialIncremented - ] - -prop_SerialIncremented x = nextSerial x > x diff --git a/Tests/Signature.hs b/Tests/Signature.hs deleted file mode 100644 --- a/Tests/Signature.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- - Copyright (C) 2009 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 . --} - -module Tests.Signature (signatureProperties) where - -import Data.Maybe (isJust, isNothing) -import Test.QuickCheck -import Tests.Instances () -import DBus.Types - -signatureProperties = - [ property (prop_Equality :: Signature -> Bool) - , property (prop_Equality :: Type -> Bool) - , property prop_TypeToSig - , property prop_Ident - , property prop_Length0 - , property prop_Length254 - , property prop_Length255 - , property prop_Length256 - , property prop_Invalid0 - , property prop_Invalid1 - , property prop_Invalid2 - , property prop_show0 - , property prop_show1 - ] - --- Signatures and type equality -prop_Equality x = x == x - --- Types can be converted to signatures via mkSignature -prop_TypeToSig x = typeString x == strSignature sig where - Just sig = mkSignature (typeString x) - --- Signatures can be safely converted to strings and back -prop_Ident x = mkSignature (strSignature x) == Just x - --- Signatures may be no more than 255 characters long -prop_Length0 = isJust . mkSignature $ "" -prop_Length254 = isJust . mkSignature . replicate 254 $ 'y' -prop_Length255 = isJust . mkSignature . replicate 255 $ 'y' -prop_Length256 = isNothing . mkSignature . replicate 256 $ 'y' - --- Invalid signatures are not parsed -prop_Invalid0 = isNothing . mkSignature $ "a" -prop_Invalid1 = isNothing . mkSignature $ "0" -prop_Invalid2 = isNothing . mkSignature $ "a{vy}" - --- Show is useful -prop_show0 x = showsPrec 10 x "" == "Signature \"" ++ strSignature x ++ "\"" -prop_show1 x = showsPrec 11 x "" == "(Signature \"" ++ strSignature x ++ "\")" diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,6 +1,6 @@ name: dbus-core -version: 0.4 -synopsis: Low-level DBus protocol implementation +version: 0.5 +synopsis: Low-level D-Bus protocol implementation license: GPL license-file: License.txt author: John Millikin @@ -12,17 +12,24 @@ bug-reports: mailto:jmillikin@gmail.com extra-source-files: - dbus-core.tex + dbus-core.nw Examples/*.hs - Tests/*.hs - Tests.hs + Makefile + Tests.nw source-repository head type: darcs location: http://patch-tag.com/r/jmillikin/dbus-core/pullrepo +flag test + default: False + +flag hpc + default: False + library ghc-options: -Wall + hs-source-dirs: hs build-depends: base >=4 && < 5, @@ -30,7 +37,9 @@ binary, bytestring, data-binary-ieee754 >= 0.3, - utf8-string, + HaXml >= 1.19.7, + pretty, + text, mtl, containers, unix, @@ -41,23 +50,36 @@ DBus.Bus DBus.Connection DBus.Constants + DBus.Introspection DBus.Message DBus.Types other-modules: - DBus.Authentication - DBus.Types.Atom - DBus.Types.Containers - DBus.Types.Containers.Array - DBus.Types.Containers.Dictionary - DBus.Types.Containers.Structure - DBus.Types.Containers.Variant - DBus.Types.Endianness - DBus.Types.Names - DBus.Types.ObjectPath - DBus.Types.Serial - DBus.Types.Signature - DBus.Marshal - DBus.Padding - DBus.Unmarshal + DBus.Message.Internal + DBus.Wire DBus.Util + +executable tests + main-is: Tests.hs + hs-source-dirs: hs + + if flag(test) + build-depends: + QuickCheck >= 2 + , test-framework + , test-framework-quickcheck2 + else + buildable: False + + if flag(hpc) + ghc-options: -fhpc + + other-modules: + DBus.Address + DBus.Constants + DBus.Introspection + DBus.Message + DBus.Types + DBus.Wire + DBus.Util + diff --git a/dbus-core.nw b/dbus-core.nw new file mode 100644 --- /dev/null +++ b/dbus-core.nw @@ -0,0 +1,3085 @@ + +% Copyright (C) 2009 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 . + +\documentclass[12pt]{article} + +\usepackage{color} +\usepackage{hyperref} +\usepackage{booktabs} +\usepackage{multirow} +\usepackage{noweb} +\usepackage{url} + +% Smaller margins +\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} + +% Remove boxes from hyperlinks +\hypersetup{ + colorlinks, + linkcolor=blue, +} + +\makeindex + +\begin{document} + +\addcontentsline{toc}{section}{Contents} +\tableofcontents + +@ +\section{Introduction} + +D-Bus is a low-latency, asynchronous IPC protocol. It is primarily used on +Linux, BSD, and other free UNIX-like systems. More information is available +at \url{http://dbus.freedesktop.org/}. + +This package is an implementation of the D-Bus protocol. It is intended +for use in either a client or server, though currently only the client +portion of connection establishment is implemented. Additionally, it +implements the introspection file format. + +All source code is licensed under the terms of the GNU GPL v3 or later. + +<>= +{- + Copyright (C) 2009 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 . +-} + +@ +\section{Text values} + +Most of the functions in this library use the types and functions defined +in {\tt Data.Text}, in preference to the {\tt String} type. + +<>= +{-# LANGUAGE OverloadedStrings #-} + +<>= +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +@ +\section{Types} + +The {\tt DBus.Types module} defines interfaces for storing, building, and +deconstructing D-Bus values. + +<>= +<> +<> +<> +module DBus.Types (<>) where +<> +<> + +@ DBus types are divided into two categories, ``atomic'' and ``container'' +types. Atoms are actual values -- strings, numbers, etc. Containers store +atoms and other containers. The most interesting difference between the two +is that atoms may be used as the keys in associative mappings +(``dictionaries''). + +Internally, types are represented using an enumeration. + +<>= +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) + +<>= +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 + +@ Each type can be converted to a textual representation, used in ``type +signatures'' or for debugging. + +<>= +typeCode :: Type -> Text + +<>= + -- * Available types + Type (..) +, typeCode + +@ Certain Haskell types are considered ``built-in'' D-Bus types; that is, +they are directly represented in the D-Bus protocol. + +<>= +class (Show a, Eq a) => Builtin a where + builtinDBusType :: a -> Type + +@ \subsection{Variants} + +A wrapper type is needed for safely storing generic D-Bus values in Haskell. +The D-Bus ``variant'' type is perfect for this, because variants may store +any D-Bus value. + +To cleanly store any D-Bus type, without exposing the internal storage +mechanism, requires existential quantification and some run-time casting. + +<>= +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +<>= +import Data.Typeable (Typeable, cast) + +@ Any type which is an instance of {\tt Variable} is considered a valid +D-Bus value, because it can be used to construct {\tt Variant}s. However, +outside of this module, {\tt Variant}s can only be constructed from +pre-defined types. + +<>= +data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a + deriving (Typeable) + +class Variable a where + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a + +<>= + -- * Variants +, Variant +, Variable (..) + +@ Variants can be printed, for debugging purposes -- this instance shouldn't +be parsed or inspected or anything like that, since the output format might +change drastically. + +<>= +instance Show Variant where + showsPrec d (Variant x) = showParen (d > 10) $ + s "Variant " . shows code . s " " . showsPrec 11 x + where code = typeCode . builtinDBusType $ x + s = showString + +@ In the test suite, it's useful to test that two variants have the same +value. + +<>= +instance Eq Variant where + (Variant x) == (Variant y) = cast x == Just y + +@ Since many operations on D-Bus values depend on having the correct type, +{\tt variantType} is used to retrieve which type is actually stored within +a {\tt Variant}. + +<>= +variantType :: Variant -> Type +variantType (Variant x) = builtinDBusType x + +<>= +, variantType + +@ These helper macros will be used for defining instances of Haskell types. + +<>= +#define INSTANCE_BUILTIN(HASKELL, DBUS) \ + instance Builtin HASKELL where \ + { builtinDBusType _ = DBUS }; + +#define INSTANCE_VARIABLE(HASKELL) \ + instance Variable HASKELL where \ + { toVariant = Variant \ + ; fromVariant (Variant x) = cast x }; + +#define BUILTIN_VARIABLE(HASKELL, DBUS) \ + INSTANCE_BUILTIN(HASKELL, DBUS) \ + INSTANCE_VARIABLE(HASKELL) + +@ Since {\tt Variant}s are D-Bus values themselves, they have a type. + +<>= +BUILTIN_VARIABLE(Variant, DBusVariant) + +@ \subsection{Numerics} + +D-Bus supports most common numeric types: + +\begin{table}[h] +\caption{D-Bus Numeric types} +\begin{center} +\begin{tabular}{ll} +\toprule +Type & Description \\ +\midrule +Boolean & Either {\tt True} or {\tt False} \\ +Byte & 8-bit unsigned integer \\ +Int16 & 16-bit signed integer \\ +Int32 & 32-bit signed integer \\ +Int64 & 64-bit signed integer \\ +Word16 & 16-bit unsigned integer \\ +Word32 & 32-bit unsigned integer \\ +Word64 & 64-bit unsigned integer \\ +Double & 64-bit IEEE754 floating-point \\ +\bottomrule +\end{tabular} +\end{center} +\end{table} + +All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer} +types can't be used. Instead, instances for the fixed-length integer types +are defined and any others will have to be converted. + +<>= +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +<>= +BUILTIN_VARIABLE(Bool, DBusBoolean) +BUILTIN_VARIABLE(Word8, DBusByte) +BUILTIN_VARIABLE(Int16, DBusInt16) +BUILTIN_VARIABLE(Int32, DBusInt32) +BUILTIN_VARIABLE(Int64, DBusInt64) +BUILTIN_VARIABLE(Word16, DBusWord16) +BUILTIN_VARIABLE(Word32, DBusWord32) +BUILTIN_VARIABLE(Word64, DBusWord64) +BUILTIN_VARIABLE(Double, DBusDouble) + +@ \subsection{Strings} + +Strings are a weird case; the built-in type, {\tt String}, is horribly +inefficent. To provide better performance for large strings, packed Unicode +strings defined in {\tt Data.Text} are used internally. + +<>= +BUILTIN_VARIABLE(TL.Text, DBusString) + +@ There's two different {\tt Text} types, strict and lazy. It'd be a pain +to store both and have to convert later, so instead, all strict {\tt Text} +values are converted to lazy values. + +<>= +import qualified Data.Text as T + +<>= +instance Variable T.Text where + toVariant = toVariant . TL.fromChunks . (:[]) + fromVariant = fmap (T.concat . TL.toChunks) . fromVariant + +@ Built-in {\tt String}s can still be stored, of course, but it requires +a language extension. + +<>= +{-# LANGUAGE TypeSynonymInstances #-} + +<>= +instance Variable String where + toVariant = toVariant . TL.pack + fromVariant = fmap TL.unpack . fromVariant + +@ \subsection{Signatures} + +@ Valid DBus types must obey certain rules, such as ``dict keys must be +atomic'', which are difficult to express in the Haskell type system. A +{\tt Signature} is guaranteed to be valid according to these rules. Creating +one requires using the {\tt mkSignature} function, which will convert a valid +DBus signature string into a {\tt Signature}. + +<>= +BUILTIN_VARIABLE(Signature, DBusSignature) +data Signature = Signature { signatureTypes :: [Type] } + deriving (Eq, Typeable) + +instance Show Signature where + showsPrec d x = showParen (d > 10) $ + showString "Signature " . shows (strSignature x) + +@ Signatures can also be converted back into text, by concatenating the +type codes of their contained types. + +<>= +strSignature :: Signature -> Text +strSignature (Signature ts) = TL.concat $ map typeCode ts + +@ It doesn't make much sense to sort signatures, but since they can be used +as dictionary keys, it's useful to have them as an instance of {\tt Ord}. + +<>= +instance Ord Signature where + compare x y = compare (strSignature x) (strSignature y) + +<>= + -- * Signatures +, Signature +, signatureTypes +, strSignature + +@ \subsubsection{Type codes} + +@ For atomic types, the type code is a single letter. Arrays, structures, +and dictionary types are multiple characters. + +<>= +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" + +@ 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''. + +<>= +typeCode (DBusArray t) = TL.cons 'a' $ typeCode 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}''. + +<>= +typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] + +@ A structure's type code is the concatenation of its contained types, +wrapped by ``('' and ``)''. Structures may be empty, in which case their +type code is simply ``()''. + +<>= +typeCode (DBusStructure ts) = TL.concat $ + ["("] ++ map typeCode ts ++ [")"] + +@ \subsubsection{Parsing} + +When parsing, additional restrictions apply which are not inherent to the +D-Bus type system: + +\begin{itemize} +\item Signatures may be at most 255 characters long. +\end{itemize} + +Parsec is used to parse signatures. + +<>= +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import DBus.Util (checkLength, parseMaybe) + +<>= +mkSignature :: Text -> Maybe Signature +mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where + sigParser = do + types <- P.many parseType + P.eof + return $ Signature types + parseType = parseAtom <|> parseContainer + parseContainer = + parseArray + <|> parseStruct + <|> (P.char 'v' >> return DBusVariant) + 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) + parseArray = do + P.char 'a' + parseDict <|> do + t <- parseType + return $ DBusArray t + 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 + +@ Since many signatures are defined as string literals, it's useful to +have a helper function to construct a signature directly from a string. +If the input string is invalid, {\tt error} will be called. + +<>= +import DBus.Util (mkUnsafe) + +<>= +mkSignature' :: Text -> Signature +mkSignature' = mkUnsafe "signature" mkSignature + +@ Most signature-related functions are exposed to clients, except the +{\tt Signature} value constructor. If that were exposed, clients could +construct invalid signatures. + +<>= +, mkSignature +, mkSignature' + +@ \subsection{Object paths} + +<>= +BUILTIN_VARIABLE(ObjectPath, DBusObjectPath) +newtype ObjectPath = ObjectPath + { strObjectPath :: Text + } + deriving (Show, Eq, Ord, Typeable) + +@ An object path may be one of + +\begin{itemize} +\item The root path, {\tt "/"}. +\item {\tt '/'}, followed by one or more element names. Each element name + contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at + least one character. +\end{itemize} + +Element names are separated by {\tt '/'}, and the path may not end in +{\tt '/'} unless it is the root path. + +<>= +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 + +<>= + -- * Object paths +, ObjectPath +, strObjectPath +, mkObjectPath +, mkObjectPath' + +@ \subsection{Arrays} + +Arrays are homogenous sequences of any valid DBus type. Arrays might be +empty, so the type they contain is stored instead of being calculated from +their contents (as in {\tt variantType}). + +TODO: There ought to be a specialised constructor for arrays of bytes, based +on the {\tt ByteString} type. Storing bytes individually in a list of +{\tt Variant}s is inefficient. + +<>= +INSTANCE_VARIABLE(Array) +data Array = Array + { arrayType :: Type + , arrayItems :: [Variant] + } + deriving (Eq, Typeable) + +instance Builtin Array where + builtinDBusType = DBusArray . arrayType + +<>= + -- * Arrays +, Array +, arrayType +, arrayItems + +@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly +just useful for debugging. + +<>= +instance Show Array where + showsPrec d (Array t vs) = showParen (d > 10) $ + s "Array " . showSig . s " [" . s valueString . s "]" where + s = showString + showSig = shows $ typeCode t + vs' = [show x | (Variant x) <- vs] + valueString = intercalate ", " vs' + +@ Clients constructing an array must provide the expected item type, which +will be checked for validity. Every item in the array will be checked against +the item type, to ensure the array is homogenous. + +<>= +arrayFromItems :: Type -> [Variant] -> Maybe Array +arrayFromItems t vs = do + mkSignature (typeCode t) + if all (\x -> variantType x == t) vs + then Just $ Array t vs + else Nothing + +@ Additionally, for ease of use, an {\tt Array} can be converted directly +to/from lists of {\tt Variable} values. + +<>= +toArray :: Variable a => Type -> [a] -> Maybe Array +toArray t = arrayFromItems t . map toVariant + +fromArray :: Variable a => Array -> Maybe [a] +fromArray = mapM fromVariant . arrayItems + +<>= +, toArray +, fromArray +, arrayFromItems + +@ \subsection{Dictionaries} + +Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the +key type must be atomic. Values may be of any valid DBus type. Like +{\tt Array}, {\tt Dictionary} stores its contained types. + +<>= +INSTANCE_VARIABLE(Dictionary) +data Dictionary = Dictionary + { dictionaryKeyType :: Type + , dictionaryValueType :: Type + , dictionaryItems :: [(Variant, Variant)] + } + deriving (Eq, Typeable) + +instance Builtin Dictionary where + builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt + +<>= + -- * Dictionaries +, Dictionary +, dictionaryItems +, dictionaryKeyType +, dictionaryValueType + +@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable +format than a list of pairs. + +<>= +import Data.List (intercalate) + +<>= +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 ((Variant k), (Variant v)) = + show k ++ " -> " ++ show v + +@ Constructing a {\tt Dictionary} works like constructing an {\tt Array}, +except that there are two types to check, and the key type must be atomic. + +<>= +import Control.Monad (unless) + +<>= +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 + +@ The closest match for dictionary semantics in Haskell is the +{\tt Data.Map.Map} type. Therefore, the utility conversion functions work +with {\tt Map}s instead of pair lists. + +<>= +import Control.Arrow ((***)) +import qualified Data.Map as Map + +<>= +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 + +<>= +import Control.Monad (forM) + +<>= +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 + +<>= +, toDictionary +, fromDictionary +, dictionaryFromItems + +@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}} + +Converting between {\tt Array} and {\tt Dictionary} is useful when +(un)marshaling -- dictionaries can be thought of as arrays of two-element +structures, much as a {\tt Map} is a list of 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 t items) = do + let toPair x = do + struct <- fromVariant x + case struct of + Structure [k, v] -> Just (k, v) + _ -> Nothing + (kt, vt) <- case t of + DBusStructure [kt, vt] -> Just (kt, vt) + _ -> Nothing + pairs <- mapM toPair items + dictionaryFromItems kt vt pairs + +<>= +, dictionaryToArray +, arrayToDictionary + +@ \subsection{Structures} + +A heterogeneous, fixed-length container; equivalent in purpose to a Haskell +tuple. + +<>= +INSTANCE_VARIABLE(Structure) +data Structure = Structure [Variant] + deriving (Show, Eq, Typeable) + +instance Builtin Structure where + builtinDBusType (Structure vs) = DBusStructure $ map variantType vs + +<>= + -- * Structures +, Structure (..) + +@ \subsection{Names} + +Various aspects of DBus require the use of specially-formatted strings, +called ``names''. All names are limited to 255 characters, and use subsets +of ASCII. + +Since all names have basically the same structure (a {\tt newtype} +declaration and some helper functions), I define a macro to automate +the definitions. + +<>= +#define NAME_TYPE(TYPE, NAME) \ + newtype TYPE = TYPE {str##TYPE :: Text} \ + deriving (Show, Eq, Ord); \ + \ + instance Variable TYPE where \ + { toVariant = toVariant . str##TYPE \ + ; fromVariant = (mk##TYPE =<<) . fromVariant }; \ + \ + mk##TYPE##' :: Text -> TYPE; \ + mk##TYPE##' = mkUnsafe NAME mk##TYPE + +<>= +-- * Names + +@ \subsubsection{Bus names} + +There are two forms of bus names, ``unique'' and ``well-known''. + +Unique names begin with {\tt `:'} and contain two or more elements, separated +by {\tt `.'}. Each element consists of characters from the set +{\tt [a-zA-Z0-9\_-]}. + +Well-known names contain two or more elements, separated by {\tt `.'}. Each +element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must +not start with a digit. + +<>= +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') + +<>= + -- ** Bus names +, BusName +, strBusName +, mkBusName +, mkBusName' + +@ \subsubsection{Interface names} + +An interface name consists of two or more {\tt '.'}-separated elements. Each +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. + +<>= +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) + +<>= + -- ** Interface names +, InterfaceName +, strInterfaceName +, mkInterfaceName +, mkInterfaceName' + +@ \subsubsection{Error names} + +Error names have the same format as interface names, so the parser logic +can just be re-purposed. + +<>= +NAME_TYPE(ErrorName, "error name") + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + +<>= + -- ** Error names +, ErrorName +, strErrorName +, mkErrorName +, mkErrorName' + +@ \subsubsection{Member names} + +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. + +<>= +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) + +<>= + -- ** Member names +, MemberName +, strMemberName +, mkMemberName +, mkMemberName' + +@ +\section{Messages} + +@ To prevent internal details of messages from leaking out to clients, +declarations are contained in an internal module and then re-exported +in the public module. + +<>= +<> +module DBus.Message + (<> + ) where +import DBus.Message.Internal + +<>= +<> +module DBus.Message.Internal where +import qualified Data.Set as S +import Data.Word (Word8, Word32) +import qualified DBus.Types as T + +<>= +class Message a where + messageTypeCode :: a -> Word8 + messageHeaderFields :: a -> [HeaderField] + messageFlags :: a -> S.Set Flag + messageBody :: a -> [T.Variant] + +<>= +Message ( messageFlags + , messageBody + ) + +@ \subsection{Flags} + +The instance of {\tt Ord} only exists for storing flags in a set. Flags have +no inherent ordering. + +<>= +data Flag + = NoReplyExpected + | NoAutoStart + deriving (Show, Eq, Ord) + +<>= +, Flag (..) + +@ \subsection{Header fields} + +<>= +data HeaderField + = Path T.ObjectPath + | Interface T.InterfaceName + | Member T.MemberName + | ErrorName T.ErrorName + | ReplySerial Serial + | Destination T.BusName + | Sender T.BusName + | Signature T.Signature + deriving (Show, Eq) + +@ \subsection{Serials} + +{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of +added type-safety. + +<>= +newtype Serial = Serial { serialValue :: Word32 } + deriving (Eq, Ord) + +instance Show Serial where + show (Serial x) = show x + +instance T.Variable Serial where + toVariant (Serial x) = T.toVariant x + fromVariant = fmap Serial . T.fromVariant + +@ Additionally, some useful functions exist for incrementing serials. + +<>= +firstSerial :: Serial +firstSerial = Serial 1 + +nextSerial :: Serial -> Serial +nextSerial (Serial x) = Serial (x + 1) + +@ The {\tt Serial} constructor isn't useful to clients, because building +arbitrary serials doesn't make any sense. + +<>= +, Serial +, serialValue + +@ \subsection{Message types} + +<>= +maybe' :: (a -> b) -> Maybe a -> [b] +maybe' f = maybe [] (\x' -> [f x']) + +@ \subsubsection{Method calls} + +<>= +data MethodCall = MethodCall + { methodCallPath :: T.ObjectPath + , methodCallMember :: T.MemberName + , methodCallInterface :: Maybe T.InterfaceName + , methodCallDestination :: Maybe T.BusName + , methodCallFlags :: S.Set Flag + , methodCallBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodCall where + messageTypeCode _ = 1 + messageFlags = methodCallFlags + messageBody = methodCallBody + messageHeaderFields m = concat + [ [ Path $ methodCallPath m + , Member $ methodCallMember m + ] + , maybe' Interface . methodCallInterface $ m + , maybe' Destination . methodCallDestination $ m + ] + +<>= +, MethodCall (..) + +@ \subsubsection{Method returns} + +<>= +data MethodReturn = MethodReturn + { methodReturnSerial :: Serial + , methodReturnDestination :: Maybe T.BusName + , methodReturnFlags :: S.Set Flag + , methodReturnBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodReturn where + messageTypeCode _ = 2 + messageFlags = methodReturnFlags + messageBody = methodReturnBody + messageHeaderFields m = concat + [ [ ReplySerial $ methodReturnSerial m + ] + , maybe' Destination . methodReturnDestination $ m + ] + +<>= +, MethodReturn (..) + +@ \subsubsection{Errors} + +<>= +data Error = Error + { errorName :: T.ErrorName + , errorSerial :: Serial + , errorDestination :: Maybe T.BusName + , errorFlags :: S.Set Flag + , errorBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Error where + messageTypeCode _ = 3 + messageFlags = errorFlags + messageBody = errorBody + messageHeaderFields m = concat + [ [ ErrorName $ errorName m + , ReplySerial $ errorSerial m + ] + , maybe' Destination . errorDestination $ m + ] + +<>= +, Error (..) + +@ \subsubsection{Signals} + +<>= +data Signal = Signal + { signalPath :: T.ObjectPath + , signalMember :: T.MemberName + , signalInterface :: T.InterfaceName + , signalDestination :: Maybe T.BusName + , signalFlags :: S.Set Flag + , signalBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Signal where + messageTypeCode _ = 4 + messageFlags = signalFlags + messageBody = signalBody + messageHeaderFields m = concat + [ [ Path $ signalPath m + , Member $ signalMember m + , Interface $ signalInterface m + ] + , maybe' Destination . signalDestination $ m + ] + +<>= +, Signal (..) + +@ \subsubsection{Unknown messages} + +Unknown messages are used for storing information about messages without +a recognized type code. They are not instances of {\tt Message}, because +if they were, then clients could accidentally send invalid messages over +the bus. + +<>= +data Unknown = Unknown + { unknownType :: Word8 + , unknownFlags :: S.Set Flag + , unknownBody :: [T.Variant] + } + deriving (Show, Eq) + +<>= +, Unknown (..) + +@ \subsection{Received messages} + +Messages received from a bus have additional fields which do not make sense +when sending. + +If a message has an unknown type, its serial and origin are still useful +for sending an error reply. + +<>= +data ReceivedMessage + = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall + | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn + | ReceivedError Serial (Maybe T.BusName) Error + | ReceivedSignal Serial (Maybe T.BusName) Signal + | ReceivedUnknown Serial (Maybe T.BusName) Unknown + deriving (Show, Eq) + +<>= +receivedSerial :: ReceivedMessage -> Serial +receivedSerial (ReceivedMethodCall s _ _) = s +receivedSerial (ReceivedMethodReturn s _ _) = s +receivedSerial (ReceivedError s _ _) = s +receivedSerial (ReceivedSignal s _ _) = s +receivedSerial (ReceivedUnknown s _ _) = s + +<>= +receivedSender :: ReceivedMessage -> Maybe T.BusName +receivedSender (ReceivedMethodCall _ s _) = s +receivedSender (ReceivedMethodReturn _ s _) = s +receivedSender (ReceivedError _ s _) = s +receivedSender (ReceivedSignal _ s _) = s +receivedSender (ReceivedUnknown _ s _) = s + +<>= +, ReceivedMessage (..) +, receivedSerial +, receivedSender + +@ +\section{Wire format} + +<>= +<> +<> +<> +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Wire (<>) where +<> +<> +import Control.Monad (when, unless) +import Data.Maybe (fromJust, listToMaybe, fromMaybe) +import Data.Word (Word8, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import Data.Typeable (Typeable) + +import qualified DBus.Types as T + +@ \subsection{Endianness} + +<>= +data Endianness = LittleEndian | BigEndian + deriving (Show, Eq) + +encodeEndianness :: Endianness -> Word8 +encodeEndianness LittleEndian = 108 +encodeEndianness BigEndian = 66 + +decodeEndianness :: Word8 -> Maybe Endianness +decodeEndianness 108 = Just LittleEndian +decodeEndianness 66 = Just BigEndian +decodeEndianness _ = Nothing + +<>= + Endianness (..) + +@ \subsection{Alignment} + +Every built-in type has an associated alignment. If a value of the given +type is marshaled, it must have {\sc nul} bytes inserted until it starts +on a byte index divisible by its alignment. + +<>= +alignment :: T.Type -> Word8 +<> + +padding :: Word64 -> Word8 -> Word64 +padding current count = required where + count' = fromIntegral count + missing = mod current count' + required = if missing > 0 + then count' - missing + else 0 + +<>= +, alignment + +@ \subsection{Marshaling} + +Marshaling is implemented using an error transformer over an internal +state. + +<>= +import qualified Control.Monad.State as ST +import qualified Control.Monad.Error as E +import qualified Data.ByteString.Lazy as L + +<>= +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +<>= +data MarshalState = MarshalState Endianness L.ByteString +newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a) + deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState) +type Marshal = MarshalM () + +@ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, +which will generate a {\tt ByteString} with the fully marshaled data. + +<>= +, MarshalM +, Marshal +, marshal +, runMarshal + +<>= +runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString +runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of + (Right _, MarshalState _ bytes) -> Right bytes + (Left x, _) -> Left x + where initialState = MarshalState e L.empty + +<>= +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 + <> + +@ TODO: describe these functions + +<>= +append :: L.ByteString -> Marshal +append bs = do + (MarshalState e bs') <- ST.get + ST.put $ MarshalState e (L.append bs' bs) + +<>= +pad :: Word8 -> Marshal +pad count = do + (MarshalState _ bytes) <- ST.get + let padding' = padding (fromIntegral . L.length $ bytes) count + append $ L.replicate (fromIntegral padding') 0 + +@ Most numeric values already have marshalers implemented in the +{\tt Data.Binary.Put} module; this function lets them be re-used easily. + +<>= +import qualified Data.Binary.Put as P + +<>= +marshalPut :: (a -> P.Put) -> a -> Marshal +marshalPut put x = do + let bytes = P.runPut $ put x + (MarshalState e _) <- ST.get + pad . fromIntegral . L.length $ bytes + append $ case e of + BigEndian -> bytes + LittleEndian -> L.reverse bytes + +@ \subsubsection{Errors} + +Marshaling can fail for four reasons: + +\begin{itemize} +\item The message exceeds the maximum message size of $2^{27}$ bytes. +\item An array in the message exceeds the maximum array size of $2^{26}$ bytes. +\item The body's signature is not valid (for example, more than 255 fields). +\item A variant's signature is not valid -- same causes as an invalid body + signature. +\end{itemize} + +<>= +data MarshalError + = MessageTooLong Word64 + | ArrayTooLong Word64 + | InvalidBodySignature Text + | InvalidVariantSignature Text + deriving (Eq, Typeable) + +instance Show MarshalError where + show (MessageTooLong x) = concat + ["Message too long (", show x, " bytes)."] + show (ArrayTooLong x) = concat + ["Array too long (", show x, " bytes)."] + show (InvalidBodySignature x) = concat + ["Invalid body signature: ", show x] + show (InvalidVariantSignature x) = concat + ["Invalid variant signature: ", show x] + +instance E.Error MarshalError + +<>= +, MarshalError (..) + +@ \subsection{Unmarshaling} + +Unmarshaling also uses an error transformer and internal state. + +<>= +, Unmarshal +, unmarshal +, runUnmarshal + +<>= +data UnmarshalState = UnmarshalState Endianness L.ByteString Word64 +newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a) + deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState) + +<>= +runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a +runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where + state = UnmarshalState e bytes 0 + +<>= +unmarshal :: T.Signature -> Unmarshal [T.Variant] +unmarshal = mapM unmarshalType . T.signatureTypes + +unmarshalType :: T.Type -> Unmarshal T.Variant +<> + +@ TODO: describe these functions + +<>= +consume :: Word64 -> Unmarshal L.ByteString +consume count = do + (UnmarshalState e bytes offset) <- ST.get + let bytes' = L.drop (fromIntegral offset) bytes + let x = L.take (fromIntegral count) bytes' + unless (L.length x == fromIntegral count) $ + E.throwError $ UnexpectedEOF offset + + ST.put $ UnmarshalState e bytes (offset + count) + return x + +<>= +skipPadding :: Word8 -> Unmarshal () +skipPadding count = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume $ padding offset count + unless (L.all (== 0) bytes) $ + E.throwError $ InvalidPadding offset + +<>= +skipTerminator :: Unmarshal () +skipTerminator = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume 1 + unless (L.all (== 0) bytes) $ + E.throwError $ MissingTerminator offset + +<>= +fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b +fromMaybeU label f x = case f x of + Just x' -> return x' + Nothing -> E.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' + +<>= +import qualified Data.Binary.Get as G + +<>= +unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a +unmarshalGet count be le = do + skipPadding count + (UnmarshalState e _ _) <- ST.get + bs <- consume . fromIntegral $ count + let get' = case e of + BigEndian -> be + LittleEndian -> le + return $ G.runGet get' bs + +unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a + -> Unmarshal T.Variant +unmarshalGet' count be le = fmap T.toVariant $ unmarshalGet count be le + +<>= +untilM :: Monad m => m Bool -> m a -> m [a] +untilM test comp = do + done <- test + if done + then return [] + else do + x <- comp + xs <- untilM test comp + return $ x:xs + +@ \subsubsection{Errors} + +Unmarshaling can fail for four reasons: + +\begin{itemize} +\item The message's declared protocol version is unsupported. +\item Unexpected {\sc eof}, when there are less bytes remaining than are + required. +\item An invalid byte sequence for a given value type. +\item Missing required header fields for the declared message type. +\item Non-zero bytes were found where padding was expected. +\item A string, signature, or object path was not {\sc null}-terminated. +\item An array's size didn't match the number of elements +\end{itemize} + +<>= +data UnmarshalError + = UnsupportedProtocolVersion Word8 + | UnexpectedEOF Word64 + | Invalid Text Text + | MissingHeaderField Text + | InvalidHeaderField Text T.Variant + | InvalidPadding Word64 + | MissingTerminator Word64 + | ArraySizeMismatch + deriving (Eq, Typeable) + +instance Show UnmarshalError where + show (UnsupportedProtocolVersion x) = concat + ["Unsupported protocol version: ", show x] + show (UnexpectedEOF pos) = concat + ["Unexpected EOF at position ", show pos] + show (Invalid label x) = TL.unpack $ TL.concat + ["Invalid ", label, ": ", x] + show (MissingHeaderField x) = concat + ["Required field " , show x , " is missing."] + show (InvalidHeaderField x got) = concat + [ "Invalid header field ", show x, ": ", show got] + show (InvalidPadding pos) = concat + ["Invalid padding at position ", show pos] + show (MissingTerminator pos) = concat + ["Missing NUL terminator at position ", show pos] + show ArraySizeMismatch = "Array size mismatch" + +instance E.Error UnmarshalError + +<>= +, UnmarshalError (..) + +@ \subsection{Numerics} + +Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte +integer will have a 4-byte alignment. + +<>= +alignment T.DBusByte = 1 +alignment T.DBusWord16 = 2 +alignment T.DBusWord32 = 4 +alignment T.DBusWord64 = 8 +alignment T.DBusInt16 = 2 +alignment T.DBusInt32 = 4 +alignment T.DBusInt64 = 8 +alignment T.DBusDouble = 8 + +@ Because {\tt Word32}s are often used for other types, there's +separate functions for handling them. + +<>= +marshalWord32 :: Word32 -> Marshal +marshalWord32 = marshalPut P.putWord32be + +unmarshalWord32 :: Unmarshal Word32 +unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le + +<>= +marshalType T.DBusByte = append $ L.singleton x +marshalType T.DBusWord16 = marshalPut P.putWord16be x +marshalType T.DBusWord32 = marshalPut P.putWord32be x +marshalType T.DBusWord64 = marshalPut P.putWord64be x +marshalType T.DBusInt16 = marshalPut P.putWord16be $ fromIntegral (x :: Int16) +marshalType T.DBusInt32 = marshalPut P.putWord32be $ fromIntegral (x :: Int32) +marshalType T.DBusInt64 = marshalPut P.putWord64be $ fromIntegral (x :: Int64) + +<>= +unmarshalType T.DBusByte = fmap (T.toVariant . L.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 + +unmarshalType T.DBusInt16 = do + x <- unmarshalGet 2 G.getWord16be G.getWord16le + return . T.toVariant $ (fromIntegral x :: Int16) + +unmarshalType T.DBusInt32 = do + x <- unmarshalGet 4 G.getWord32be G.getWord32le + return . T.toVariant $ (fromIntegral x :: Int32) + +unmarshalType T.DBusInt64 = do + x <- unmarshalGet 8 G.getWord64be G.getWord64le + return . T.toVariant $ (fromIntegral x :: Int64) + +@ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format. + +<>= +import qualified Data.Binary.IEEE754 as IEEE + +<>= +marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x + +<>= +unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le + +@ \subsection{Booleans} + +Booleans are marshaled as 4-byte unsigned integers containing either of +the values 0 or 1. Yes, really. + +<>= +alignment T.DBusBoolean = 4 + +<>= +marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 + +<>= +unmarshalType T.DBusBoolean = unmarshalWord32 >>= + fromMaybeU' "boolean" (\x -> case x of + 0 -> Just False + 1 -> Just True + _ -> Nothing) + +@ \subsection{Strings and object paths} + +Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed +with their length as an unsigned 32-bit integer. Their alignment is that of +their length. Object paths are marshaled just like strings, though additional +checks are required when unmarshaling. + +TODO: If the input is invalid, these {\sc utf8} functions will raise an +exception, rather than return an error value. Eventually they should be +wrapped with {\tt unsafePerformIO} and be tweaked to return a proper +{\tt Maybe} or {\tt Either}. + +<>= +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) + +<>= +marshalText :: Text -> Marshal +marshalText x = do + let bytes = encodeUtf8 x + marshalWord32 . fromIntegral . L.length $ bytes + append bytes + append (L.singleton 0) + +<>= +unmarshalText :: Unmarshal Text +unmarshalText = do + byteCount <- unmarshalWord32 + bytes <- consume . fromIntegral $ byteCount + skipTerminator + return . decodeUtf8 $ bytes + +<>= +alignment T.DBusString = 4 +alignment T.DBusObjectPath = 4 + +<>= +marshalType T.DBusString = marshalText x +marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x + +<>= +unmarshalType T.DBusString = fmap T.toVariant unmarshalText + +unmarshalType T.DBusObjectPath = unmarshalText >>= + fromMaybeU' "object path" T.mkObjectPath + +@ \subsection{Signatures} + +Signatures are similar to strings, except their length is limited to 255 +characters and is therefore stored as a single byte. + +<>= +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) + +<>= +unmarshalSignature :: Unmarshal T.Signature +unmarshalSignature = do + byteCount <- fmap L.head $ consume 1 + sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount + skipTerminator + fromMaybeU "signature" T.mkSignature sigText + +<>= +alignment T.DBusSignature = 1 + +<>= +marshalType T.DBusSignature = marshalSignature x + +<>= +unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature + +@ \subsection{Containers} + +@ \subsubsection{Arrays} + +<>= +alignment (T.DBusArray _) = 4 + +<>= +marshalType (T.DBusArray _) = marshalArray x + +<>= +unmarshalType (T.DBusArray t) = fmap T.toVariant $ unmarshalArray t + +@ Marshaling arrays is complicated, because the array body must be marshaled +\emph{first} to calculate the array length. This requires building a +temporary marshaler, to get the padding right. + +<>= +import qualified DBus.Constants as C + +<>= +marshalArray :: T.Array -> Marshal +marshalArray x = do + (arrayPadding, arrayBytes) <- getArrayBytes x + let arrayLen = L.length arrayBytes + when (arrayLen > fromIntegral C.arrayMaximumLength) + (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + marshalWord32 $ fromIntegral arrayLen + append arrayPadding + append arrayBytes + +<>= +getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString) +getArrayBytes x = do + let vs = T.arrayItems x + let itemType = T.arrayType x + s <- ST.get + (MarshalState _ afterLength) <- marshalWord32 0 >> ST.get + (MarshalState _ afterPadding) <- pad (alignment itemType) >> ST.get + (MarshalState _ afterItems) <- mapM_ marshal vs >> ST.get + + let paddingBytes = L.drop (L.length afterLength) afterPadding + let itemBytes = L.drop (L.length afterPadding) afterItems + + ST.put s + return (paddingBytes, itemBytes) + +@ Unmarshaling is much easier + +<>= +unmarshalArray :: T.Type -> Unmarshal T.Array +unmarshalArray itemType = do + let getOffset = do + (UnmarshalState _ _ o) <- ST.get + return o + byteCount <- unmarshalWord32 + skipPadding (alignment itemType) + start <- getOffset + let end = start + fromIntegral byteCount + vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + end' <- getOffset + when (end' > end) $ + E.throwError ArraySizeMismatch + fromMaybeU "array" (T.arrayFromItems itemType) vs + +@ \subsubsection{Dictionaries} + +<>= +alignment (T.DBusDictionary _ _) = 4 + +<>= +marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) + +<>= +unmarshalType (T.DBusDictionary kt vt) = do + let pairType = T.DBusStructure [kt, vt] + array <- unmarshalArray pairType + fromMaybeU' "dictionary" T.arrayToDictionary array + +@ \subsubsection{Structures} + +<>= +alignment (T.DBusStructure _) = 8 + +<>= +marshalType (T.DBusStructure _) = do + let T.Structure vs = x + pad 8 + mapM_ marshal vs + +<>= +unmarshalType (T.DBusStructure ts) = do + skipPadding 8 + fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + +@ \subsubsection{Variants} + +<>= +alignment T.DBusVariant = 1 + +<>= +marshalType T.DBusVariant = do + let rawSig = T.typeCode . T.variantType $ x + sig <- case T.mkSignature rawSig of + Just x' -> return x' + Nothing -> E.throwError $ InvalidVariantSignature rawSig + marshalSignature sig + marshal x + +<>= +unmarshalType T.DBusVariant = do + let getType sig = case T.signatureTypes sig of + [t] -> Just t + _ -> Nothing + + t <- fromMaybeU "variant signature" getType =<< unmarshalSignature + fmap T.toVariant $ unmarshalType t + +@ \subsection{Messages} + +<>= +import qualified DBus.Message.Internal as M + +@ \subsubsection{Flags} + +<>= +import Data.Bits ((.|.), (.&.)) +import qualified Data.Set as Set + +<>= +encodeFlags :: Set.Set M.Flag -> Word8 +encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where + flagValue M.NoReplyExpected = 0x1 + flagValue M.NoAutoStart = 0x2 + +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] + +@ \subsubsection{Header fields} + +<>= +encodeField :: M.HeaderField -> T.Structure +encodeField (M.Path x) = encodeField' 1 x +encodeField (M.Interface x) = encodeField' 2 x +encodeField (M.Member x) = encodeField' 3 x +encodeField (M.ErrorName x) = encodeField' 4 x +encodeField (M.ReplySerial x) = encodeField' 5 x +encodeField (M.Destination x) = encodeField' 6 x +encodeField (M.Sender x) = encodeField' 7 x +encodeField (M.Signature x) = encodeField' 8 x + +encodeField' :: T.Variable a => Word8 -> a -> T.Structure +encodeField' code x = T.Structure + [ T.toVariant code + , T.toVariant $ T.toVariant x + ] + +<>= +decodeField :: Monad m => T.Structure + -> E.ErrorT UnmarshalError m [M.HeaderField] +decodeField struct = case unpackField struct of + (1, x) -> decodeField' x M.Path "path" + (2, x) -> decodeField' x M.Interface "interface" + (3, x) -> decodeField' x M.Member "member" + (4, x) -> decodeField' x M.ErrorName "error name" + (5, x) -> decodeField' x M.ReplySerial "reply serial" + (6, x) -> decodeField' x M.Destination "destination" + (7, x) -> decodeField' x M.Sender "sender" + (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' x f label = case T.fromVariant x of + Just x' -> return [f x'] + Nothing -> E.throwError $ InvalidHeaderField label x + +<>= +unpackField :: T.Structure -> (Word8, T.Variant) +unpackField struct = (c', v') where + T.Structure [c, v] = struct + c' = fromJust . T.fromVariant $ c + v' = fromJust . T.fromVariant $ v + +@ \subsubsection{Header layout} + +TODO: describe header layout here + +@ \subsubsection{Marshaling} + +<>= +, marshalMessage + +<>= +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 <- ST.get + mapM_ marshal body + (MarshalState _ bodyBytes) <- ST.get + ST.put empty + marshalEndianness e + marshalHeader msg serial sig + $ fromIntegral . L.length $ bodyBytes + pad 8 + append bodyBytes + checkMaximumSize + +<>= +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 + Just x -> return x + Nothing -> invalid + +<>= +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 + marshalWord32 bodyLength + marshal . T.toVariant $ serial + let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] + marshal . T.toVariant . fromJust . T.toArray fieldType + $ map encodeField fields + +<>= +marshalEndianness :: Endianness -> Marshal +marshalEndianness = marshal . T.toVariant . encodeEndianness + +<>= +checkMaximumSize :: Marshal +checkMaximumSize = do + (MarshalState _ messageBytes) <- ST.get + let messageLength = L.length messageBytes + when (messageLength > fromIntegral C.messageMaximumLength) + (E.throwError $ MessageTooLong $ fromIntegral messageLength) + +@ \subsubsection{Unmarshaling} + +<>= +, unmarshalMessage + +<>= +unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) + -> m (Either UnmarshalError M.ReceivedMessage) +unmarshalMessage getBytes' = E.runErrorT $ do + let getBytes = E.lift . getBytes' + + <> + <> + <> + <> + +@ The first part of the header has a fixed size of 16 bytes, so it can be +retrieved without any size calculations. + +<>= +let fixedSig = T.mkSignature' "yyyyuuu" +fixedBytes <- getBytes 16 + +@ The first field of interest is the protocol version; if the incoming +message's version is different from this library, the message cannot be +parsed. + +<>= +let messageVersion = L.index fixedBytes 3 +when (messageVersion /= C.protocolVersion) $ + E.throwError $ UnsupportedProtocolVersion messageVersion + +@ Next is the endianness, used for parsing pretty much every other field. + +<>= +let eByte = L.index fixedBytes 0 +endianness <- case decodeEndianness eByte of + Just x' -> return x' + Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte + +@ With the endianness out of the way, the rest of the fixed header +can be decoded + +<>= +let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of + Right x' -> return x' + Left e -> E.throwError 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 + +@ The last field of the fixed header is actually part of the field array, +but is treated as a single {\tt Word32} so it'll be known how many bytes +to retrieve. + +<>= +let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 + +@ With the field byte count, the remainder of the header bytes can be +pulled out of the monad. + +<>= +let headerSig = T.mkSignature' "yyyyuua(yv)" +fieldBytes <- getBytes fieldByteCount +let headerBytes = L.append fixedBytes fieldBytes +header <- unmarshal' headerSig headerBytes + +@ And the header fields can be parsed. + +<>= +let fieldArray = fromJust . T.fromVariant $ header !! 6 +let fieldStructures = fromJust . T.fromArray $ fieldArray +fields <- fmap concat $ mapM decodeField fieldStructures + +@ The body is always aligned to 8 bytes, so pull out the padding before +unmarshaling it. + +<>= +let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 +getBytes . fromIntegral $ bodyPadding + +<>= +findBodySignature :: [M.HeaderField] -> T.Signature +findBodySignature fields = fromMaybe empty signature where + empty = T.mkSignature' "" + signature = listToMaybe [x | M.Signature x <- fields] + +<>= +let bodySig = findBodySignature fields + +@ Then pull the body bytes, and unmarshal it. + +<>= +bodyBytes <- getBytes bodyLength +body <- unmarshal' bodySig bodyBytes + +@ Even if the received message was structurally valid, building the +{\tt ReceivedMessage} can still fail due to missing header fields. + +<>= +y <- case buildReceivedMessage typeCode fields of + Right x -> return x + Left x -> E.throwError $ MissingHeaderField x + +<>= +return $ y serial flags body + +@ This really belongs in the Message section... + +<>= +buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text + (M.Serial -> (Set.Set M.Flag) -> [T.Variant] + -> M.ReceivedMessage) + +@ Method calls + +<>= +buildReceivedMessage 1 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + return $ \serial flags body -> let + iface = listToMaybe [x | M.Interface x <- fields] + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodCall path member iface dest flags body + in M.ReceivedMethodCall serial sender msg + +@ Method returns + +<>= +buildReceivedMessage 2 fields = do + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodReturn replySerial dest flags body + in M.ReceivedMethodReturn serial sender msg + +@ Errors + +<>= +buildReceivedMessage 3 fields = do + name <- require "error name" [x | M.ErrorName x <- fields] + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Error name replySerial dest flags body + in M.ReceivedError serial sender msg + +@ Signals + +<>= +buildReceivedMessage 4 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + iface <- require "interface" [x | M.Interface x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Signal path member iface dest flags body + in M.ReceivedSignal serial sender msg + +@ Unknown + +<>= +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] -> Either Text a +require _ (x:_) = Right x +require label _ = Left label + +@ This is just needed for the Monad instance of {\tt Either Text} + +<>= +instance E.Error Text where + strMsg = TL.pack + +@ +\section{Connections} + +<>= +<> +<> +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Connection + ( <> + ) where +<> +<> + +@ A {\tt Connection} is an opaque handle to an open DBus channel, with +an internal state for maintaining the current message serial. + +<>= +import qualified Control.Concurrent as C +import qualified DBus.Address as A +import qualified DBus.Message.Internal as M + +<>= +data Connection = Connection A.Address Transport (C.MVar M.Serial) + +<>= + Connection + +@ While not particularly useful for other functions, being able to +{\tt show} a {\tt Connection} is useful when debugging. + +<>= +instance Show Connection where + showsPrec d (Connection a _ _) = showParen (d > 10) $ + showString' [""] where + showString' = foldr (.) id . map showString + +@ \subsection{Transports} + +A transport is anything which can send and receive bytestrings, typically +over a socket. + +<>= +import qualified Data.ByteString.Lazy as L +import Data.Word (Word32) + +<>= +data Transport = Transport + { transportSend :: L.ByteString -> IO () + , transportRecv :: Word32 -> IO L.ByteString + } + +<>= +connectTransport :: A.Address -> IO Transport +connectTransport a = transport' (A.addressMethod a) a where + transport' "unix" = unix + transport' _ = unknownTransport + +@ \subsubsection{UNIX} + +The {\sc unix} transport accepts two parameters: {\tt path}, which is a +simple filesystem path, and {\tt abstract}, which is a path in the +Linux-specific abstract domain. One, and only one, of these parameters must +be specified. + +<>= +import qualified Network as N +import qualified Data.Map as Map + +<>= +unix :: A.Address -> IO Transport +unix a = handleTransport . N.connectTo "localhost" =<< port where + params = A.addressParameters a + path = Map.lookup "path" params + abstract = Map.lookup "abstract" params + + tooMany = "Only one of `path' or `abstract' may be specified for the\ + \ `unix' method." + tooFew = "One of `path' or `abstract' must be specified for the\ + \ `unix' transport." + + port = fmap N.UnixSocket path' + path' = case (path, abstract) of + (Just _, Just _) -> E.throwIO $ BadParameters a tooMany + (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew + (Just x, Nothing) -> return $ TL.unpack x + (Nothing, Just x) -> return $ '\x00' : TL.unpack x + +@ \subsubsection{TCP} + +known parameters: + +\begin{itemize} +\item {\tt host} (optional, default "{\tt localhost}") +\item {\tt port} +\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}" +\end{itemize} + +TCP support is TODO + +<>= +tcp :: A.Address -> IO Transport +tcp a@(A.Address _ params) = handleTransport a connect' where + host = lookup "host" params + port = parsePort =<< lookup "post" params + family = parseFamily =<< lookup "family" params + connect' = do + -- check host + -- check port + -- check family + -- return handle +parsePort :: String -> Maybe PortNumber + +parseFamily :: String -> Maybe Family + +@ \subsubsection{Generic handle-based transport} + +Both UNIX and TCP are backed by standard handles, and can therefore use +a shared handle-based transport backend. + +<>= +import qualified System.IO as I + +<>= +handleTransport :: IO I.Handle -> IO Transport +handleTransport io = do + h <- io + I.hSetBuffering h I.NoBuffering + I.hSetBinaryMode h True + return $ Transport (L.hPut h) (L.hGet h . fromIntegral) + +@ \subsubsection{Unknown transports} + +If a method has no known transport, attempting to connect using it will +just result in an exception. + +<>= +unknownTransport :: A.Address -> IO Transport +unknownTransport = E.throwIO . UnknownMethod + +@ \subsection{Errors} + +If connecting to DBus fails, a {\tt ConnectionError} will be thrown. +The constructor describes which exception occurred. + +<>= +import qualified Control.Exception as E +import Data.Typeable (Typeable) + +<>= +data ConnectionError + = InvalidAddress Text + | BadParameters A.Address Text + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) + +instance E.Exception ConnectionError + +<>= +, ConnectionError (..) +, W.MarshalError (..) +, W.UnmarshalError (..) + +@ \subsection{Establishing a connection} + +A connection can be opened to any valid address, though actually connecting +might fail due to external factors. + +<>= +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) + +<>= +connect :: A.Address -> IO Connection +connect a = do + t <- connectTransport a + let putS = transportSend t . encodeUtf8 . TL.pack + let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t + authenticate putS getS + serialMVar <- C.newMVar M.firstSerial + return $ Connection a t serialMVar + +<>= +, connect + +@ \subsection{Authentication} + +<>= +authenticate :: (String -> IO ()) -> (Word32 -> IO String) + -> IO () +authenticate put get = do + put "\x00" + +@ {\sc external} authentication is performed using the process's real user +ID, converted to a string, and then hex-encoded. + +<>= +import System.Posix.User (getRealUserID) +import Data.Char (ord) +import Text.Printf (printf) + +<>= + uid <- getRealUserID + let authToken = concatMap (printf "%02X" . ord) (show uid) + put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" + +@ If authentication was successful, the server responds with {\tt OK +}. The GUID is intended to enable connection sharing, which +is currently unimplemented, so it's ignored. + +<>= +import Data.List (isPrefixOf) + +<>= + response <- readUntil '\n' get + if "OK" `isPrefixOf` response + then put "BEGIN\r\n" + else do + putStrLn $ "response = " ++ show response + error "Server rejected authentication token." + +<>= +readUntil :: Monad m => Char -> (Word32 -> m String) -> m String +readUntil = readUntil' "" where + readUntil' xs c f = do + [x] <- f 1 + let xs' = xs ++ [x] + if x == c + then return xs' + else readUntil' xs' c f + +@ \subsection{Sending and receiving messages} + +Sending a message will increment the connection's internal serial state. +The second parameter is present to allow registration of a callback before +the message has actually been sent, which avoids race conditions in +multi-threaded clients. + +<>= +import qualified DBus.Wire as W + +<>= +send :: M.Message a => Connection -> (M.Serial -> IO b) -> a + -> IO (Either W.MarshalError b) +send (Connection _ t mvar) io msg = withSerial mvar $ \serial -> + case W.marshalMessage W.LittleEndian serial msg of + Right bytes -> do + x <- io serial + transportSend t bytes + return $ Right x + Left err -> return $ Left err + +<>= +, send + +<>= +withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a +withSerial m io = E.block $ do + s <- C.takeMVar m + let s' = M.nextSerial s + x <- E.unblock (io s) `E.onException` C.putMVar m s' + C.putMVar m s' + return x + +@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an +error is encountered while unmarshaling, an exception will be thrown. + +<>= +receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) +receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t + +<>= +, receive + +@ +\section{The central bus} + +<>= +<> +<> +module DBus.Bus + ( getSystemBus + , getSessionBus + , getStarterBus + , getFirstBus + , getBus + ) where +<> + +import qualified Control.Exception as E +import Control.Monad (when) +import Data.Maybe (fromJust, isNothing) +import qualified Data.Set as Set +import System.Environment (getEnv) + +import qualified DBus.Address as A +import qualified DBus.Connection as C +import DBus.Constants (dbusName, dbusPath, dbusInterface) +import qualified DBus.Message as M +import qualified DBus.Types as T +import DBus.Util (fromRight) + +@ Connecting to a message bus is a bit more involved than just connecting +over an app-to-app connection: the bus must be notified of the new client, +using a "hello message", before it will begin forwarding messages. + +<>= +getBus :: A.Address -> IO (C.Connection, T.BusName) +getBus addr = do + c <- C.connect addr + name <- sendHello c + return (c, name) + +@ Optionally, multiple addresses may be provided. The first successfully +connected bus will be returned. + +<>= +getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus as = getFirstBus' as as + +getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus' orig [] = E.throwIO $ C.NoWorkingAddress orig +getFirstBus' orig (a:as) = E.catch (getBus a) onError where + onError :: E.SomeException -> IO (C.Connection, T.BusName) + onError _ = getFirstBus' orig as + +@ \subsection{Default connections} + +Two default buses are defined, the ``system'' and ``session'' buses. The system +bus is global for the OS, while the session bus runs only for the duration +of the user's session. + +<>= +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 + +<>= +getSessionBus :: IO (C.Connection, T.BusName) +getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +<>= +getStarterBus :: IO (C.Connection, T.BusName) +getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" + +<>= +getBus' :: IO String -> IO (C.Connection, T.BusName) +getBus' io = do + addr <- fmap TL.pack io + case A.mkAddresses addr of + Just [x] -> getBus x + Just x -> getFirstBus x + _ -> E.throwIO $ C.InvalidAddress addr + +@ \subsection{Sending the ``hello'' message} + +<>= +hello :: M.MethodCall +hello = M.MethodCall dbusPath + (T.mkMemberName' "Hello") + (Just dbusInterface) + (Just dbusName) + Set.empty + [] + +<>= +sendHello :: C.Connection -> IO T.BusName +sendHello c = do + serial <- fromRight `fmap` C.send c return hello + reply <- waitForReply c serial + let name = case M.methodReturnBody reply of + (x:_) -> T.fromVariant x + _ -> Nothing + + when (isNothing name) $ + E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + + return . fromJust $ name + +<>= +waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn +waitForReply c serial = do + received <- C.receive c + msg <- case received of + Right x -> return x + Left err -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + case msg of + (M.ReceivedMethodReturn _ _ reply) -> + if M.methodReturnSerial reply == serial + then return reply + else waitForReply c serial + _ -> waitForReply c serial + +@ +\section{Addresses} + +<>= +<> +<> +module DBus.Address + ( Address + , addressMethod + , addressParameters + , mkAddresses + , strAddress + ) where +<> + +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 DBus.Util (hexToInt, eitherToMaybe) + +@ \subsection{Address syntax} + +A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...} +where the method may be empty and parameters are optional. An address's +parameter list, if present, may end with a comma. Addresses in environment +variables are separated by semicolons, and the full address list may end +in a semicolon. Multiple parameters may have the same key; in this case, +only the first parameter for each key will be stored. + +The bytes allowed in each component of the address are given by the following +chart, where each character is understood to be its ASCII value: + +\begin{table}[h] +\begin{center} +\begin{tabular}{ll} +\toprule +Component & Allowed Characters \\ +\midrule +Method & Any except {\tt `;'} and {\tt `:'} \\ +Param key & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\ +Param value & {\tt `0'} to {\tt `9'} \\ + & {\tt `a'} to {\tt `z'} \\ + & {\tt `A'} to {\tt `Z'} \\ + & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\ +\bottomrule +\end{tabular} +\end{center} +\end{table} + +In parameter values, any byte may be encoded by prepending the \% character +to its value in hexadecimal. \% is not allowed to appear unless it is +followed by two hexadecimal digits. Every other allowed byte is termed +an ``optionally encoded'' byte, and may appear unescaped in parameter +values. + +<>= +optionallyEncoded :: [Char] +optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + +@ +The address simply stores its method and parameter map, with a custom +{\tt Show} instance to provide easier debugging. + +<>= +data Address = Address + { addressMethod :: Text + , addressParameters :: M.Map Text Text + } deriving (Eq) + +instance Show Address where + showsPrec d x = showParen (d> 10) $ + showString "Address " . shows (strAddress x) + +@ +Parsing is straightforward; the input string is divided into addresses by +semicolons, then further by colons and commas. Parsing will fail if any +of the addresses in the input failed to parse. + +<>= +mkAddresses :: Text -> Maybe [Address] +mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where + address = do + method <- P.many (P.noneOf ":;") + P.char ':' + params <- P.sepEndBy param (P.char ',') + return $ Address (TL.pack method) (M.fromList params) + + param = do + key <- P.many1 (P.noneOf "=;,") + P.char '=' + value <- P.many1 (encodedValue <|> unencodedValue) + return (TL.pack key, TL.pack value) + + parser = do + as <- P.sepEndBy1 address (P.char ';') + P.eof + return as + + unencodedValue = P.oneOf optionallyEncoded + encodedValue = do + P.char '%' + hex <- P.count 2 P.hexDigit + return . chr . hexToInt $ hex + +@ +Converting an {\tt Address} back to a {\tt String} is just the reverse +operation. Note that because the original parameter order is not preserved, +the string produced might differ from the original input. + +<>= +strAddress :: Address -> Text +strAddress (Address t ps) = TL.concat [t, ":", ps'] where + ps' = TL.intercalate "," $ do + (k, v) <- M.toList ps + return $ TL.concat [k, "=", TL.concatMap encode v] + encode c | elem c optionallyEncoded = TL.singleton c + | otherwise = TL.pack $ printf "%%%02X" (ord c) + + +@ +\section{Introspection} + +@ DBus objects may be ``introspected'' to determine which methods, signals, +etc they support. Intospection data is sent over the bus in {\sc xml}, in +a mostly standardised but undocumented format. + +An XML introspection document looks like this: + +\begin{verbatim} + + + + + + + + + + + + + + + +\end{verbatim} + +<>= +<> +<> +module DBus.Introspection + ( Object (..) + , Interface (..) + , Method (..) + , Signal (..) + , Parameter (..) + , Property (..) + , PropertyAccess (..) + , toXML + , fromXML + ) where +<> +<> +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. + +<>= +import qualified Text.XML.HaXml as H + +@ \subsection{Data types} + +<>= +data Object = Object T.ObjectPath [Interface] [Object] + deriving (Show, Eq) + +data Interface = Interface T.InterfaceName [Method] [Signal] [Property] + deriving (Show, Eq) + +data Method = Method T.MemberName [Parameter] [Parameter] + deriving (Show, Eq) + +data Signal = Signal T.MemberName [Parameter] + deriving (Show, Eq) + +data Parameter = Parameter Text T.Signature + deriving (Show, Eq) + +data Property = Property Text T.Signature [PropertyAccess] + deriving (Show, Eq) + +data PropertyAccess = Read | Write + deriving (Show, Eq) + +@ \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. + +<>= +import Text.XML.HaXml.Parse (xmlParse') +import DBus.Util (eitherToMaybe) + +<>= +fromXML :: T.ObjectPath -> Text -> Maybe Object +fromXML path text = do + doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text + let (H.Document _ _ root _) = doc + parseRoot path root + +@ Even though the root object's {\tt name} is optional, if present, it must +still be a valid object path. + +<>= +parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object +parseRoot defaultPath e = do + path <- case getAttr "name" e of + Nothing -> Just defaultPath + Just x -> T.mkObjectPath x + parseObject' path e + +@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name} +attribute is not a valid object path, but should be valid when appended to +the root object's path. + +<>= +parseChild :: T.ObjectPath -> H.Element a -> Maybe Object +parseChild parentPath e = do + let parentPath' = case T.strObjectPath parentPath of + "/" -> "/" + x -> TL.append x "/" + pathSegment <- getAttr "name" e + path <- T.mkObjectPath $ TL.append parentPath' pathSegment + 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. + +<>= +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 + return $ Object path interfaces children' +parseObject' _ _ = Nothing + +@ Interfaces may contain methods, signals, and properties. + +<>= +parseInterface :: H.Element a -> 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 + return $ Interface name methods signals properties + +@ Methods contain a list of parameters, which default to ``in'' parameters +if no direction is specified. + +<>= +parseMethod :: H.Element a -> Maybe Method +parseMethod e = do + name <- T.mkMemberName =<< getAttr "name" e + paramsIn <- children parseParameter (isParam ["in", ""]) e + paramsOut <- children parseParameter (isParam ["out"]) e + return $ Method name paramsIn paramsOut + +@ Signals are similar to methods, except they have no ``in'' parameters. + +<>= +parseSignal :: H.Element a -> Maybe Signal +parseSignal e = do + name <- T.mkMemberName =<< getAttr "name" e + params <- children parseParameter (isParam ["out", ""]) e + return $ Signal name params + +@ A parameter has a free-form name, and a single valid type. + +<>= +parseParameter :: H.Element a -> Maybe Parameter +parseParameter e = do + let name = getAttr' "name" e + sig <- parseType e + return $ Parameter name sig + +<>= +parseType :: H.Element a -> Maybe T.Signature +parseType e = do + sig <- T.mkSignature =<< getAttr "type" e + case T.signatureTypes sig of + [_] -> Just sig + _ -> Nothing + +@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface. +Each property may be read, written, or both, and has an associated type. + +<>= +parseProperty :: H.Element a -> Maybe Property +parseProperty e = do + let name = getAttr' "name" e + sig <- parseType e + access <- case getAttr' "access" e of + "" -> Just [] + "read" -> Just [Read] + "write" -> Just [Write] + "readwrite" -> Just [Read, Write] + _ -> Nothing + 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. + +<>= +import Data.Char (chr) + +<>= +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 + +<>= +import Data.Maybe (fromMaybe) + +<>= +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 + +<>= +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] + +<>= +children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] +children f filt (H.Elem _ _ contents) = do + mapM f [x | (H.CElem x _) <- concatMap filt contents] + +@ \subsection{Generating XML} + +<>= +dtdPublicID, dtdSystemID :: String +dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" +dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" + +@ HaXml punts to the {\tt pretty} package for serialising XML. + +<>= +import Text.XML.HaXml.Pretty (document) +import Text.PrettyPrint.HughesPJ (render) + +@ Generating XML can fail; if a child object's path is not a sub-path of the +parent, {\tt toXML} will return {\tt Nothing}. + +<>= +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 [] + +@ When writing objects to {\tt node}s, the root object must have an absolute +path, and children must have paths relative to their parent. + +<>= +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' + 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 = read ++ write where + read = if elem Read access then "read" else "" + write = 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] + +@ +\section{Constants} + +<>= +<> +{-# LANGUAGE OverloadedStrings #-} +module DBus.Constants where +import qualified DBus.Types as T +import Data.Word (Word8, Word32) + +<>= +protocolVersion :: Word8 +protocolVersion = 1 + +messageMaximumLength :: Word32 +messageMaximumLength = 134217728 + +arrayMaximumLength :: Word32 +arrayMaximumLength = 67108864 + +@ \subsection{The message bus} + +<>= +dbusName :: T.BusName +dbusName = T.mkBusName' "org.freedesktop.DBus" + +dbusPath :: T.ObjectPath +dbusPath = T.mkObjectPath' "/org/freedesktop/DBus" + +dbusInterface :: T.InterfaceName +dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus" + +@ \subsection{Pre-defined interfaces} + +<>= +interfaceIntrospectable :: T.InterfaceName +interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" + +interfaceProperties :: T.InterfaceName +interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties" + +interfacePeer :: T.InterfaceName +interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer" + +@ \subsection{Pre-defined error names} + +<>= +errorFailed :: T.ErrorName +errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed" + +errorNoMemory :: T.ErrorName +errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory" + +errorServiceUnknown :: T.ErrorName +errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown" + +errorNameHasNoOwner :: T.ErrorName +errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner" + +errorNoReply :: T.ErrorName +errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply" + +errorIOError :: T.ErrorName +errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError" + +errorBadAddress :: T.ErrorName +errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress" + +errorNotSupported :: T.ErrorName +errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported" + +errorLimitsExceeded :: T.ErrorName +errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded" + +errorAccessDenied :: T.ErrorName +errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied" + +errorAuthFailed :: T.ErrorName +errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed" + +errorNoServer :: T.ErrorName +errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer" + +errorTimeout :: T.ErrorName +errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout" + +errorNoNetwork :: T.ErrorName +errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork" + +errorAddressInUse :: T.ErrorName +errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse" + +errorDisconnected :: T.ErrorName +errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected" + +errorInvalidArgs :: T.ErrorName +errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs" + +errorFileNotFound :: T.ErrorName +errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound" + +errorFileExists :: T.ErrorName +errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists" + +errorUnknownMethod :: T.ErrorName +errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod" + +errorTimedOut :: T.ErrorName +errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut" + +errorMatchRuleNotFound :: T.ErrorName +errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound" + +errorMatchRuleInvalid :: T.ErrorName +errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid" + +errorSpawnExecFailed :: T.ErrorName +errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed" + +errorSpawnForkFailed :: T.ErrorName +errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed" + +errorSpawnChildExited :: T.ErrorName +errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited" + +errorSpawnChildSignaled :: T.ErrorName +errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled" + +errorSpawnFailed :: T.ErrorName +errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed" + +errorSpawnFailedToSetup :: T.ErrorName +errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup" + +errorSpawnConfigInvalid :: T.ErrorName +errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" + +errorSpawnServiceNotValid :: T.ErrorName +errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" + +errorSpawnServiceNotFound :: T.ErrorName +errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" + +errorSpawnPermissionsInvalid :: T.ErrorName +errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" + +errorSpawnFileInvalid :: T.ErrorName +errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid" + +errorSpawnNoMemory :: T.ErrorName +errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory" + +errorUnixProcessIdUnknown :: T.ErrorName +errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown" + +errorInvalidFileContent :: T.ErrorName +errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent" + +errorSELinuxSecurityContextUnknown :: T.ErrorName +errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" + +errorAdtAuditDataUnknown :: T.ErrorName +errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown" + +errorObjectPathInUse :: T.ErrorName +errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse" + +errorInconsistentMessage :: T.ErrorName +errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage" + +@ +\section{Misc. utility functions} + +<>= +<> +module DBus.Util where +import Text.Parsec (Parsec, parse) +import Data.Char (digitToInt) + +checkLength :: Int -> String -> Maybe String +checkLength length' s | length s <= length' = Just s +checkLength _ _ = Nothing + +parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe p = either (const Nothing) Just . parse p "" + +mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b +mkUnsafe label f x = case f x of + Just x' -> x' + Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x + +hexToInt :: String -> Int +hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "DBus.Util.fromRight: Left" + +@ \end{document} diff --git a/dbus-core.tex b/dbus-core.tex deleted file mode 100644 --- a/dbus-core.tex +++ /dev/null @@ -1,60 +0,0 @@ -\documentclass[12pt]{article} - -\usepackage{color} -\usepackage{hyperref} -\usepackage{textcomp} -\usepackage{booktabs} -\usepackage{multirow} - -% Smaller margins -\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} - -% Remove boxes from hyperlinks -\hypersetup{ - colorlinks, - linkcolor=blue, -} - -\usepackage{listings} -\lstnewenvironment{code}{ - \lstset - {language=Haskell - ,basicstyle=\footnotesize\tt - ,showstringspaces=false - ,frame=single - ,upquote=true - }} - {} - -% http://hackage.haskell.org/trac/ghc/ticket/3549 -\lstnewenvironment{otherCode}{ - \lstset - {language=Haskell - ,basicstyle=\footnotesize\tt - ,showstringspaces=false - ,frame=single - ,upquote=true - }} - {} - -\long\def\ignore#1{} - -\makeindex - -\begin{document} - -\addcontentsline{toc}{section}{Contents} -\tableofcontents - -\input{DBus/Address.lhs} -\input{DBus/Connection.lhs} -\input{DBus/Bus.lhs} -\input{DBus/Internal/Authentication.lhs} -\input{DBus/Types.lhs} -\input{DBus/Message.lhs} -\input{DBus/Internal/Marshal.lhs} -\input{DBus/Internal/Unmarshal.lhs} -\input{DBus/Internal/Padding.lhs} -\input{DBus/Util.lhs} - -\end{document} diff --git a/hs/DBus/Address.hs b/hs/DBus/Address.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Address.hs @@ -0,0 +1,83 @@ +{- + Copyright (C) 2009 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 #-} + +module DBus.Address + ( Address + , addressMethod + , addressParameters + , mkAddresses + , strAddress + ) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + + +import Data.Char (ord, chr) +import qualified Data.Map as M +import Text.Printf (printf) +import qualified Text.Parsec as P +import Text.Parsec ((<|>)) +import DBus.Util (hexToInt, eitherToMaybe) + +optionallyEncoded :: [Char] +optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + +data Address = Address + { addressMethod :: Text + , addressParameters :: M.Map Text Text + } deriving (Eq) + +instance Show Address where + showsPrec d x = showParen (d> 10) $ + showString "Address " . shows (strAddress x) + +mkAddresses :: Text -> Maybe [Address] +mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where + address = do + method <- P.many (P.noneOf ":;") + P.char ':' + params <- P.sepEndBy param (P.char ',') + return $ Address (TL.pack method) (M.fromList params) + + param = do + key <- P.many1 (P.noneOf "=;,") + P.char '=' + value <- P.many1 (encodedValue <|> unencodedValue) + return (TL.pack key, TL.pack value) + + parser = do + as <- P.sepEndBy1 address (P.char ';') + P.eof + return as + + unencodedValue = P.oneOf optionallyEncoded + encodedValue = do + P.char '%' + hex <- P.count 2 P.hexDigit + return . chr . hexToInt $ hex + +strAddress :: Address -> Text +strAddress (Address t ps) = TL.concat [t, ":", ps'] where + ps' = TL.intercalate "," $ do + (k, v) <- M.toList ps + return $ TL.concat [k, "=", TL.concatMap encode v] + encode c | elem c optionallyEncoded = TL.singleton c + | otherwise = TL.pack $ printf "%%%02X" (ord c) + + diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Bus.hs @@ -0,0 +1,112 @@ +{- + Copyright (C) 2009 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 #-} + +module DBus.Bus + ( getSystemBus + , getSessionBus + , getStarterBus + , getFirstBus + , getBus + ) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + + +import qualified Control.Exception as E +import Control.Monad (when) +import Data.Maybe (fromJust, isNothing) +import qualified Data.Set as Set +import System.Environment (getEnv) + +import qualified DBus.Address as A +import qualified DBus.Connection as C +import DBus.Constants (dbusName, dbusPath, dbusInterface) +import qualified DBus.Message as M +import qualified DBus.Types as T +import DBus.Util (fromRight) + +getBus :: A.Address -> IO (C.Connection, T.BusName) +getBus addr = do + c <- C.connect addr + name <- sendHello c + return (c, name) + +getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus as = getFirstBus' as as + +getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus' orig [] = E.throwIO $ C.NoWorkingAddress orig +getFirstBus' orig (a:as) = E.catch (getBus a) onError where + onError :: E.SomeException -> IO (C.Connection, T.BusName) + onError _ = getFirstBus' orig as + +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 + +getSessionBus :: IO (C.Connection, T.BusName) +getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +getStarterBus :: IO (C.Connection, T.BusName) +getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" + +getBus' :: IO String -> IO (C.Connection, T.BusName) +getBus' io = do + addr <- fmap TL.pack io + case A.mkAddresses addr of + Just [x] -> getBus x + Just x -> getFirstBus x + _ -> E.throwIO $ C.InvalidAddress addr + +hello :: M.MethodCall +hello = M.MethodCall dbusPath + (T.mkMemberName' "Hello") + (Just dbusInterface) + (Just dbusName) + Set.empty + [] + +sendHello :: C.Connection -> IO T.BusName +sendHello c = do + serial <- fromRight `fmap` C.send c return hello + reply <- waitForReply c serial + let name = case M.methodReturnBody reply of + (x:_) -> T.fromVariant x + _ -> Nothing + + when (isNothing name) $ + E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + + return . fromJust $ name + +waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn +waitForReply c serial = do + received <- C.receive c + msg <- case received of + Right x -> return x + Left err -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + case msg of + (M.ReceivedMethodReturn _ _ reply) -> + if M.methodReturnSerial reply == serial + then return reply + else waitForReply c serial + _ -> waitForReply c serial + diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Connection.hs @@ -0,0 +1,172 @@ +{- + Copyright (C) 2009 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 DeriveDataTypeable #-} +module DBus.Connection + ( Connection + + , ConnectionError (..) + , W.MarshalError (..) + , W.UnmarshalError (..) + + , connect + + , send + + , receive + + ) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import qualified Control.Concurrent as C +import qualified DBus.Address as A +import qualified DBus.Message.Internal as M + +import qualified Data.ByteString.Lazy as L +import Data.Word (Word32) + +import qualified Network as N +import qualified Data.Map as Map + +import qualified System.IO as I + +import qualified Control.Exception as E +import Data.Typeable (Typeable) + +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) + +import System.Posix.User (getRealUserID) +import Data.Char (ord) +import Text.Printf (printf) + +import Data.List (isPrefixOf) + +import qualified DBus.Wire as W + + +data Connection = Connection A.Address Transport (C.MVar M.Serial) + +instance Show Connection where + showsPrec d (Connection a _ _) = showParen (d > 10) $ + showString' [""] where + showString' = foldr (.) id . map showString + +data Transport = Transport + { transportSend :: L.ByteString -> IO () + , transportRecv :: Word32 -> IO L.ByteString + } + +connectTransport :: A.Address -> IO Transport +connectTransport a = transport' (A.addressMethod a) a where + transport' "unix" = unix + transport' _ = unknownTransport + +unix :: A.Address -> IO Transport +unix a = handleTransport . N.connectTo "localhost" =<< port where + params = A.addressParameters a + path = Map.lookup "path" params + abstract = Map.lookup "abstract" params + + tooMany = "Only one of `path' or `abstract' may be specified for the\ + \ `unix' method." + tooFew = "One of `path' or `abstract' must be specified for the\ + \ `unix' transport." + + port = fmap N.UnixSocket path' + path' = case (path, abstract) of + (Just _, Just _) -> E.throwIO $ BadParameters a tooMany + (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew + (Just x, Nothing) -> return $ TL.unpack x + (Nothing, Just x) -> return $ '\x00' : TL.unpack x + +handleTransport :: IO I.Handle -> IO Transport +handleTransport io = do + h <- io + I.hSetBuffering h I.NoBuffering + I.hSetBinaryMode h True + return $ Transport (L.hPut h) (L.hGet h . fromIntegral) + +unknownTransport :: A.Address -> IO Transport +unknownTransport = E.throwIO . UnknownMethod + +data ConnectionError + = InvalidAddress Text + | BadParameters A.Address Text + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) + +instance E.Exception ConnectionError + +connect :: A.Address -> IO Connection +connect a = do + t <- connectTransport a + let putS = transportSend t . encodeUtf8 . TL.pack + let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t + authenticate putS getS + serialMVar <- C.newMVar M.firstSerial + return $ Connection a t serialMVar + +authenticate :: (String -> IO ()) -> (Word32 -> IO String) + -> IO () +authenticate put get = do + put "\x00" + + uid <- getRealUserID + let authToken = concatMap (printf "%02X" . ord) (show uid) + put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" + + response <- readUntil '\n' get + if "OK" `isPrefixOf` response + then put "BEGIN\r\n" + else do + putStrLn $ "response = " ++ show response + error "Server rejected authentication token." + +readUntil :: Monad m => Char -> (Word32 -> m String) -> m String +readUntil = readUntil' "" where + readUntil' xs c f = do + [x] <- f 1 + let xs' = xs ++ [x] + if x == c + then return xs' + else readUntil' xs' c f + +send :: M.Message a => Connection -> (M.Serial -> IO b) -> a + -> IO (Either W.MarshalError b) +send (Connection _ t mvar) io msg = withSerial mvar $ \serial -> + case W.marshalMessage W.LittleEndian serial msg of + Right bytes -> do + x <- io serial + transportSend t bytes + return $ Right x + Left err -> return $ Left err + +withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a +withSerial m io = E.block $ do + s <- C.takeMVar m + let s' = M.nextSerial s + x <- E.unblock (io s) `E.onException` C.putMVar m s' + C.putMVar m s' + return x + +receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) +receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t + diff --git a/hs/DBus/Constants.hs b/hs/DBus/Constants.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Constants.hs @@ -0,0 +1,172 @@ +{- + Copyright (C) 2009 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 #-} +module DBus.Constants where +import qualified DBus.Types as T +import Data.Word (Word8, Word32) + +protocolVersion :: Word8 +protocolVersion = 1 + +messageMaximumLength :: Word32 +messageMaximumLength = 134217728 + +arrayMaximumLength :: Word32 +arrayMaximumLength = 67108864 + +dbusName :: T.BusName +dbusName = T.mkBusName' "org.freedesktop.DBus" + +dbusPath :: T.ObjectPath +dbusPath = T.mkObjectPath' "/org/freedesktop/DBus" + +dbusInterface :: T.InterfaceName +dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus" + +interfaceIntrospectable :: T.InterfaceName +interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" + +interfaceProperties :: T.InterfaceName +interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties" + +interfacePeer :: T.InterfaceName +interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer" + +errorFailed :: T.ErrorName +errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed" + +errorNoMemory :: T.ErrorName +errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory" + +errorServiceUnknown :: T.ErrorName +errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown" + +errorNameHasNoOwner :: T.ErrorName +errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner" + +errorNoReply :: T.ErrorName +errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply" + +errorIOError :: T.ErrorName +errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError" + +errorBadAddress :: T.ErrorName +errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress" + +errorNotSupported :: T.ErrorName +errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported" + +errorLimitsExceeded :: T.ErrorName +errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded" + +errorAccessDenied :: T.ErrorName +errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied" + +errorAuthFailed :: T.ErrorName +errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed" + +errorNoServer :: T.ErrorName +errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer" + +errorTimeout :: T.ErrorName +errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout" + +errorNoNetwork :: T.ErrorName +errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork" + +errorAddressInUse :: T.ErrorName +errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse" + +errorDisconnected :: T.ErrorName +errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected" + +errorInvalidArgs :: T.ErrorName +errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs" + +errorFileNotFound :: T.ErrorName +errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound" + +errorFileExists :: T.ErrorName +errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists" + +errorUnknownMethod :: T.ErrorName +errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod" + +errorTimedOut :: T.ErrorName +errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut" + +errorMatchRuleNotFound :: T.ErrorName +errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound" + +errorMatchRuleInvalid :: T.ErrorName +errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid" + +errorSpawnExecFailed :: T.ErrorName +errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed" + +errorSpawnForkFailed :: T.ErrorName +errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed" + +errorSpawnChildExited :: T.ErrorName +errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited" + +errorSpawnChildSignaled :: T.ErrorName +errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled" + +errorSpawnFailed :: T.ErrorName +errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed" + +errorSpawnFailedToSetup :: T.ErrorName +errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup" + +errorSpawnConfigInvalid :: T.ErrorName +errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" + +errorSpawnServiceNotValid :: T.ErrorName +errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" + +errorSpawnServiceNotFound :: T.ErrorName +errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" + +errorSpawnPermissionsInvalid :: T.ErrorName +errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" + +errorSpawnFileInvalid :: T.ErrorName +errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid" + +errorSpawnNoMemory :: T.ErrorName +errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory" + +errorUnixProcessIdUnknown :: T.ErrorName +errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown" + +errorInvalidFileContent :: T.ErrorName +errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent" + +errorSELinuxSecurityContextUnknown :: T.ErrorName +errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" + +errorAdtAuditDataUnknown :: T.ErrorName +errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown" + +errorObjectPathInUse :: T.ErrorName +errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse" + +errorInconsistentMessage :: T.ErrorName +errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage" + diff --git a/hs/DBus/Introspection.hs b/hs/DBus/Introspection.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Introspection.hs @@ -0,0 +1,265 @@ +{- + Copyright (C) 2009 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 #-} + +module DBus.Introspection + ( Object (..) + , Interface (..) + , Method (..) + , Signal (..) + , Parameter (..) + , Property (..) + , PropertyAccess (..) + , toXML + , fromXML + ) where +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) + +import qualified DBus.Types as T + +data Object = Object T.ObjectPath [Interface] [Object] + deriving (Show, Eq) + +data Interface = Interface T.InterfaceName [Method] [Signal] [Property] + deriving (Show, Eq) + +data Method = Method T.MemberName [Parameter] [Parameter] + deriving (Show, Eq) + +data Signal = Signal T.MemberName [Parameter] + deriving (Show, Eq) + +data Parameter = Parameter Text T.Signature + deriving (Show, Eq) + +data Property = Property Text T.Signature [PropertyAccess] + deriving (Show, Eq) + +data PropertyAccess = Read | Write + deriving (Show, Eq) + +fromXML :: T.ObjectPath -> Text -> Maybe Object +fromXML path text = do + doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text + let (H.Document _ _ root _) = doc + parseRoot path root + +parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object +parseRoot defaultPath e = do + path <- case getAttr "name" e of + Nothing -> Just defaultPath + Just x -> T.mkObjectPath x + parseObject' path e + +parseChild :: T.ObjectPath -> H.Element a -> Maybe Object +parseChild parentPath e = do + let parentPath' = case T.strObjectPath parentPath of + "/" -> "/" + x -> TL.append x "/" + pathSegment <- getAttr "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 + return $ Object path interfaces children' +parseObject' _ _ = Nothing + +parseInterface :: H.Element a -> 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 + return $ Interface name methods signals properties + +parseMethod :: H.Element a -> Maybe Method +parseMethod e = do + name <- T.mkMemberName =<< getAttr "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 +parseSignal e = do + name <- T.mkMemberName =<< getAttr "name" e + params <- children parseParameter (isParam ["out", ""]) e + return $ Signal name params + +parseParameter :: H.Element a -> Maybe Parameter +parseParameter e = do + let name = getAttr' "name" e + sig <- parseType e + return $ Parameter name sig + +parseType :: H.Element a -> Maybe T.Signature +parseType e = do + sig <- T.mkSignature =<< getAttr "type" e + case T.signatureTypes sig of + [_] -> Just sig + _ -> Nothing + +parseProperty :: H.Element a -> Maybe Property +parseProperty e = do + let name = getAttr' "name" e + sig <- parseType e + 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 + +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] + +children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] +children f filt (H.Elem _ _ contents) = do + 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" + +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' + 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 = read ++ write where + read = if elem Read access then "read" else "" + write = 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] + diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Message.hs @@ -0,0 +1,44 @@ +{- + Copyright (C) 2009 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 . +-} + +module DBus.Message + (Message ( messageFlags + , messageBody + ) + + , Flag (..) + + , Serial + , serialValue + + , MethodCall (..) + + , MethodReturn (..) + + , Error (..) + + , Signal (..) + + , Unknown (..) + + , ReceivedMessage (..) + , receivedSerial + , receivedSender + + ) where +import DBus.Message.Internal + diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Message/Internal.hs @@ -0,0 +1,174 @@ +{- + Copyright (C) 2009 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 . +-} + +module DBus.Message.Internal where +import qualified Data.Set as S +import Data.Word (Word8, Word32) +import qualified DBus.Types as T + +class Message a where + messageTypeCode :: a -> Word8 + messageHeaderFields :: a -> [HeaderField] + messageFlags :: a -> S.Set Flag + messageBody :: a -> [T.Variant] + +data Flag + = NoReplyExpected + | NoAutoStart + deriving (Show, Eq, Ord) + +data HeaderField + = Path T.ObjectPath + | Interface T.InterfaceName + | Member T.MemberName + | ErrorName T.ErrorName + | ReplySerial Serial + | Destination T.BusName + | Sender T.BusName + | Signature T.Signature + deriving (Show, Eq) + +newtype Serial = Serial { serialValue :: Word32 } + deriving (Eq, Ord) + +instance Show Serial where + show (Serial x) = show x + +instance T.Variable Serial where + toVariant (Serial x) = T.toVariant x + fromVariant = fmap Serial . T.fromVariant + +firstSerial :: Serial +firstSerial = Serial 1 + +nextSerial :: Serial -> Serial +nextSerial (Serial x) = Serial (x + 1) + +maybe' :: (a -> b) -> Maybe a -> [b] +maybe' f = maybe [] (\x' -> [f x']) + +data MethodCall = MethodCall + { methodCallPath :: T.ObjectPath + , methodCallMember :: T.MemberName + , methodCallInterface :: Maybe T.InterfaceName + , methodCallDestination :: Maybe T.BusName + , methodCallFlags :: S.Set Flag + , methodCallBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodCall where + messageTypeCode _ = 1 + messageFlags = methodCallFlags + messageBody = methodCallBody + messageHeaderFields m = concat + [ [ Path $ methodCallPath m + , Member $ methodCallMember m + ] + , maybe' Interface . methodCallInterface $ m + , maybe' Destination . methodCallDestination $ m + ] + +data MethodReturn = MethodReturn + { methodReturnSerial :: Serial + , methodReturnDestination :: Maybe T.BusName + , methodReturnFlags :: S.Set Flag + , methodReturnBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodReturn where + messageTypeCode _ = 2 + messageFlags = methodReturnFlags + messageBody = methodReturnBody + messageHeaderFields m = concat + [ [ ReplySerial $ methodReturnSerial m + ] + , maybe' Destination . methodReturnDestination $ m + ] + +data Error = Error + { errorName :: T.ErrorName + , errorSerial :: Serial + , errorDestination :: Maybe T.BusName + , errorFlags :: S.Set Flag + , errorBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Error where + messageTypeCode _ = 3 + messageFlags = errorFlags + messageBody = errorBody + messageHeaderFields m = concat + [ [ ErrorName $ errorName m + , ReplySerial $ errorSerial m + ] + , maybe' Destination . errorDestination $ m + ] + +data Signal = Signal + { signalPath :: T.ObjectPath + , signalMember :: T.MemberName + , signalInterface :: T.InterfaceName + , signalDestination :: Maybe T.BusName + , signalFlags :: S.Set Flag + , signalBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Signal where + messageTypeCode _ = 4 + messageFlags = signalFlags + messageBody = signalBody + messageHeaderFields m = concat + [ [ Path $ signalPath m + , Member $ signalMember m + , Interface $ signalInterface m + ] + , maybe' Destination . signalDestination $ m + ] + +data Unknown = Unknown + { unknownType :: Word8 + , unknownFlags :: S.Set Flag + , unknownBody :: [T.Variant] + } + deriving (Show, Eq) + +data ReceivedMessage + = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall + | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn + | ReceivedError Serial (Maybe T.BusName) Error + | ReceivedSignal Serial (Maybe T.BusName) Signal + | ReceivedUnknown Serial (Maybe T.BusName) Unknown + deriving (Show, Eq) + +receivedSerial :: ReceivedMessage -> Serial +receivedSerial (ReceivedMethodCall s _ _) = s +receivedSerial (ReceivedMethodReturn s _ _) = s +receivedSerial (ReceivedError s _ _) = s +receivedSerial (ReceivedSignal s _ _) = s +receivedSerial (ReceivedUnknown s _ _) = s + +receivedSender :: ReceivedMessage -> Maybe T.BusName +receivedSender (ReceivedMethodCall _ s _) = s +receivedSender (ReceivedMethodReturn _ s _) = s +receivedSender (ReceivedError _ s _) = s +receivedSender (ReceivedSignal _ s _) = s +receivedSender (ReceivedUnknown _ s _) = s + 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,462 @@ +{- + Copyright (C) 2009 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 DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +{-# 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 + + -- * 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.Typeable (Typeable, cast) + +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import qualified Data.Text as T + +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import DBus.Util (checkLength, parseMaybe) + +import DBus.Util (mkUnsafe) + +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) + +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 + +typeCode :: Type -> Text + +class (Show a, Eq a) => Builtin a where + builtinDBusType :: a -> Type + +data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a + deriving (Typeable) + +class Variable a where + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a + +instance Show Variant where + showsPrec d (Variant x) = showParen (d > 10) $ + s "Variant " . shows code . s " " . showsPrec 11 x + where code = typeCode . builtinDBusType $ x + s = showString + +instance Eq Variant where + (Variant x) == (Variant y) = cast x == Just y + +variantType :: Variant -> Type +variantType (Variant x) = builtinDBusType x + + + + + + + + + + + + + + +instance Builtin Variant where { builtinDBusType _ = DBusVariant }; instance Variable Variant where { toVariant = Variant ; fromVariant (Variant x) = cast x }; + +instance Builtin Bool where { builtinDBusType _ = DBusBoolean }; instance Variable Bool where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Word8 where { builtinDBusType _ = DBusByte }; instance Variable Word8 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Int16 where { builtinDBusType _ = DBusInt16 }; instance Variable Int16 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Int32 where { builtinDBusType _ = DBusInt32 }; instance Variable Int32 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Int64 where { builtinDBusType _ = DBusInt64 }; instance Variable Int64 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Word16 where { builtinDBusType _ = DBusWord16 }; instance Variable Word16 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Word32 where { builtinDBusType _ = DBusWord32 }; instance Variable Word32 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Word64 where { builtinDBusType _ = DBusWord64 }; instance Variable Word64 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +instance Builtin Double where { builtinDBusType _ = DBusDouble }; instance Variable Double where { toVariant = Variant ; fromVariant (Variant x) = cast x }; + +instance Builtin TL.Text where { builtinDBusType _ = DBusString }; instance Variable TL.Text where { toVariant = Variant ; fromVariant (Variant x) = cast x }; + +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 Builtin Signature where { builtinDBusType _ = DBusSignature }; instance Variable Signature where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +data Signature = Signature { signatureTypes :: [Type] } + deriving (Eq, Typeable) + +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 x y = compare (strSignature x) (strSignature y) + +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 ++ [")"] + +mkSignature :: Text -> Maybe Signature +mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where + sigParser = do + types <- P.many parseType + P.eof + return $ Signature types + parseType = parseAtom <|> parseContainer + parseContainer = + parseArray + <|> parseStruct + <|> (P.char 'v' >> return DBusVariant) + 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) + parseArray = do + P.char 'a' + parseDict <|> do + t <- parseType + return $ DBusArray t + 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 + +mkSignature' :: Text -> Signature +mkSignature' = mkUnsafe "signature" mkSignature + +instance Builtin ObjectPath where { builtinDBusType _ = DBusObjectPath }; instance Variable ObjectPath where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +newtype ObjectPath = ObjectPath + { strObjectPath :: Text + } + deriving (Show, Eq, Ord, Typeable) + +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 where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +data Array = Array + { arrayType :: Type + , arrayItems :: [Variant] + } + deriving (Eq, Typeable) + +instance Builtin Array where + builtinDBusType = DBusArray . arrayType + +instance Show Array where + showsPrec d (Array t vs) = showParen (d > 10) $ + s "Array " . showSig . s " [" . s valueString . s "]" where + s = showString + showSig = shows $ typeCode t + vs' = [show x | (Variant x) <- vs] + valueString = intercalate ", " vs' + +arrayFromItems :: Type -> [Variant] -> Maybe Array +arrayFromItems t vs = do + mkSignature (typeCode t) + if all (\x -> variantType x == t) vs + then Just $ Array 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 + +instance Variable Dictionary where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +data Dictionary = Dictionary + { dictionaryKeyType :: Type + , dictionaryValueType :: Type + , dictionaryItems :: [(Variant, Variant)] + } + deriving (Eq, Typeable) + +instance Builtin Dictionary where + builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt + +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 ((Variant k), (Variant v)) = + show k ++ " -> " ++ show 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 t items) = do + let toPair x = do + struct <- fromVariant x + case struct of + Structure [k, v] -> Just (k, v) + _ -> Nothing + (kt, vt) <- case t of + DBusStructure [kt, vt] -> Just (kt, vt) + _ -> Nothing + pairs <- mapM toPair items + dictionaryFromItems kt vt pairs + +instance Variable Structure where { toVariant = Variant ; fromVariant (Variant x) = cast x }; +data Structure = Structure [Variant] + deriving (Show, Eq, Typeable) + +instance Builtin Structure where + builtinDBusType (Structure vs) = DBusStructure $ map variantType vs + + + + + + + + + + + + +newtype BusName = BusName {strBusName :: Text} deriving (Show, Eq, Ord); instance Variable BusName where { toVariant = toVariant . strBusName ; fromVariant = (mkBusName =<<) . fromVariant }; mkBusName' :: Text -> BusName; mkBusName' = mkUnsafe "bus name" mkBusName + +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') + +newtype InterfaceName = InterfaceName {strInterfaceName :: Text} deriving (Show, Eq, Ord); instance Variable InterfaceName where { toVariant = toVariant . strInterfaceName ; fromVariant = (mkInterfaceName =<<) . fromVariant }; mkInterfaceName' :: Text -> InterfaceName; mkInterfaceName' = mkUnsafe "interface name" mkInterfaceName + +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) + +newtype ErrorName = ErrorName {strErrorName :: Text} deriving (Show, Eq, Ord); instance Variable ErrorName where { toVariant = toVariant . strErrorName ; fromVariant = (mkErrorName =<<) . fromVariant }; mkErrorName' :: Text -> ErrorName; mkErrorName' = mkUnsafe "error name" mkErrorName + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + +newtype MemberName = MemberName {strMemberName :: Text} deriving (Show, Eq, Ord); instance Variable MemberName where { toVariant = toVariant . strMemberName ; fromVariant = (mkMemberName =<<) . fromVariant }; mkMemberName' :: Text -> MemberName; mkMemberName' = mkUnsafe "member name" mkMemberName + +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/Util.hs b/hs/DBus/Util.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Util.hs @@ -0,0 +1,44 @@ +{- + Copyright (C) 2009 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 . +-} + +module DBus.Util where +import Text.Parsec (Parsec, parse) +import Data.Char (digitToInt) + +checkLength :: Int -> String -> Maybe String +checkLength length' s | length s <= length' = Just s +checkLength _ _ = Nothing + +parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe p = either (const Nothing) Just . parse p "" + +mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b +mkUnsafe label f x = case f x of + Just x' -> x' + Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x + +hexToInt :: String -> Int +hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "DBus.Util.fromRight: Left" + diff --git a/hs/DBus/Wire.hs b/hs/DBus/Wire.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Wire.hs @@ -0,0 +1,649 @@ +{- + Copyright (C) 2009 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 GeneralizedNewtypeDeriving #-} + +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Wire ( Endianness (..) + + , alignment + + , MarshalM + , Marshal + , marshal + , runMarshal + + , MarshalError (..) + + , Unmarshal + , unmarshal + , runUnmarshal + + , UnmarshalError (..) + + , marshalMessage + + , unmarshalMessage +) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import qualified Control.Monad.State as ST +import qualified Control.Monad.Error as E +import qualified Data.ByteString.Lazy as L + +import qualified Data.Binary.Put as P + +import qualified Data.Binary.Get as G + +import qualified Data.Binary.IEEE754 as IEEE + +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) + +import qualified DBus.Constants as C + +import qualified DBus.Message.Internal as M + +import Data.Bits ((.|.), (.&.)) +import qualified Data.Set as Set + +import Control.Monad (when, unless) +import Data.Maybe (fromJust, listToMaybe, fromMaybe) +import Data.Word (Word8, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import Data.Typeable (Typeable) + +import qualified DBus.Types as T + +data Endianness = LittleEndian | BigEndian + deriving (Show, Eq) + +encodeEndianness :: Endianness -> Word8 +encodeEndianness LittleEndian = 108 +encodeEndianness BigEndian = 66 + +decodeEndianness :: Word8 -> Maybe Endianness +decodeEndianness 108 = Just LittleEndian +decodeEndianness 66 = Just BigEndian +decodeEndianness _ = Nothing + +alignment :: T.Type -> Word8 +alignment T.DBusByte = 1 +alignment T.DBusWord16 = 2 +alignment T.DBusWord32 = 4 +alignment T.DBusWord64 = 8 +alignment T.DBusInt16 = 2 +alignment T.DBusInt32 = 4 +alignment T.DBusInt64 = 8 +alignment T.DBusDouble = 8 + +alignment T.DBusBoolean = 4 + +alignment T.DBusString = 4 +alignment T.DBusObjectPath = 4 + +alignment T.DBusSignature = 1 + +alignment (T.DBusArray _) = 4 + +alignment (T.DBusDictionary _ _) = 4 + +alignment (T.DBusStructure _) = 8 + +alignment T.DBusVariant = 1 + + +padding :: Word64 -> Word8 -> Word64 +padding current count = required where + count' = fromIntegral count + missing = mod current count' + required = if missing > 0 + then count' - missing + else 0 + +data MarshalState = MarshalState Endianness L.ByteString +newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a) + deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState) +type Marshal = MarshalM () + +runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString +runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of + (Right _, MarshalState _ bytes) -> Right bytes + (Left x, _) -> Left x + where initialState = MarshalState e L.empty + +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 = marshalPut P.putWord16be x + marshalType T.DBusWord32 = marshalPut P.putWord32be x + marshalType T.DBusWord64 = marshalPut P.putWord64be x + marshalType T.DBusInt16 = marshalPut P.putWord16be $ fromIntegral (x :: Int16) + marshalType T.DBusInt32 = marshalPut P.putWord32be $ fromIntegral (x :: Int32) + marshalType T.DBusInt64 = marshalPut P.putWord64be $ fromIntegral (x :: Int64) + + marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x + + 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 + pad 8 + mapM_ marshal vs + + marshalType T.DBusVariant = do + let rawSig = T.typeCode . T.variantType $ x + sig <- case T.mkSignature rawSig of + Just x' -> return x' + Nothing -> E.throwError $ InvalidVariantSignature rawSig + marshalSignature sig + marshal x + + +append :: L.ByteString -> Marshal +append bs = do + (MarshalState e bs') <- ST.get + ST.put $ MarshalState e (L.append bs' bs) + +pad :: Word8 -> Marshal +pad count = do + (MarshalState _ bytes) <- ST.get + let padding' = padding (fromIntegral . L.length $ bytes) count + append $ L.replicate (fromIntegral padding') 0 + +marshalPut :: (a -> P.Put) -> a -> Marshal +marshalPut put x = do + let bytes = P.runPut $ put x + (MarshalState e _) <- ST.get + pad . fromIntegral . L.length $ bytes + append $ case e of + BigEndian -> bytes + LittleEndian -> L.reverse bytes + +data MarshalError + = MessageTooLong Word64 + | ArrayTooLong Word64 + | InvalidBodySignature Text + | InvalidVariantSignature Text + deriving (Eq, Typeable) + +instance Show MarshalError where + show (MessageTooLong x) = concat + ["Message too long (", show x, " bytes)."] + show (ArrayTooLong x) = concat + ["Array too long (", show x, " bytes)."] + show (InvalidBodySignature x) = concat + ["Invalid body signature: ", show x] + show (InvalidVariantSignature x) = concat + ["Invalid variant signature: ", show x] + +instance E.Error MarshalError + +data UnmarshalState = UnmarshalState Endianness L.ByteString Word64 +newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a) + deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState) + +runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a +runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where + state = UnmarshalState e bytes 0 + +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 +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 + +unmarshalType T.DBusInt16 = do + x <- unmarshalGet 2 G.getWord16be G.getWord16le + return . T.toVariant $ (fromIntegral x :: Int16) + +unmarshalType T.DBusInt32 = do + x <- unmarshalGet 4 G.getWord32be G.getWord32le + return . T.toVariant $ (fromIntegral x :: Int32) + +unmarshalType T.DBusInt64 = do + x <- unmarshalGet 8 G.getWord64be G.getWord64le + return . T.toVariant $ (fromIntegral x :: Int64) + +unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le + +unmarshalType T.DBusBoolean = unmarshalWord32 >>= + fromMaybeU' "boolean" (\x -> case x of + 0 -> Just False + 1 -> Just True + _ -> Nothing) + +unmarshalType T.DBusString = fmap T.toVariant unmarshalText + +unmarshalType T.DBusObjectPath = unmarshalText >>= + fromMaybeU' "object path" T.mkObjectPath + +unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature + +unmarshalType (T.DBusArray t) = fmap T.toVariant $ unmarshalArray t + +unmarshalType (T.DBusDictionary kt vt) = do + let pairType = T.DBusStructure [kt, vt] + array <- unmarshalArray pairType + fromMaybeU' "dictionary" T.arrayToDictionary array + +unmarshalType (T.DBusStructure ts) = do + skipPadding 8 + fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + +unmarshalType T.DBusVariant = do + let getType sig = case T.signatureTypes sig of + [t] -> Just t + _ -> Nothing + + t <- fromMaybeU "variant signature" getType =<< unmarshalSignature + fmap T.toVariant $ unmarshalType t + + +consume :: Word64 -> Unmarshal L.ByteString +consume count = do + (UnmarshalState e bytes offset) <- ST.get + let bytes' = L.drop (fromIntegral offset) bytes + let x = L.take (fromIntegral count) bytes' + unless (L.length x == fromIntegral count) $ + E.throwError $ UnexpectedEOF offset + + ST.put $ UnmarshalState e bytes (offset + count) + return x + +skipPadding :: Word8 -> Unmarshal () +skipPadding count = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume $ padding offset count + unless (L.all (== 0) bytes) $ + E.throwError $ InvalidPadding offset + +skipTerminator :: Unmarshal () +skipTerminator = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume 1 + unless (L.all (== 0) bytes) $ + E.throwError $ MissingTerminator offset + +fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b +fromMaybeU label f x = case f x of + Just x' -> return x' + Nothing -> E.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' + +unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a +unmarshalGet count be le = do + skipPadding count + (UnmarshalState e _ _) <- ST.get + bs <- consume . fromIntegral $ count + let get' = case e of + BigEndian -> be + LittleEndian -> le + return $ G.runGet get' bs + +unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a + -> Unmarshal T.Variant +unmarshalGet' count be le = fmap T.toVariant $ unmarshalGet count be le + +untilM :: Monad m => m Bool -> m a -> m [a] +untilM test comp = do + done <- test + if done + then return [] + else do + x <- comp + xs <- untilM test comp + return $ x:xs + +data UnmarshalError + = UnsupportedProtocolVersion Word8 + | UnexpectedEOF Word64 + | Invalid Text Text + | MissingHeaderField Text + | InvalidHeaderField Text T.Variant + | InvalidPadding Word64 + | MissingTerminator Word64 + | ArraySizeMismatch + deriving (Eq, Typeable) + +instance Show UnmarshalError where + show (UnsupportedProtocolVersion x) = concat + ["Unsupported protocol version: ", show x] + show (UnexpectedEOF pos) = concat + ["Unexpected EOF at position ", show pos] + show (Invalid label x) = TL.unpack $ TL.concat + ["Invalid ", label, ": ", x] + show (MissingHeaderField x) = concat + ["Required field " , show x , " is missing."] + show (InvalidHeaderField x got) = concat + [ "Invalid header field ", show x, ": ", show got] + show (InvalidPadding pos) = concat + ["Invalid padding at position ", show pos] + show (MissingTerminator pos) = concat + ["Missing NUL terminator at position ", show pos] + show ArraySizeMismatch = "Array size mismatch" + +instance E.Error UnmarshalError + +marshalWord32 :: Word32 -> Marshal +marshalWord32 = marshalPut P.putWord32be + +unmarshalWord32 :: Unmarshal Word32 +unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le + +marshalText :: Text -> Marshal +marshalText x = do + let bytes = encodeUtf8 x + marshalWord32 . fromIntegral . L.length $ bytes + append bytes + append (L.singleton 0) + +unmarshalText :: Unmarshal Text +unmarshalText = do + byteCount <- unmarshalWord32 + bytes <- consume . fromIntegral $ byteCount + skipTerminator + return . decodeUtf8 $ bytes + +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) + +unmarshalSignature :: Unmarshal T.Signature +unmarshalSignature = do + byteCount <- fmap L.head $ consume 1 + sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount + skipTerminator + fromMaybeU "signature" T.mkSignature sigText + +marshalArray :: T.Array -> Marshal +marshalArray x = do + (arrayPadding, arrayBytes) <- getArrayBytes x + let arrayLen = L.length arrayBytes + when (arrayLen > fromIntegral C.arrayMaximumLength) + (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + marshalWord32 $ fromIntegral arrayLen + append arrayPadding + append arrayBytes + +getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString) +getArrayBytes x = do + let vs = T.arrayItems x + let itemType = T.arrayType x + s <- ST.get + (MarshalState _ afterLength) <- marshalWord32 0 >> ST.get + (MarshalState _ afterPadding) <- pad (alignment itemType) >> ST.get + (MarshalState _ afterItems) <- mapM_ marshal vs >> ST.get + + let paddingBytes = L.drop (L.length afterLength) afterPadding + let itemBytes = L.drop (L.length afterPadding) afterItems + + ST.put s + return (paddingBytes, itemBytes) + +unmarshalArray :: T.Type -> Unmarshal T.Array +unmarshalArray itemType = do + let getOffset = do + (UnmarshalState _ _ o) <- ST.get + return o + byteCount <- unmarshalWord32 + skipPadding (alignment itemType) + start <- getOffset + let end = start + fromIntegral byteCount + vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + end' <- getOffset + when (end' > end) $ + E.throwError ArraySizeMismatch + fromMaybeU "array" (T.arrayFromItems itemType) vs + +encodeFlags :: Set.Set M.Flag -> Word8 +encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where + flagValue M.NoReplyExpected = 0x1 + flagValue M.NoAutoStart = 0x2 + +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] + +encodeField :: M.HeaderField -> T.Structure +encodeField (M.Path x) = encodeField' 1 x +encodeField (M.Interface x) = encodeField' 2 x +encodeField (M.Member x) = encodeField' 3 x +encodeField (M.ErrorName x) = encodeField' 4 x +encodeField (M.ReplySerial x) = encodeField' 5 x +encodeField (M.Destination x) = encodeField' 6 x +encodeField (M.Sender x) = encodeField' 7 x +encodeField (M.Signature x) = encodeField' 8 x + +encodeField' :: T.Variable a => Word8 -> a -> T.Structure +encodeField' code x = T.Structure + [ T.toVariant code + , T.toVariant $ T.toVariant x + ] + +decodeField :: Monad m => T.Structure + -> E.ErrorT UnmarshalError m [M.HeaderField] +decodeField struct = case unpackField struct of + (1, x) -> decodeField' x M.Path "path" + (2, x) -> decodeField' x M.Interface "interface" + (3, x) -> decodeField' x M.Member "member" + (4, x) -> decodeField' x M.ErrorName "error name" + (5, x) -> decodeField' x M.ReplySerial "reply serial" + (6, x) -> decodeField' x M.Destination "destination" + (7, x) -> decodeField' x M.Sender "sender" + (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' x f label = case T.fromVariant x of + Just x' -> return [f x'] + Nothing -> E.throwError $ InvalidHeaderField label x + +unpackField :: T.Structure -> (Word8, T.Variant) +unpackField struct = (c', v') where + T.Structure [c, v] = struct + c' = fromJust . T.fromVariant $ c + v' = fromJust . T.fromVariant $ v + +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 <- ST.get + mapM_ marshal body + (MarshalState _ bodyBytes) <- ST.get + ST.put empty + marshalEndianness e + marshalHeader msg serial sig + $ fromIntegral . L.length $ bodyBytes + pad 8 + append bodyBytes + checkMaximumSize + +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 + Just x -> return x + Nothing -> invalid + +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 + marshalWord32 bodyLength + marshal . T.toVariant $ serial + let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] + marshal . T.toVariant . fromJust . T.toArray fieldType + $ map encodeField fields + +marshalEndianness :: Endianness -> Marshal +marshalEndianness = marshal . T.toVariant . encodeEndianness + +checkMaximumSize :: Marshal +checkMaximumSize = do + (MarshalState _ messageBytes) <- ST.get + let messageLength = L.length messageBytes + when (messageLength > fromIntegral C.messageMaximumLength) + (E.throwError $ MessageTooLong $ fromIntegral messageLength) + +unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) + -> m (Either UnmarshalError M.ReceivedMessage) +unmarshalMessage getBytes' = E.runErrorT $ do + let getBytes = E.lift . getBytes' + + let fixedSig = T.mkSignature' "yyyyuuu" + fixedBytes <- getBytes 16 + + let messageVersion = L.index fixedBytes 3 + when (messageVersion /= C.protocolVersion) $ + E.throwError $ UnsupportedProtocolVersion messageVersion + + let eByte = L.index fixedBytes 0 + endianness <- case decodeEndianness eByte of + Just x' -> return x' + Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte + + let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of + Right x' -> return x' + Left e -> E.throwError 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 + + let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 + + let headerSig = T.mkSignature' "yyyyuua(yv)" + fieldBytes <- getBytes fieldByteCount + let headerBytes = L.append fixedBytes fieldBytes + header <- unmarshal' headerSig headerBytes + + let fieldArray = fromJust . T.fromVariant $ header !! 6 + let fieldStructures = fromJust . T.fromArray $ fieldArray + fields <- fmap concat $ mapM decodeField fieldStructures + + let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 + getBytes . fromIntegral $ bodyPadding + + let bodySig = findBodySignature fields + + bodyBytes <- getBytes bodyLength + body <- unmarshal' bodySig bodyBytes + + y <- case buildReceivedMessage typeCode fields of + Right x -> return x + Left x -> E.throwError $ MissingHeaderField x + + return $ y serial flags body + + +findBodySignature :: [M.HeaderField] -> T.Signature +findBodySignature fields = fromMaybe empty signature where + empty = T.mkSignature' "" + signature = listToMaybe [x | M.Signature x <- fields] + +buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text + (M.Serial -> (Set.Set M.Flag) -> [T.Variant] + -> M.ReceivedMessage) + +buildReceivedMessage 1 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + return $ \serial flags body -> let + iface = listToMaybe [x | M.Interface x <- fields] + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodCall path member iface dest flags body + in M.ReceivedMethodCall serial sender msg + +buildReceivedMessage 2 fields = do + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodReturn replySerial dest flags body + in M.ReceivedMethodReturn serial sender msg + +buildReceivedMessage 3 fields = do + name <- require "error name" [x | M.ErrorName x <- fields] + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Error name replySerial dest flags body + in M.ReceivedError serial sender msg + +buildReceivedMessage 4 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + iface <- require "interface" [x | M.Interface x <- fields] + return $ \serial flags body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Signal path member iface dest flags body + in M.ReceivedSignal serial sender msg + +buildReceivedMessage typeCode fields = return $ \serial flags body -> let + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Unknown typeCode flags body + in M.ReceivedUnknown serial sender msg + +require :: Text -> [a] -> Either Text a +require _ (x:_) = Right x +require label _ = Left label + +instance E.Error Text where + strMsg = TL.pack + diff --git a/hs/Tests.hs b/hs/Tests.hs new file mode 100644 --- /dev/null +++ b/hs/Tests.hs @@ -0,0 +1,614 @@ +{- + Copyright (C) 2009 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 #-} +module Main (tests) where + +import Test.QuickCheck +import Test.Framework (Test, testGroup) +import qualified Test.Framework as F +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Arrow ((&&&)) +import Control.Monad (replicateM) +import qualified Data.Binary.Get as G +import Data.Char (isPrint) +import Data.List (intercalate, isInfixOf) +import Data.Maybe (fromJust, isJust, isNothing) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import DBus.Address +import DBus.Message.Internal +import DBus.Types +import DBus.Wire +import qualified DBus.Introspection as I + +tests :: [Test] +tests = [ testGroup "Types" + [ testGroup "Atomic types" + [ + testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool) + , testGroup "Word8" $ commonVariantTests (arbitrary :: Gen Word8) + , testGroup "Word16" $ commonVariantTests (arbitrary :: Gen Word16) + , testGroup "Word32" $ commonVariantTests (arbitrary :: Gen Word32) + , testGroup "Word64" $ commonVariantTests (arbitrary :: Gen Word64) + , testGroup "Int16" $ commonVariantTests (arbitrary :: Gen Int16) + , testGroup "Int32" $ commonVariantTests (arbitrary :: Gen Int32) + , testGroup "Int64" $ commonVariantTests (arbitrary :: Gen Int64) + , testGroup "Double" $ commonVariantTests (arbitrary :: Gen Double) + , testGroup "String" $ commonVariantTests (arbitrary :: Gen String) ++ + [ testProperty "String -> strict Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.pack x) + , testProperty "String <- strict Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x) + , testProperty "String -> lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x) + , testProperty "String <- lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x) + , testProperty "Strict Text -> lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x) + , testProperty "Strict Text <- lazy Text" + $ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x) + ] + + , testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++ + [ testProperty "Signature identity" + $ \x -> (mkSignature . strSignature) x == Just x + , testProperty "Signature show" + $ \x -> show (strSignature x) `isInfixOf` show x + ] + + , testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++ + [ testProperty "ObjectPath identity" + $ \x -> (mkObjectPath . strObjectPath) x == Just x + ] + + , testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++ + [ testProperty "BusName identity" + $ \x -> (mkBusName . strBusName) x == Just x + ] + + , testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++ + [ testProperty "InterfaceName identity" + $ \x -> (mkInterfaceName . strInterfaceName) x == Just x + ] + + , testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++ + [ testProperty "ErrorName identity" + $ \x -> (mkErrorName . strErrorName) x == Just x + ] + + , testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++ + [ testProperty "MemberName identity" + $ \x -> (mkMemberName . strMemberName) x == Just x + ] + + ] + , testGroup "Container types" + [ + testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant) + + , testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++ + [ testProperty "Array identity" + $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) + , testProperty "Array homogeneity" prop_ArrayHomogeneous + ] + + , testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++ + [ testProperty "Dictionary identity" + $ \x -> Just x == dictionaryFromItems + (dictionaryKeyType x) + (dictionaryValueType x) + (dictionaryItems x) + , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous + , testProperty "Dictionary must have atomic keys" + $ \vt -> forAll containerType $ \kt -> + isNothing (dictionaryFromItems kt vt []) + , testProperty "Dictionary <-> Array conversion" + $ \x -> arrayToDictionary (dictionaryToArray x) == Just x + ] + + , testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure) + + ] + ] + + , testGroup "Addresses" + [ testProperty "Address identity" + $ \x -> mkAddresses (strAddress x) == Just [x] + , testProperty "Multiple addresses" + $ \x y -> let + joined = TL.concat [strAddress x, ";", strAddress y] + in mkAddresses joined == Just [x, y] + , testProperty "Ignore trailing semicolon" + $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] + , testProperty "Ignore trailing comma" + $ \x -> let + hasParams = not . Map.null . addressParameters $ x + parsed = mkAddresses (TL.append (strAddress x) ",") + in hasParams ==> parsed == Just [x] + , testGroup "Valid addresses" $ singleTests + [ isJust . mkAddresses $ ":" + , isJust . mkAddresses $ "a:" + , isJust . mkAddresses $ "a:b=c" + , isJust . mkAddresses $ "a:;" + , isJust . mkAddresses $ "a:;b:" + , isJust . mkAddresses $ "a:b=c," + ] + , testGroup "Invalid addresses" $ singleTests + [ isNothing . mkAddresses $ "" + , isNothing . mkAddresses $ "a" + , isNothing . mkAddresses $ "a:b" + , isNothing . mkAddresses $ "a:b=" + , isNothing . mkAddresses $ "a:," + ] + ] + + , testGroup "Wire format" + [ testProperty "Marshal -> Ummarshal" prop_Unmarshal + , testGroup "Messages" + [ testProperty "Method calls" prop_WireMethodCall + , testProperty "Method returns" prop_WireMethodReturn + , testProperty "Errors" prop_WireError + , testProperty "Signals" prop_WireSignal + ] + ] + + , testGroup "Introspection" + [ testProperty "Generate -> Parse" + $ \x@(I.Object path _ _) -> let + xml = I.toXML x + Just xml' = xml + parsed = I.fromXML path xml' + in isJust xml ==> I.fromXML path xml' == Just x + ] + + ] + +main :: IO () +main = F.defaultMain tests + +atomicType :: Gen Type +atomicType = elements + [ DBusBoolean + , DBusByte + , DBusWord16 + , DBusWord32 + , DBusWord64 + , DBusInt16 + , DBusInt32 + , DBusInt64 + , DBusDouble + , DBusString + , DBusObjectPath + , DBusSignature + ] + +containerType :: Gen Type +containerType = do + c <- choose (0,3) :: Gen Int + case c of + 0 -> fmap DBusArray arbitrary + 1 -> do + kt <- atomicType + vt <- arbitrary + return $ DBusDictionary kt vt + 2 -> fmap DBusStructure $ shrinkingGen arbitrary + 3 -> return DBusVariant + +instance Arbitrary Type where + arbitrary = oneof [atomicType, containerType] + +instance Arbitrary Signature where + arbitrary = clampedSize 255 genSig mkSignature' where + genSig = fmap (TL.concat . map typeCode) arbitrary + +instance Arbitrary ObjectPath where + arbitrary = fmap (mkObjectPath' . TL.pack) path' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = fmap (intercalate "/" . ([] :)) genElements + path' = frequency [(1, return "/"), (9, path)] + genElements = sized' 1 (sized' 1 (elements c)) + +instance Arbitrary BusName where + arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + + unique = do + elems' <- sized' 2 $ elems c' + return . TL.pack $ ':' : intercalate "." elems' + + wellKnown = do + elems' <- sized' 2 $ elems c + return . TL.pack $ intercalate "." elems' + + elems start = do + x <- elements start + xs <- sized' 0 (elements c') + return (x:xs) + +instance Arbitrary InterfaceName where + arbitrary = clampedSize 255 genName mkInterfaceName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = fmap (TL.pack . intercalate ".") genElements + genElements = sized' 2 genElement + genElement = do + x <- elements c + xs <- sized' 0 (elements c') + return (x:xs) + +instance Arbitrary ErrorName where + arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary + +instance Arbitrary MemberName where + arbitrary = clampedSize 255 genName mkMemberName' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = do + x <- elements c + xs <- sized' 0 (elements c') + return . TL.pack $ (x:xs) + +prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen + $ \x -> (fromVariant . toVariant) x == Just x + +prop_VariantEquality gen = testProperty "Variant equality" . forAll gen + $ \x y -> (x == y) == (toVariant x == toVariant y) + +commonVariantTests gen = + [ prop_VariantIdentity gen + , prop_VariantEquality gen + ] + +genVariant :: Type -> Gen Variant +genVariant DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) +genVariant DBusByte = fmap toVariant (arbitrary :: Gen Word8) +genVariant DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) +genVariant DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) +genVariant DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) +genVariant DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) +genVariant DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) +genVariant DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) +genVariant DBusDouble = fmap toVariant (arbitrary :: Gen Double) +genVariant DBusString = fmap toVariant (arbitrary :: Gen String) +genVariant DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) +genVariant DBusSignature = fmap toVariant (arbitrary :: Gen Signature) +genVariant (DBusArray _) = fmap toVariant (arbitrary :: Gen Array) +genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary) +genVariant (DBusStructure _) = fmap toVariant (arbitrary :: Gen Structure) +genVariant DBusVariant = fmap toVariant (arbitrary :: Gen Variant) + +instance Arbitrary Variant where + arbitrary = arbitrary >>= genVariant + +genAtom :: Type -> Gen Variant +genAtom DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) +genAtom DBusByte = fmap toVariant (arbitrary :: Gen Word8) +genAtom DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) +genAtom DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) +genAtom DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) +genAtom DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) +genAtom DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) +genAtom DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) +genAtom DBusDouble = fmap toVariant (arbitrary :: Gen Double) +genAtom DBusString = fmap toVariant (arbitrary :: Gen String) +genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) +genAtom DBusSignature = fmap toVariant (arbitrary :: Gen Signature) + +instance Arbitrary Array where + arbitrary = do + -- Only generate arrays of atomic values, as generating + -- containers randomly almost never results in a valid + -- array. + t <- atomicType + xs <- listOf $ genVariant t + return . fromJust $ arrayFromItems t xs + +prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where + array = arrayFromItems firstType vs + homogeneousTypes = all (== firstType) types + types = map variantType vs + firstType = if null types + then DBusByte + else head types + +instance Arbitrary Dictionary where + arbitrary = do + -- Only generate dictionaries of atomic values, as generating + -- containers randomly almost never results in a valid + -- dictionary. + kt <- atomicType + vt <- atomicType + ks <- listOf $ genAtom kt + vs <- vectorOf (length ks) $ genVariant vt + + return . fromJust $ dictionaryFromItems kt vt $ zip ks vs + +prop_DictionaryHomogeneous x = all correctType pairs where + pairs = dictionaryItems x + kType = dictionaryKeyType x + vType = dictionaryValueType x + correctType (k, v) = variantType k == kType && + variantType v == vType + +instance Arbitrary Structure where + arbitrary = sized $ \n -> + fmap Structure $ shrinkingGen arbitrary + +singleTests :: Testable a => [a] -> [Test] +singleTests ts = singleTests' 1 ts where + singleTests' _ [] = [] + singleTests' n (t:ts') = plusOptions (testProperty (name n) t) + : singleTests' (n + 1) ts' + + total = length ts + options = F.TestOptions Nothing (Just 1) Nothing Nothing + plusOptions = F.plusTestOptions options + name n = "Test " ++ show n ++ "/" ++ show total + +instance Arbitrary Address where + arbitrary = genAddress where + optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + methodChars = filter (flip notElem ":;") ['!'..'~'] + keyChars = filter (flip notElem "=;,") ['!'..'~'] + + genMethod = sized' 0 $ elements methodChars + genParam = do + key <- genKey + value <- genValue + return . concat $ [key, "=", value] + + genKey = sized' 1 $ elements keyChars + genValue = oneof [encodedValue, plainValue] + genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] + encodedValue = do + x1 <- genHex + x2 <- genHex + return ['%', x1, x2] + plainValue = sized' 1 $ elements optional + + genParams = do + params <- sized' 0 genParam + let params' = intercalate "," params + extraComma <- if null params + then return "" + else elements ["", ","] + return $ concat [params', extraComma] + + genAddress = do + m <- genMethod + params <- genParams + extraSemicolon <- elements ["", ";"] + let addrStr = concat [m, ":", params, extraSemicolon] + let Just [addr] = mkAddresses $ TL.pack addrStr + return addr + +instance Arbitrary Serial where + arbitrary = fmap Serial arbitrary + +instance Arbitrary Flag where + arbitrary = elements [NoReplyExpected, NoAutoStart] + +instance Arbitrary MethodCall where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodCall path member iface dest flags body + +instance Arbitrary MethodReturn where + arbitrary = do + serial <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodReturn serial dest flags body + +instance Arbitrary Error where + arbitrary = do + name <- arbitrary + serial <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ Error name serial dest flags body + +instance Arbitrary Signal where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ Signal path member iface dest flags body + +isRight :: Either a b -> Bool +isRight = either (const False) (const True) + +prop_Unmarshal :: Endianness -> Variant -> Property +prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where + sig = mkSignature . typeCode . variantType $ x + Just sig' = sig + + bytes = runMarshal (marshal x) e + Right bytes' = bytes + + valid = isJust sig && isRight bytes + unmarshaled = runUnmarshal (unmarshal sig') e bytes' + +prop_MarshalMessage e serial msg expected = valid ==> correct where + bytes = marshalMessage e serial msg + Right bytes' = bytes + + getBytes = G.getLazyByteString . fromIntegral + unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' + + valid = isRight bytes + correct = unmarshaled == Right expected + +prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodCall serial Nothing msg + +prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodReturn serial Nothing msg + +prop_WireError e serial msg = prop_MarshalMessage e serial msg + $ ReceivedError serial Nothing msg + +prop_WireSignal e serial msg = prop_MarshalMessage e serial msg + $ ReceivedSignal serial Nothing msg + +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian, BigEndian] + +subObject :: ObjectPath -> Gen I.Object +subObject parentPath = sized $ \n -> resize (min n 4) $ do + let nonRoot = do + x <- arbitrary + case strObjectPath x of + "/" -> nonRoot + x' -> return x' + + thisPath <- nonRoot + let path' = case strObjectPath parentPath of + "/" -> thisPath + x -> TL.append x thisPath + let path = mkObjectPath' path' + ifaces <- arbitrary + children <- shrinkingGen . listOf . subObject $ path + return $ I.Object path ifaces children + +instance Arbitrary I.Object where + arbitrary = arbitrary >>= subObject + +instance Arbitrary I.Interface where + arbitrary = do + name <- arbitrary + methods <- arbitrary + signals <- arbitrary + properties <- arbitrary + return $ I.Interface name methods signals properties + +instance Arbitrary I.Method where + arbitrary = do + name <- arbitrary + inParams <- arbitrary + outParams <- arbitrary + return $ I.Method name inParams outParams + +instance Arbitrary I.Signal where + arbitrary = do + name <- arbitrary + params <- arbitrary + return $ I.Signal name params + +singleType :: Gen Signature +singleType = do + t <- arbitrary + case mkSignature $ typeCode t of + Just x -> return x + Nothing -> singleType + +instance Arbitrary I.Parameter where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + return $ I.Parameter (TL.pack name) sig + +instance Arbitrary I.Property where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + access <- elements + [[], [I.Read], [I.Write], + [I.Read, I.Write]] + return $ I.Property (TL.pack name) sig access + +iexp :: Integral a => a -> a -> a +iexp x y = floor $ fromIntegral x ** fromIntegral y + +instance Arbitrary Word8 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 8 - 1 + +instance Arbitrary Word16 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 16 - 1 + +instance Arbitrary Word32 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 32 - 1 + +instance Arbitrary Word64 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 64 - 1 + +instance Arbitrary Int16 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 16 - 1 + +instance Arbitrary Int32 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 32 - 1 + +instance Arbitrary Int64 where + arbitrary = fmap fromIntegral gen where + gen = choose (0, max') :: Gen Integer + max' = iexp 2 64 - 1 + +instance Arbitrary T.Text where + arbitrary = fmap T.pack arbitrary + +instance Arbitrary TL.Text where + arbitrary = fmap TL.pack arbitrary + +sized' :: Int -> Gen a -> Gen [a] +sized' atLeast g = sized $ \n -> do + n' <- choose (atLeast, max atLeast n) + replicateM n' g + +clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a +clampedSize maxSize gen f = do + s <- gen + if TL.length s > maxSize + then shrinkingGen arbitrary + else return . f $ s + +shrinkingGen :: Gen a -> Gen a +shrinkingGen gen = sized $ \n -> if n > 0 then + resize (n `div` 2) gen + else gen +