diff --git a/DBus/Address.lhs b/DBus/Address.lhs new file mode 100644 --- /dev/null +++ b/DBus/Address.lhs @@ -0,0 +1,137 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Authentication.lhs @@ -0,0 +1,70 @@ +% 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 --- a/DBus/Bus.lhs +++ b/DBus/Bus.lhs @@ -24,18 +24,19 @@ 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.Bus.Address as A -import qualified DBus.Bus.Connection as C + +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 @@ -92,11 +93,10 @@ \begin{code} hello :: M.MethodCall -hello = M.MethodCall - (fromJust . T.mkObjectPath $ "/org/freedesktop/DBus") - (fromJust . T.mkMemberName $ "Hello") - (T.mkInterfaceName "org.freedesktop.DBus") - (T.mkBusName "org.freedesktop.DBus") +hello = M.MethodCall dbusPath + (T.mkMemberName' "Hello") + (Just dbusInterface) + (Just dbusName) Set.empty [] \end{code} diff --git a/DBus/Bus/Address.lhs b/DBus/Bus/Address.lhs deleted file mode 100644 --- a/DBus/Bus/Address.lhs +++ /dev/null @@ -1,148 +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.Address - ( Address - , addressMethod - , addressParameters - , strAddress - , parseAddresses - ) where - -import Data.Char (ord, digitToInt, chr) -import qualified Data.Map as M -import Data.List (intercalate) -import Text.Printf (printf) -import qualified Text.Parsec as P -import Text.Parsec ((<|>)) -\end{code} -} - -\section{Addresses} - -\subsection{Formatting} - -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} - -Finally, a couple parser utility functions. - -\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/DBus/Bus/Connection.lhs b/DBus/Bus/Connection.lhs deleted file mode 100644 --- a/DBus/Bus/Connection.lhs +++ /dev/null @@ -1,236 +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.Bus.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.Types as T -import DBus.Message (Message, ReceivedMessage, marshal, unmarshal) -import qualified DBus.Bus.Address as A -import DBus.Protocol.Authentication (authenticate) -\end{code} -} - -\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/Connection.lhs b/DBus/Connection.lhs new file mode 100644 --- /dev/null +++ b/DBus/Connection.lhs @@ -0,0 +1,237 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Constants.lhs @@ -0,0 +1,271 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Marshal.lhs @@ -0,0 +1,242 @@ +% 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 --- a/DBus/Message.lhs +++ b/DBus/Message.lhs @@ -16,16 +16,30 @@ \ignore{ \begin{code} module DBus.Message - ( 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 @@ -38,10 +52,11 @@ import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe) import qualified Data.Set as S -import qualified DBus.Protocol.Marshal as M -import qualified DBus.Protocol.Unmarshal as U -import DBus.Protocol.Padding (padding) +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} } @@ -61,13 +76,6 @@ messageBody :: a -> [T.Variant] \end{code} -All messages are assumed to be using protocol version 1. - -\begin{code} -protocolVersion :: Word8 -protocolVersion = 1 -\end{code} - \subsection{Flags} Flags are represented as the integral value of each flag OR'd into a single @@ -99,14 +107,15 @@ \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 +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} @@ -128,7 +137,7 @@ return (c', v') instance T.Variable HeaderField where - defaultSignature _ = fromJust . T.mkSignature $ "(yv)" + defaultSignature _ = T.mkSignature' "(yv)" toVariant (Path x) = header' 1 x toVariant (Interface x) = header' 2 x @@ -272,7 +281,7 @@ -> MessageHeader buildHeader endianness serial m bodyLen = header where ts = map T.variantType $ messageBody m - bodySig = fromJust . T.mkSignature $ concatMap T.typeString ts + bodySig = T.mkSignature' $ concatMap T.typeString ts fields = Signature bodySig : messageHeaderFields m header = MessageHeader endianness @@ -327,8 +336,8 @@ unknown messages. \begin{code} -data ReceivedMessage = - ReceivedMethodCall T.Serial (Maybe T.BusName) MethodCall +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 @@ -380,8 +389,8 @@ getRaw :: (E.Error e, E.MonadError e m) => (Word32 -> m L.ByteString) -> m RawMessage getRaw get = do - let fixed'Sig = fromJust . T.mkSignature $ "yyyy" - let fixedSig = fromJust . T.mkSignature $ "yyyyuuu" + let fixed'Sig = T.mkSignature' "yyyy" + let fixedSig = T.mkSignature' "yyyyuuu" -- Protocol version fixedBytes <- get 16 @@ -432,7 +441,7 @@ parseHeader :: (E.Error e, E.MonadError e m) => T.Endianness -> L.ByteString -> m MessageHeader parseHeader endianness bytes = do - let signature = fromJust . T.mkSignature $ "yyyyuua(yv)" + 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 @@ -453,7 +462,7 @@ \begin{code} findBodySignature :: [HeaderField] -> T.Signature findBodySignature fields = fromMaybe empty signature where - empty = fromJust . T.mkSignature $ "" + empty = T.mkSignature' "" signature = listToMaybe [x | Signature x <- fields] \end{code} diff --git a/DBus/Padding.lhs b/DBus/Padding.lhs new file mode 100644 --- /dev/null +++ b/DBus/Padding.lhs @@ -0,0 +1,59 @@ +% 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/Protocol/Authentication.lhs b/DBus/Protocol/Authentication.lhs deleted file mode 100644 --- a/DBus/Protocol/Authentication.lhs +++ /dev/null @@ -1,71 +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} -{-# OPTIONS_HADDOCK hide #-} -module DBus.Protocol.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/Protocol/Marshal.lhs b/DBus/Protocol/Marshal.lhs deleted file mode 100644 --- a/DBus/Protocol/Marshal.lhs +++ /dev/null @@ -1,243 +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} -{-# OPTIONS_HADDOCK hide #-} -module DBus.Protocol.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.Protocol.Padding (padding, padByType) -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 (padByType 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/Protocol/Padding.lhs b/DBus/Protocol/Padding.lhs deleted file mode 100644 --- a/DBus/Protocol/Padding.lhs +++ /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 . - -\ignore{ -\begin{code} -{-# OPTIONS_HADDOCK hide #-} -module DBus.Protocol.Padding - ( padding - , padByType - ) where - -import Data.Word (Word8, Word64) -import qualified DBus.Types as T -\end{code} -} - -\section{Value padding} - -\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} -padByType :: T.Type -> Word8 -padByType T.BooleanT = 4 -padByType T.ByteT = 1 -padByType T.UInt16T = 2 -padByType T.UInt32T = 4 -padByType T.UInt64T = 8 -padByType T.Int16T = 2 -padByType T.Int32T = 4 -padByType T.Int64T = 8 -padByType T.DoubleT = 8 -padByType T.StringT = 4 -padByType T.ObjectPathT = 4 -padByType T.SignatureT = 1 -padByType (T.ArrayT _) = 4 -padByType (T.DictionaryT _ _) = 4 -padByType (T.StructureT _) = 8 -padByType T.VariantT = 1 -\end{code} - diff --git a/DBus/Protocol/Unmarshal.lhs b/DBus/Protocol/Unmarshal.lhs deleted file mode 100644 --- a/DBus/Protocol/Unmarshal.lhs +++ /dev/null @@ -1,313 +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} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ExistentialQuantification #-} -module DBus.Protocol.Unmarshal (unmarshal) where - -import Data.Maybe (fromJust) -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.Protocol.Padding (padding, padByType) -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 = fromJust . T.mkSignature . T.typeString $ t - - byteCount <- word32 - skipPadding (padByType 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 = fromJust . T.mkSignature . T.typeString $ kt - let vSig = fromJust . 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/Types.lhs b/DBus/Types.lhs --- a/DBus/Types.lhs +++ b/DBus/Types.lhs @@ -38,10 +38,10 @@ \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} -\input{DBus/Types/Containers.lhs} diff --git a/DBus/Types/Atom.lhs b/DBus/Types/Atom.lhs --- a/DBus/Types/Atom.lhs +++ b/DBus/Types/Atom.lhs @@ -13,13 +13,12 @@ % You should have received a copy of the GNU General Public License % along with this program. If not, see . -\subsection{Atoms} - \ignore{ \begin{code} {-# LANGUAGE TypeSynonymInstances #-} module DBus.Types.Atom - ( Atom + ( -- * Atoms + Atom , Atomic , toAtom , fromAtom @@ -34,27 +33,29 @@ import Data.Int (Int16, Int32, Int64) import qualified DBus.Types.Signature as S import qualified DBus.Types.ObjectPath as O -import {-# SOURCE #-} qualified DBus.Types.Containers as C +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 C.Variant +newtype Atom = Atom V.Variant deriving (Show, Eq) -class C.Variable a => Atomic a where +class V.Variable a => Atomic a where toAtom :: a -> Atom -atomToVariant :: Atom -> C.Variant +atomToVariant :: Atom -> V.Variant atomToVariant (Atom x) = x -atomFromVariant :: C.Variant -> Maybe Atom +atomFromVariant :: V.Variant -> Maybe Atom atomFromVariant v = msum as where - v' :: C.Variable a => Maybe a - v' = C.fromVariant v + v' :: V.Variable a => Maybe a + v' = V.fromVariant v fa :: (Atomic a, Functor f) => f a -> f Atom fa = fmap toAtom @@ -74,13 +75,13 @@ \end{code} \begin{code} -fromAtom :: C.Variable a => Atom -> Maybe a -fromAtom (Atom x) = C.fromVariant x +fromAtom :: V.Variable a => Atom -> Maybe a +fromAtom (Atom x) = V.fromVariant x \end{code} \begin{code} atomSignature :: Atom -> S.Signature -atomSignature (Atom v) = C.variantSignature v +atomSignature (Atom v) = V.variantSignature v \end{code} \begin{code} @@ -88,11 +89,9 @@ atomType = head . S.signatureTypes . atomSignature \end{code} -\subsubsection{Built-in atomic types} - \begin{code} toAtom' :: Atomic a => a -> Atom -toAtom' = Atom . C.toVariant +toAtom' = Atom . V.toVariant instance Atomic Bool where toAtom = toAtom' instance Atomic Word8 where toAtom = toAtom' diff --git a/DBus/Types/Containers.lhs b/DBus/Types/Containers.lhs --- a/DBus/Types/Containers.lhs +++ b/DBus/Types/Containers.lhs @@ -15,318 +15,35 @@ \ignore{ \begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.Containers - ( Variant - , Variable - , toVariant - , fromVariant - , defaultSignature + ( -- * Containers + + -- ** Variants + Variant + , Variable (..) , variantSignature , variantType - , Array - , toArray - , fromArray - , arrayItems - , arrayFromItems - , arraySignature + -- ** Arrays + , module DBus.Types.Containers.Array - , Dictionary - , toDictionary - , fromDictionary - , dictionaryItems - , dictionaryFromItems - , dictionarySignature + -- ** Dictionaries + , module DBus.Types.Containers.Dictionary - , Structure (..) - , structureSignature + -- ** Structures + , module DBus.Types.Containers.Structure ) where -import Control.Arrow ((***)) -import Data.Typeable (Typeable, cast) -import Data.Maybe (fromJust) -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.Atom as A +import DBus.Types.Containers.Variant +import DBus.Types.Containers.Array +import DBus.Types.Containers.Dictionary +import DBus.Types.Containers.Structure \end{code} } -\subsection{Containers} -\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 _ = sig' "v" - toVariant = variant' "v" - fromVariant = cast' -\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 _ = sig' "b" - toVariant = variant' "b" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Word8 where - defaultSignature _ = sig' "y" - toVariant = variant' "y" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Word16 where - defaultSignature _ = sig' "q" - toVariant = variant' "q" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Word32 where - defaultSignature _ = sig' "u" - toVariant = variant' "u" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Word64 where - defaultSignature _ = sig' "t" - toVariant = variant' "t" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Int16 where - defaultSignature _ = sig' "n" - toVariant = variant' "n" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Int32 where - defaultSignature _ = sig' "i" - toVariant = variant' "i" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Int64 where - defaultSignature _ = sig' "x" - toVariant = variant' "x" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable Double where - defaultSignature _ = sig' "d" - toVariant = variant' "d" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable String where - defaultSignature _ = sig' "s" - toVariant = variant' "s" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable O.ObjectPath where - defaultSignature _ = sig' "o" - toVariant = variant' "o" - fromVariant = cast' -\end{code} - -\begin{code} -instance Variable S.Signature where - defaultSignature _ = sig' "g" - toVariant = variant' "g" - fromVariant = cast' -\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 [Variant] - deriving (Show, Eq, Typeable) - -instance Variable Array where - defaultSignature _ = sig' "ay" - toVariant x = Variant (arraySignature x) x - fromVariant = cast' - -toArray :: Variable a => [a] -> Maybe Array -toArray vs@([]) = Just $ Array sig [] where - itemSig = defaultSignature . head $ undefined:vs - sig = sig' $ 'a' : S.strSignature itemSig - -toArray vs = arrayFromItems sig variants where - variants = map toVariant vs - sig = variantSignature . head $ variants - -fromArray :: Variable a => Array -> Maybe [a] -fromArray (Array _ vs) = mapM fromVariant vs - -arrayItems :: Array -> [Variant] -arrayItems (Array _ vs) = vs - -arrayFromItems :: S.Signature -> [Variant] -> Maybe Array -arrayFromItems itemSig vs = maybeArray where - maybeArray = if hasSignature itemSig vs - then Just (Array sig vs) - else Nothing - sig = sig' $ 'a' : S.strSignature itemSig - -arraySignature :: Array -> S.Signature -arraySignature (Array s _) = s -\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, Variant)] - deriving (Show, Eq, Typeable) - -instance Variable Dictionary where - defaultSignature _ = sig' "a{yy}" - toVariant x = Variant (dictionarySignature x) x - fromVariant = cast' - -toDictionary :: (A.Atomic a, Variable b) => [(a, b)] -> Maybe Dictionary -toDictionary vs@([]) = Just $ Dictionary sig [] where - fake = head $ (undefined, undefined) : vs - kSig = S.strSignature . defaultSignature . fst $ fake - vSig = S.strSignature . defaultSignature . snd $ fake - sig = sig' $ "a{" ++ kSig ++ vSig ++ "}" - -toDictionary pairs = dictionaryFromItems kSig vSig pairs' where - pairs' = map (A.toAtom *** toVariant) pairs - kSig = A.atomSignature . fst . head $ pairs' - vSig = variantSignature . snd . head $ pairs' - -fromDictionary :: (A.Atomic a, Variable b) => Dictionary -> Maybe [(a, b)] -fromDictionary (Dictionary _ vs) = mapM fromVariant' vs where - fromVariant' (k, v) = do - k' <- A.fromAtom k - v' <- fromVariant v - return (k', v') - -dictionaryItems :: Dictionary -> [(A.Atom, Variant)] -dictionaryItems (Dictionary _ vs) = vs - -dictionaryFromItems :: S.Signature -> S.Signature -> [(A.Atom, 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 = sig' $ "a{" ++ kSig' ++ vSig' ++ "}" - -dictionarySignature :: Dictionary -> S.Signature -dictionarySignature (Dictionary s _) = s -\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 [Variant] - deriving (Show, Eq, Typeable) - -instance Variable Structure where - defaultSignature _ = sig' "()" - toVariant x = Variant (structureSignature x) x - fromVariant = cast' - -structureSignature :: Structure -> S.Signature -structureSignature (Structure vs) = sig where - sigs = [s | (Variant s _) <- vs] - sig = sig' $ "(" ++ concatMap S.strSignature sigs ++ ")" -\end{code} - -\subsubsection*{Helper functions} - -\begin{code} -sig' :: String -> S.Signature -sig' = fromJust . S.mkSignature - -variant' :: (Variable a, Typeable a, Show a) => String -> a -> Variant -variant' = Variant . sig' - -cast' :: Typeable a => Variant -> Maybe a -cast' (Variant _ x) = cast x +\subsection{Containers} -hasSignature :: S.Signature -> [Variant] -> Bool -hasSignature _ [] = True -hasSignature sig vs = all (== sig) . map variantSignature $ vs -\end{code} +\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.lhs-boot b/DBus/Types/Containers.lhs-boot deleted file mode 100644 --- a/DBus/Types/Containers.lhs-boot +++ /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 . - -This is just a stub file so {\tt Atom} can implement {\tt Variable}. - -\begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -module DBus.Types.Containers where - -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import DBus.Types.Signature (Signature) -import DBus.Types.ObjectPath (ObjectPath) - -class Variable a where - defaultSignature :: a -> Signature - toVariant :: a -> Variant - fromVariant :: Variant -> Maybe a - -data Variant - -instance Show Variant -instance Eq Variant - -instance Variable Bool -instance Variable Word8 -instance Variable Word16 -instance Variable Word32 -instance Variable Word64 -instance Variable Int16 -instance Variable Int32 -instance Variable Int64 -instance Variable Double -instance Variable String -instance Variable ObjectPath -instance Variable Signature - -variantSignature :: Variant -> Signature -\end{code} diff --git a/DBus/Types/Containers/Array.lhs b/DBus/Types/Containers/Array.lhs new file mode 100644 --- /dev/null +++ b/DBus/Types/Containers/Array.lhs @@ -0,0 +1,84 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Types/Containers/Dictionary.lhs @@ -0,0 +1,110 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Types/Containers/Structure.lhs @@ -0,0 +1,48 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Types/Containers/Variant.lhs @@ -0,0 +1,186 @@ +% 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 --- a/DBus/Types/Endianness.lhs +++ b/DBus/Types/Endianness.lhs @@ -15,12 +15,14 @@ \ignore{ \begin{code} -module DBus.Types.Endianness (Endianness (..)) where +module DBus.Types.Endianness + ( -- * Endianness + Endianness (..) + ) where import Data.Word (Word8) -import Data.Maybe (fromJust) import qualified DBus.Types.Containers as C -import DBus.Types.Signature (mkSignature) +import DBus.Types.Signature (mkSignature') \end{code} } @@ -37,7 +39,7 @@ \begin{code} instance C.Variable Endianness where - defaultSignature _ = fromJust . mkSignature $ "y" + defaultSignature _ = mkSignature' "y" toVariant LittleEndian = C.toVariant (0x6C :: Word8) toVariant BigEndian = C.toVariant (0x42 :: Word8) fromVariant v = do diff --git a/DBus/Types/Names.lhs b/DBus/Types/Names.lhs --- a/DBus/Types/Names.lhs +++ b/DBus/Types/Names.lhs @@ -16,35 +16,42 @@ \ignore{ \begin{code} module DBus.Types.Names - ( InterfaceName + ( -- * 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 Data.Maybe (fromJust) 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.Types.Util (checkLength, parseMaybe) +import DBus.Types.Signature (mkSignature') +import DBus.Util (checkLength, parseMaybe, mkUnsafe) \end{code} } -\subsubsection{Names} - All names have a length limit of 255 characters. \subsubsection{Interface names} @@ -60,7 +67,7 @@ \begin{code} instance C.Variable InterfaceName where - defaultSignature _ = fromJust . mkSignature $ "s" + defaultSignature _ = mkSignature' "s" toVariant = A.atomToVariant . A.toAtom fromVariant = (mkInterfaceName =<<) . C.fromVariant instance A.Atomic InterfaceName where @@ -78,6 +85,11 @@ \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} @@ -94,7 +106,7 @@ \begin{code} instance C.Variable ErrorName where - defaultSignature _ = fromJust . mkSignature $ "s" + defaultSignature _ = mkSignature' "s" toVariant = A.atomToVariant . A.toAtom fromVariant = (mkErrorName =<<) . C.fromVariant instance A.Atomic ErrorName where @@ -107,6 +119,11 @@ \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} @@ -120,7 +137,7 @@ \begin{code} instance C.Variable BusName where - defaultSignature _ = fromJust . mkSignature $ "s" + defaultSignature _ = mkSignature' "s" toVariant = A.atomToVariant . A.toAtom fromVariant = (mkBusName =<<) . C.fromVariant instance A.Atomic BusName where @@ -140,6 +157,11 @@ \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} @@ -153,7 +175,7 @@ \begin{code} instance C.Variable MemberName where - defaultSignature _ = fromJust . mkSignature $ "s" + defaultSignature _ = mkSignature' "s" toVariant = A.atomToVariant . A.toAtom fromVariant = (mkMemberName =<<) . C.fromVariant instance A.Atomic MemberName where @@ -167,6 +189,11 @@ 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} diff --git a/DBus/Types/ObjectPath.lhs b/DBus/Types/ObjectPath.lhs --- a/DBus/Types/ObjectPath.lhs +++ b/DBus/Types/ObjectPath.lhs @@ -17,14 +17,16 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.ObjectPath - ( ObjectPath + ( -- * Object paths + ObjectPath , mkObjectPath + , mkObjectPath' , strObjectPath ) where import Data.Typeable (Typeable) import qualified Text.Parsec as P -import DBus.Types.Util (parseMaybe) +import DBus.Util (parseMaybe, mkUnsafe) \end{code} } @@ -51,6 +53,9 @@ 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 diff --git a/DBus/Types/Serial.lhs b/DBus/Types/Serial.lhs --- a/DBus/Types/Serial.lhs +++ b/DBus/Types/Serial.lhs @@ -16,16 +16,16 @@ \ignore{ \begin{code} module DBus.Types.Serial - ( Serial (..) + ( -- * Message serials + Serial (..) , nextSerial , firstSerial ) where import Data.Word (Word32) -import Data.Maybe (fromJust) import qualified DBus.Types.Atom as A import qualified DBus.Types.Containers as C -import DBus.Types.Signature (mkSignature) +import DBus.Types.Signature (mkSignature') \end{code} } @@ -42,7 +42,7 @@ toAtom (Serial x) = A.toAtom x instance C.Variable Serial where - defaultSignature _ = fromJust . mkSignature $ "u" + defaultSignature _ = mkSignature' "u" toVariant (Serial x) = C.toVariant x fromVariant = fmap Serial . C.fromVariant \end{code} diff --git a/DBus/Types/Signature.lhs b/DBus/Types/Signature.lhs --- a/DBus/Types/Signature.lhs +++ b/DBus/Types/Signature.lhs @@ -17,17 +17,19 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.Signature - ( Signature + ( -- * Signatures + Signature , Type(..) , signatureTypes , mkSignature + , mkSignature' , strSignature , typeString ) where import Data.Typeable (Typeable) import Text.Parsec (char, (<|>), many, eof) -import DBus.Types.Util (checkLength, parseMaybe) +import DBus.Util (checkLength, parseMaybe, mkUnsafe) \end{code} } @@ -99,6 +101,11 @@ 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} @@ -111,8 +118,8 @@ must go through {\tt parseSignature}. \begin{code} -data Type = - BooleanT +data Type + = BooleanT | ByteT | Int16T | UInt16T diff --git a/DBus/Types/Util.lhs b/DBus/Types/Util.lhs deleted file mode 100644 --- a/DBus/Types/Util.lhs +++ /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 . - -\clearpage -\section{Misc. utility functions} - -\ignore{ -\begin{code} -{-# OPTIONS_HADDOCK hide #-} -module DBus.Types.Util - ( checkLength - , parseMaybe - ) where - -import Text.Parsec (Parsec, parse) -\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} diff --git a/DBus/Unmarshal.lhs b/DBus/Unmarshal.lhs new file mode 100644 --- /dev/null +++ b/DBus/Unmarshal.lhs @@ -0,0 +1,312 @@ +% 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 new file mode 100644 --- /dev/null +++ b/DBus/Util.lhs @@ -0,0 +1,61 @@ +% 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,9 +15,10 @@ along with this program. If not, see . -} +import DBus.Address import DBus.Bus -import DBus.Bus.Address -import DBus.Bus.Connection +import DBus.Connection +import DBus.Constants import DBus.Message import DBus.Types @@ -62,10 +63,10 @@ addMatchMsg :: String -> MethodCall addMatchMsg match = MethodCall - (fromJust . mkObjectPath $ "/org/freedesktop/DBus") - (fromJust . mkMemberName $ "AddMatch") - (mkInterfaceName "org.freedesktop.DBus") - (mkBusName "org.freedesktop.DBus") + dbusPath + (mkMemberName' "AddMatch") + (Just dbusInterface) + (Just dbusName) Set.empty [toVariant match] diff --git a/Tests/Address.hs b/Tests/Address.hs --- a/Tests/Address.hs +++ b/Tests/Address.hs @@ -23,7 +23,7 @@ import Data.Maybe (isJust, isNothing) import Test.QuickCheck import Tests.Instances (sized') -import DBus.Bus.Address +import DBus.Address addressProperties = concat [ prop_Valid diff --git a/Tests/Containers.hs b/Tests/Containers.hs --- a/Tests/Containers.hs +++ b/Tests/Containers.hs @@ -136,7 +136,7 @@ firstType = head types sig = if length vs > 0 then variantSignature (head vs) - else fromJust . mkSignature $ "y" + else mkSignature' "y" -- A dictionary must have homogeneous key and value types prop_DictHomogeneous0 = homogeneousDict @@ -144,7 +144,7 @@ prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let dict = dictionaryFromItems kSig vSig (zip ks vs) (kSig, vSig) = if null ks - then (id &&& id) . fromJust . mkSignature $ "y" + then (id &&& id) . mkSignature' $ "y" else (atomSignature (head ks), variantSignature (head vs)) in isJust dict ==> homogeneousDict (fromJust dict) @@ -173,7 +173,7 @@ where check xs sig = forAll (return sig) $ checkEmptyArray xs checkEmptyArray xs sig = arraySignature a == sig' where - sig' = fromJust . mkSignature $ sig + sig' = mkSignature' sig a = fromJust . toArray $ xs props_EmptyDictionarySignature = @@ -187,7 +187,7 @@ where check xs sig = forAll (return sig) $ checkEmptyDict xs checkEmptyDict xs sig = dictionarySignature a == sig' where - sig' = fromJust . mkSignature $ sig + sig' = mkSignature' sig a = fromJust . toDictionary $ xs -- TODO Conversion to/from array and dictionary diff --git a/Tests/Instances.hs b/Tests/Instances.hs --- a/Tests/Instances.hs +++ b/Tests/Instances.hs @@ -19,7 +19,6 @@ import Control.Monad (replicateM) import Data.List (intercalate) -import Data.Maybe (fromJust) import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int16, Int32, Int64) import Test.QuickCheck @@ -76,16 +75,16 @@ n' <- choose (atLeast, max atLeast n) replicateM n' g -clampedSize :: Arbitrary a => Int -> Gen String -> (String -> Maybe a) -> Gen a +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 . fromJust . f $ s + else return . f $ s instance Arbitrary ObjectPath where coarbitrary = undefined - arbitrary = fmap (fromJust . mkObjectPath) path' where + arbitrary = fmap mkObjectPath' path' where c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" path = fmap (intercalate "/" . ([] :)) genElements path' = frequency [(1, return "/"), (9, path)] @@ -93,7 +92,7 @@ instance Arbitrary InterfaceName where coarbitrary = undefined - arbitrary = clampedSize 255 genName mkInterfaceName where + arbitrary = clampedSize 255 genName mkInterfaceName' where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" c' = c ++ ['0'..'9'] @@ -107,7 +106,7 @@ instance Arbitrary BusName where coarbitrary = undefined - arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName where + arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" c' = c ++ ['0'..'9'] @@ -126,7 +125,7 @@ instance Arbitrary MemberName where coarbitrary = undefined - arbitrary = clampedSize 255 genName mkMemberName where + arbitrary = clampedSize 255 genName mkMemberName' where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" c' = c ++ ['0'..'9'] @@ -137,7 +136,7 @@ instance Arbitrary ErrorName where coarbitrary = undefined - arbitrary = fmap (fromJust . mkErrorName . strInterfaceName) arbitrary + arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary instance Arbitrary Type where coarbitrary = undefined @@ -145,7 +144,7 @@ instance Arbitrary Signature where coarbitrary = undefined - arbitrary = clampedSize 255 genSig mkSignature where + arbitrary = clampedSize 255 genSig mkSignature' where genSig = fmap (concatMap typeString) arbitrary atomicType = elements @@ -249,8 +248,8 @@ ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath]) SignatureT -> fmap (map toVariant) (arbitrary :: Gen [Signature]) - let kSig = fromJust . mkSignature . typeString $ kt - let vSig = fromJust . mkSignature . typeString $ vt + let kSig = mkSignature' . typeString $ kt + let vSig = mkSignature' . typeString $ vt maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs)) instance Arbitrary Structure where diff --git a/Tests/Marshal.hs b/Tests/Marshal.hs --- a/Tests/Marshal.hs +++ b/Tests/Marshal.hs @@ -21,13 +21,12 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Lazy as L import Data.Word -import Data.Maybe (fromJust) import Test.QuickCheck import Tests.Instances () import DBus.Types -import DBus.Protocol.Marshal -import DBus.Protocol.Unmarshal +import DBus.Marshal +import DBus.Unmarshal marshalProperties :: [Property] marshalProperties = diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,5 +1,5 @@ name: dbus-core -version: 0.3 +version: 0.4 synopsis: Low-level DBus protocol implementation license: GPL license-file: License.txt @@ -16,7 +16,6 @@ Examples/*.hs Tests/*.hs Tests.hs - DBus/Types/Containers.lhs-boot source-repository head type: darcs @@ -38,22 +37,27 @@ network exposed-modules: + DBus.Address DBus.Bus - DBus.Bus.Address - DBus.Bus.Connection + DBus.Connection + DBus.Constants 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 - - other-modules: - DBus.Protocol.Authentication - DBus.Protocol.Marshal - DBus.Protocol.Unmarshal - DBus.Protocol.Padding - DBus.Types.Util + DBus.Marshal + DBus.Padding + DBus.Unmarshal + DBus.Util diff --git a/dbus-core.tex b/dbus-core.tex --- a/dbus-core.tex +++ b/dbus-core.tex @@ -46,13 +46,15 @@ \addcontentsline{toc}{section}{Contents} \tableofcontents +\input{DBus/Address.lhs} +\input{DBus/Connection.lhs} \input{DBus/Bus.lhs} -\input{DBus/Bus/Address.lhs} -\input{DBus/Bus/Connection.lhs} +\input{DBus/Internal/Authentication.lhs} \input{DBus/Types.lhs} \input{DBus/Message.lhs} -\input{DBus/Protocol/Marshal.lhs} -\input{DBus/Protocol/Unmarshal.lhs} -\input{DBus/Protocol/Padding.lhs} +\input{DBus/Internal/Marshal.lhs} +\input{DBus/Internal/Unmarshal.lhs} +\input{DBus/Internal/Padding.lhs} +\input{DBus/Util.lhs} \end{document}