diff --git a/DBus.hs b/DBus.hs --- a/DBus.hs +++ b/DBus.hs @@ -1,45 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} -import System.Posix.User import Network.DBus +import Network.DBus.Actions import Network.DBus.Message +import Network.DBus.MessageType +import Network.DBus.StdMessage import Network.DBus.Type import Network.DBus.Signature import Data.Word +import Control.Monad import Control.Monad.Trans +import Control.Concurrent -dbusDestination = "org.freedesktop.DBus" -dbusPath = "/org/freedesktop/DBus" -dbusInterface = "org.freedesktop.DBus" -mainDbus uid = withSession $ do - authenticateUID uid - let msg = msgMethodCall dbusDestination dbusPath dbusInterface "Hello" [] - messageSend msg - messageRecv - liftIO $ putStrLn "spurious" - messageRecv +main = do + con <- establish busGetSession authenticateWithRealUID + registerCall con "/" $ calltableFromList + [ ("xyz", "example.test.dbus", \s sig b -> putStrLn (show s ++ ": " ++ show b)) + ] - let msg = msgMethodCall dbusDestination dbusPath dbusInterface "ListNames" [] - messageSend msg - msg <- messageRecv - let b = readBody msg - liftIO $ putStrLn $ show b + forkIO $ forever $ do + r <- call con dbusDestination msgDBusListNames + putStrLn $ show r + threadDelay 100000000 - let msg = msgMethodCall "org.freedesktop.Notifications" "/org/freedesktop/Notifications" "org.freedesktop.Notifications" "Notify" - [ DbusString "y" - , DbusUInt32 1 - , DbusString "x" - , DbusString "this is a string" - , DbusString "this is a o----" - , DbusArray (SigString) [] - , DbusArray (SigDict SigString SigVariant) [] - , DbusInt32 4000 - ] + call con "org.freedesktop.Notifications" $ DBusCall "/org/freedesktop/Notifications" "Notify" (Just "org.freedesktop.Notifications") + [ DBusString "y" + , DBusUInt32 1 + , DBusString "x" + , DBusString "this is a string" + , DBusString "this is a o----" + , DBusArray (SigString) [] + , DBusArray (SigDict SigString SigVariant) [] + , DBusInt32 4000 + ] - liftIO $ putStrLn $ show msg - messageSend msg - msgR <- messageRecv - liftIO $ putStrLn $ show msgR -main = getRealUserID >>= mainDbus . fromIntegral + forever $ threadDelay 10000 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2011 Vincent Hanquez +Copyright (c) 2010-2013 Vincent Hanquez All rights reserved. diff --git a/Network/DBus.hs b/Network/DBus.hs --- a/Network/DBus.hs +++ b/Network/DBus.hs @@ -1,176 +1,273 @@ +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.DBus +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus - ( DBusHandle - , authenticate - , authenticateUID - - , connectSession - , connectSystem - , connectHandle - - , withContext - , withSession - , withSystem + ( + -- * handle connections to DBus + establish + , establishWithCatchall + , DBusConnection + -- * Types + , DBusMessageable(..) + , DBusCall(..) + , DBusReturn(..) + , DBusError(..) + , DBusSignal(..) + , DBusValue(..) + , DBusTypeable(..) + , ObjectPath(..) + , PackedString(..) + , packedStringToString + , Type(..) + , Signature + , SignatureElem + , DBusMatchRules(..) + , defaultDBusMatchRules + , MessageType(..) + , BusName(..) + , ErrorName(..) + , Member(..) + , Interface(..) + -- * standard way to interact with dbus + , addMatch + -- * main loop creation + , runMainLoop + , runMainLoopCatchall + -- * interact with the connection + , call + , reply + , calltableFromList + , registerPath + , unregisterPath + , registerCall + , unregisterCall + , registerSignal + , unregisterSignal + -- * create a new context on system or session bus + , busGetSystem + , busGetSession + -- * authenticate methods available + , authenticate + , authenticateUID + , authenticateWithRealUID + ) where - , messageSend - , messageRecv +import Network.DBus.Actions +import Network.DBus.Message +import Network.DBus.MessageType +import Network.DBus.StdMessage +import Control.Concurrent (forkIO, ThreadId) +import Control.Concurrent.MVar +import Control.Exception +import Data.Maybe +import Control.Monad +import qualified Data.Map as M +import Data.List (intercalate) +import System.Posix.User (getRealUserID) - -- * from Message module - , MessageType(..) - , MessageFlag(..) - , Field(..) - , Message(..) - , Serial - , msgMethodCall - , msgMethodReturn - , msgError - , msgSignal +type MessageVar = MVar DBusMessage - -- * read a message body - , readBody - , readBodyWith +newMessageVar = newEmptyMVar - -- * from Signature module - , SignatureElem(..) - , Signature +type Signalback = BusName -> Signature -> Body -> IO () +type Callback = Serial -> Signature -> Body -> IO () +type DispatchTable a = M.Map Member [(Interface, a)] - -- * from Type module - , ObjectPath - , DbusType(..) - ) where +calltableFromList :: [ (Member, Interface, a) ] -> DispatchTable a +calltableFromList = foldl f M.empty where + f acc (member, intf, callback) = M.alter (appendOrCreate intf callback) member acc + appendOrCreate intf callback Nothing = Just [(intf,callback)] + appendOrCreate intf callback (Just l) = Just ((intf,callback) : l) -import Numeric (showHex) -import Data.Char (ord) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L +-- | opaque type representing a connection to DBus and a receiving dispatcher thread. +-- maintain table to route message between handlers. +data DBusConnection = DBusConnection + { connectionContext :: DBusContext + , connectionSendLock :: MVar () + , connectionCallbacks :: MVar (M.Map Serial MessageVar) + , connectionPaths :: MVar (M.Map ObjectPath (DispatchTable Callback)) + , connectionSignals :: MVar (M.Map ObjectPath (DispatchTable Signalback)) + , connectionDefaultCallback :: DBusMessage -> IO () + , connectionMainLoop :: MVar ThreadId + } -import Control.Arrow -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.State +data DBusMatchRules = DBusMatchRules + { matchType :: Maybe MessageType + , matchSender :: Maybe BusName + , matchInterface :: Maybe Interface + , matchMember :: Maybe Member + , matchPath :: Maybe ObjectPath + , matchDestination :: Maybe BusName + } -import System.Environment -import System.IO hiding (hGetLine) -import Network.Socket -import Network.DBus.Message -import Network.DBus.Type -import Network.DBus.Signature +defaultDBusMatchRules = DBusMatchRules Nothing Nothing Nothing Nothing Nothing Nothing --- | Represent an open access to dbus. for now only based on system handle. -newtype DBusHandle = DBusHandle Handle +sendLock con f = withMVar (connectionSendLock con) $ \() -> f -type DBusContext a = StateT (DBusHandle, Serial) IO a +-- | Establish a new connection to dbus, using the two functions to +-- first establish a new context, and second to authenticate to the bus. +-- this will automatically create a mainloop thread. +establish :: IO DBusContext -- ^ function to create a new dbus context (busGetSystem or busGetSession) + -> (DBusContext -> IO ()) -- ^ function to authenticate to dbus + -> IO DBusConnection +establish createContext auth = do + ctx <- createContext + auth ctx + runMainLoop ctx -withHandle :: (Handle -> IO a) -> DBusContext a -withHandle f = do - (DBusHandle h) <- fst <$> get - liftIO (f h) +establishWithCatchall catchall createContext auth = do + ctx <- createContext + _ <- auth ctx + runMainLoopCatchall catchall ctx -hGet :: Int -> DBusContext ByteString -hGet i = withHandle (\h -> BC.hGet h i) +call :: DBusConnection -> BusName -> DBusCall -> IO DBusReturn +call con destination c = do + let msg = messageMapFields (fieldsSetDestination destination) $ toDBusMessage c + mvar <- sendLock con $ do + serial <- busGetNextSerial (connectionContext con) + mvar <- registerCallback con serial + messageSendWithSerial (connectionContext con) serial msg + return mvar + result <- takeMVar mvar + case msgType result of + TypeError -> + case errorFromDBusMessage result of + Nothing -> throwIO invalidException + Just err -> throwIO err + TypeMethodReturn -> + case fromDBusMessage result of + Nothing -> throwIO invalidException + Just ret -> return ret + _ -> throwIO invalidException + where + invalidException = DBusError 0 "org.freedesktop.dbus.invalidpacket" + [DBusString "invalid packet received. missing fields"] + errorFromDBusMessage :: DBusMessage -> Maybe DBusError + errorFromDBusMessage = fromDBusMessage -hPut :: ByteString -> DBusContext () -hPut b = withHandle (\h -> BC.hPut h b) +addMatch :: DBusConnection -> DBusMatchRules -> IO () +addMatch con mr = call con dbusDestination (msgDBusAddMatch serialized) >> return () + where + serialized = intercalate "," $ filter (not . null) + [ mm "type" show $ matchType mr + , mm "sender" unBusName $ matchSender mr + , mm "interface" unInterface $ matchInterface mr + , mm "member" unMember $ matchMember mr + , mm "path" unObjectPath $ matchPath mr + , mm "destination" unBusName $ matchDestination mr + ] + mm key f = maybe "" (surroundQuote key . f) + surroundQuote key v = concat [ key, "='", v, "'" ] -hPuts :: [ByteString] -> DBusContext () -hPuts bs = withHandle (\h -> L.hPut h $ L.fromChunks bs) +reply con rep = do + let msg = toDBusMessage rep + sendLock con $ messageSend (connectionContext con) msg -hGetLine :: DBusContext () -hGetLine = withHandle BC.hGetLine >> return () +registerCallback con serial = do + mvar <- newMessageVar + modifyMVar_ (connectionCallbacks con) (return . M.insert serial mvar) + return mvar -authenticateUID :: Int -> DBusContext () -authenticateUID uid = authenticate hexencoded_uid - where - hexencoded_uid = BC.pack $ concatMap (hex2 . ord) $ show uid - hex2 a - | a < 0x10 = "0" ++ showHex a "" - | otherwise = showHex a "" +registerPath_ f con path callTable = + modifyMVar_ (f con) (return . M.insert path callTable) +unregisterPath_ f con path = + modifyMVar_ (f con) (return . M.delete path) -authenticate :: ByteString -> DBusContext () -authenticate auth = do - hPut $ BC.concat ["\0AUTH EXTERNAL ", auth, "\r\n"] - _ <- hGetLine - hPut "BEGIN\r\n" +registerCall = registerPath_ connectionPaths +unregisterCall = unregisterPath_ connectionPaths -close :: DBusHandle -> IO () -close (DBusHandle h) = hClose h +{-# DEPRECATED registerPath "use registerCall" #-} +registerPath = registerPath_ connectionPaths +{-# DEPRECATED unregisterPath "use unregisterCall" #-} +unregisterPath = unregisterPath_ connectionPaths -connectUnix :: ByteString -> IO DBusHandle -connectUnix addr = do - let sockaddr = SockAddrUnix $ BC.unpack addr - sock <- socket AF_UNIX Stream 0 - connect sock sockaddr - h <- socketToHandle sock ReadWriteMode - hSetBuffering h NoBuffering - return $ DBusHandle h +registerSignal = registerPath_ connectionSignals +unregisterSignal = unregisterPath_ connectionSignals -connectOver :: ByteString -> [(ByteString, ByteString)] -> IO DBusHandle -connectOver "unix" flags = do - let abstract = lookup "abstract" flags - case abstract of - Nothing -> error "no abstract path, use the normal path ..." - Just path -> connectUnix $ BC.concat ["\x00", path] +runMainLoop = runMainLoopCatchall (\_ -> return ()) -connectOver _ _ = do - error "not implemented yet" +runMainLoopCatchall catchAll context = do + callbacks <- newMVar M.empty + callPaths <- newMVar M.empty + signalPaths <- newMVar M.empty + mainloopPid <- newEmptyMVar + sendLockVar <- newMVar () -connectSessionAt :: ByteString -> IO DBusHandle -connectSessionAt addr = do - let (domain, flagstr) = second BC.tail $ BC.breakSubstring ":" addr - let flags = map (\x -> let (k:v:[]) = BC.split '=' x in (k,v)) $ BC.split ',' flagstr - connectOver domain flags + let con = DBusConnection + { connectionContext = context + , connectionCallbacks = callbacks + , connectionPaths = callPaths + , connectionSignals = signalPaths + , connectionDefaultCallback = catchAll + , connectionMainLoop = mainloopPid + , connectionSendLock = sendLockVar + } + pid <- forkIO (dispatcher con) + putMVar mainloopPid pid --- | connect to the dbus session bus define by the environment variable DBUS_SESSION_BUS_ADDRESS -connectSession :: IO DBusHandle -connectSession = BC.pack <$> getEnv "DBUS_SESSION_BUS_ADDRESS" >>= connectSessionAt + _ <- call con dbusDestination msgDBusHello + return con --- | connect to the dbus system bus -connectSystem :: IO DBusHandle -connectSystem = connectUnix "/var/run/dbus/system_bus_socket" +dispatcher con = forever loop where + loop = do + msg <- messageRecv (connectionContext con) + fallback <- dispatch msg + when fallback $ notifyUser msg + dispatch msg@(msgType -> TypeMethodCall) = callCallback msg + dispatch msg@(msgType -> TypeSignal) = signalCallback msg + dispatch msg@(msgType -> TypeMethodReturn) = withReply msg + dispatch msg@(msgType -> TypeError) = withReply msg + dispatch _ = return False --- | connect onto a previously open handle -connectHandle :: Handle -> IO DBusHandle -connectHandle h = return $ DBusHandle h + withReply (fieldsReplySerial . msgFields -> Nothing) = return False + withReply msg@(fieldsReplySerial . msgFields -> Just serial) = do + callback <- modifyMVar (connectionCallbacks con) $ \m -> + case M.lookup serial m of + Just c -> return (M.delete serial m, Just c) + Nothing -> return (m, Nothing) + case callback of + Nothing -> return True + Just c -> putMVar c msg >> return False + withReply _ = return False --- | create a new Dbus context from a ini function to create a dbusHandle. -withContext :: IO DBusHandle -> DBusContext a -> IO a -withContext ini f = bracket ini Network.DBus.close (\h -> evalStateT f (h,1)) + callCallback msg@(msgFields -> fields) = + case (fieldsPath fields, fieldsMember fields) of + (Just path, Just member) -> do + calltables <- readMVar (connectionPaths con) + let mcallback = findDispatchTable calltables path member (fieldsInterface fields) + case mcallback of + Nothing -> return True + Just c -> c (msgSerial msg) (fieldsSignature fields) (readBody msg) >> return False + -- method call is not valid, so just ignore + _ -> return False --- | create a new Dbus context on session bus -withSession :: DBusContext a -> IO a -withSession = withContext connectSession + signalCallback msg@(msgFields -> fields) = + case (fieldsPath fields, fieldsMember fields) of + (Just path, Just member) -> do + signaltables <- readMVar (connectionSignals con) + let mcallback = findDispatchTable signaltables path member (fieldsInterface fields) + case mcallback of + Nothing -> return True + Just c -> c (fromJust $ fieldsSender fields) (fieldsSignature fields) (readBody msg) >> return False + -- signal is not valid, so just ignore + _ -> return False --- | create a new Dbus context on system bus -withSystem :: DBusContext a -> IO a -withSystem = withContext connectSystem + findDispatchTable table path member intf = M.lookup path table >>= M.lookup member >>= getCall where + getCall callbackList = case intf of + Nothing -> safeHead $ map snd callbackList + Just i -> lookup i callbackList --- | send one message to the bus --- note that the serial of the message sent is allocated here. -messageSend :: Message -> DBusContext Serial -messageSend msg = do - serial <- snd <$> get - modify (\(h,_) -> (h, serial+1)) - let fieldstr = writeFields (msgFields msg) - let fieldlen = BC.length fieldstr - let alignfields = alignVal 8 fieldlen - fieldlen - let header = (headerFromMessage msg) - { headerBodyLength = BC.length $ msgBody msg - , headerFieldsLength = fieldlen - , headerSerial = serial } - hPuts [ writeHeader header, fieldstr, BC.replicate alignfields '\0', msgBody msg ] - return serial + safeHead [] = Nothing + safeHead (x:_) = Just x --- | receive one single message from the bus --- it is not necessarily the reply from a previous sent message. -messageRecv :: DBusContext Message -messageRecv = do - hdr <- readHeader <$> hGet 16 - fields <- readFields <$> hGet (alignVal 8 $ headerFieldsLength hdr) - body <- hGet (headerBodyLength hdr) - return $ (messageFromHeader hdr) { msgFields = fields, msgBody = body } + notifyUser = connectionDefaultCallback con -alignVal :: Int -> Int -> Int -alignVal n x - | x `mod` n == 0 = x - | otherwise = x + (n - (x `mod` n)) +-- | use the real user UID to authenticate to DBus. +authenticateWithRealUID :: DBusContext -> IO () +authenticateWithRealUID ctx = getRealUserID >>= authenticateUID ctx . fromIntegral diff --git a/Network/DBus/Actions.hs b/Network/DBus/Actions.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Actions.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.DBus.Actions +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.DBus.Actions + ( DBusContext + , DBusTransport(..) + , authenticate + , authenticateUID + + , connectSession + , connectSystem + , contextNew + , contextNewWith + + , busGetSession + , busGetSystem + , busGetNextSerial + , busClose + + , messageSend + , messageSendWithSerial + , messageRecv + + -- * from Message module + , MessageType(..) + , MessageFlag(..) + , DBusFields(..) + , DBusMessage(..) + , Serial + + -- * read a message body + , readBody + , readBodyWith + + -- * from Signature module + , Type(..) + , SignatureElem + , Signature + , serializeSignature + , unserializeSignature + + -- * from Type module + , ObjectPath(..) + , PackedString(..) + , packedStringToString + , DBusValue(..) + , DBusTypeable(..) + ) where + +import Numeric (showHex) +import Data.Char (ord) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BC + +import Control.Arrow +import Control.Applicative ((<$>)) +import Control.Concurrent +import Control.Monad.State + +import System.Environment +import System.IO hiding (hGetLine) +import Network.Socket +import Network.DBus.Message +import Network.DBus.Type +import Network.DBus.Internal +import Network.DBus.Signature + +data DBusTransport = DBusTransport + { transportGet :: Int -> IO ByteString + , transportPut :: ByteString -> IO () + , transportClose :: IO () + } + +data DBusContext = DBusContext + { contextTransport :: DBusTransport + , contextSerial :: MVar Serial + } + +withTransport :: DBusContext -> (DBusTransport -> IO a) -> IO a +withTransport ctx f = f $ contextTransport ctx + +transportHandle :: Handle -> DBusTransport +transportHandle h = DBusTransport + { transportGet = BC.hGet h + , transportPut = BC.hPut h + , transportClose = hClose h + } + +hGet :: DBusContext -> Int -> IO ByteString +hGet ctx i = withTransport ctx (\t -> transportGet t i) + +hPut :: DBusContext -> ByteString -> IO () +hPut ctx b = withTransport ctx (\t -> transportPut t b) + +hPuts :: DBusContext -> [ByteString] -> IO () +hPuts ctx bs = withTransport ctx (\t -> mapM_ (transportPut t) bs) + +hGetLine :: DBusContext -> IO () +hGetLine ctx = withTransport ctx getTillEOL + where getTillEOL transport = do + v <- transportGet transport 1 + if BC.singleton '\n' == v then return () else getTillEOL transport + +-- | authenticate to DBus using a UID. +authenticateUID :: DBusContext -> Int -> IO () +authenticateUID ctx uid = authenticate ctx hexencoded_uid + where hexencoded_uid = BC.pack $ concatMap (hex2 . ord) $ show uid + hex2 a + | a < 0x10 = '0' : showHex a "" + | otherwise = showHex a "" + +-- | authenticate to DBus using a raw bytestring. +authenticate :: DBusContext -> ByteString -> IO () +authenticate ctx auth = do + hPut ctx $ BC.concat ["\0AUTH EXTERNAL ", auth, "\r\n"] + _ <- hGetLine ctx + hPut ctx "BEGIN\r\n" + +close :: DBusTransport -> IO () +close = transportClose + +connectUnix :: ByteString -> IO Handle +connectUnix addr = do + let sockaddr = SockAddrUnix $ BC.unpack addr + sock <- socket AF_UNIX Stream 0 + connect sock sockaddr + h <- socketToHandle sock ReadWriteMode + hSetBuffering h NoBuffering + return h + +connectOver :: ByteString -> [(ByteString, ByteString)] -> IO Handle +connectOver "unix" flags = do + let abstract = lookup "abstract" flags + case abstract of + Nothing -> error "no abstract path, use the normal path ..." + Just path -> connectUnix $ BC.concat ["\x00", path] + +connectOver _ _ = error "not implemented yet" + +connectSessionAt :: ByteString -> IO Handle +connectSessionAt addr = do + let (domain, flagstr) = second BC.tail $ BC.breakSubstring ":" addr + let flags = map (\x -> let (k:v:[]) = BC.split '=' x in (k,v)) $ BC.split ',' flagstr + connectOver domain flags + +-- | connect to the dbus session bus define by the environment variable DBUS_SESSION_BUS_ADDRESS +connectSession :: IO Handle +connectSession = BC.pack <$> getEnv "DBUS_SESSION_BUS_ADDRESS" >>= connectSessionAt + +-- | connect to the dbus system bus +connectSystem :: IO Handle +connectSystem = connectUnix "/var/run/dbus/system_bus_socket" + +-- | create a new DBus context from an handle +contextNew :: Handle -> IO DBusContext +contextNew h = contextNewWith (transportHandle h) + +-- | create a new DBus context from a transport +contextNewWith :: DBusTransport -> IO DBusContext +contextNewWith transport = liftM (DBusContext transport) (newMVar 1) + +-- | create a new DBus context on session bus +busGetSession :: IO DBusContext +busGetSession = connectSession >>= contextNew + +-- | create a new DBus context on system bus +busGetSystem :: IO DBusContext +busGetSystem = connectSystem >>= contextNew + +-- | close this DBus context +busClose :: DBusContext -> IO () +busClose = transportClose . contextTransport + +-- | get the next serial usable, and increment the serial state. +busGetNextSerial :: DBusContext -> IO Serial +busGetNextSerial ctx = + modifyMVar (contextSerial ctx) (\v -> return $! (v+1, v)) + +-- | send one message to the bus with a predefined serial number. +messageSendWithSerial :: DBusContext -> Serial -> DBusMessage -> IO () +messageSendWithSerial ctx serial msg = do + let fieldstr = writeFields (msgFields msg) + let fieldlen = BC.length fieldstr + let alignfields = alignVal 8 fieldlen - fieldlen + let header = (headerFromMessage msg) + { headerBodyLength = BC.length $ msgBodyRaw msg + , headerFieldsLength = fieldlen + , headerSerial = serial } + hPuts ctx [ writeHeader header, fieldstr, BC.replicate alignfields '\0', msgBodyRaw msg ] + +-- | send one message to the bus +-- note that the serial of the message sent is allocated here. +messageSend :: DBusContext -> DBusMessage -> IO Serial +messageSend ctx msg = do + serial <- busGetNextSerial ctx + messageSendWithSerial ctx serial msg + return serial + +-- | receive one single message from the bus +-- it is not necessarily the reply from a previous sent message. +messageRecv :: DBusContext -> IO DBusMessage +messageRecv ctx = do + hdr <- readHeader <$> hGet ctx 16 + fields <- readFields (headerEndian hdr) <$> hGet ctx (alignVal 8 $ headerFieldsLength hdr) + body <- hGet ctx (headerBodyLength hdr) + return $ (messageFromHeader hdr) { msgFields = fields, msgBodyRaw = body } + +alignVal :: Int -> Int -> Int +alignVal n x + | x `mod` n == 0 = x + | otherwise = x + (n - (x `mod` n)) diff --git a/Network/DBus/IEEE754.hs b/Network/DBus/IEEE754.hs --- a/Network/DBus/IEEE754.hs +++ b/Network/DBus/IEEE754.hs @@ -1,4 +1,11 @@ {-# LANGUAGE MagicHash #-} +-- | +-- Module : Network.DBus.IEEE754 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus.IEEE754 (encode, decode) where import GHC.Prim diff --git a/Network/DBus/Internal.hs b/Network/DBus/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Internal.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Network.DBus.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- + +module Network.DBus.Internal + ( ObjectPath(..) + , PackedString(..) + , packedStringToString + ) where + +import Data.Data +import Data.String +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +newtype ObjectPath = ObjectPath { unObjectPath :: String } + deriving (Show,Eq,Ord,Data,Typeable) +instance IsString ObjectPath where + fromString = ObjectPath + +newtype PackedString = PackedString { ustringToBS :: ByteString } + deriving (Eq,Ord,Data,Typeable) +instance IsString PackedString where + fromString = PackedString . UTF8.fromString +instance Show PackedString where + show = show . packedStringToString +packedStringToString = UTF8.toString . ustringToBS diff --git a/Network/DBus/Message.hs b/Network/DBus/Message.hs --- a/Network/DBus/Message.hs +++ b/Network/DBus/Message.hs @@ -1,299 +1,328 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Network.DBus.Message +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus.Message - ( - MessageType(..) - , MessageFlag(..) - , Header(..) - , Field(..) - , Message(..) - , Serial - -- * create new message - , msgMethodCall - , msgMethodReturn - , msgError - , msgSignal - -- * Parsing and serializing functions - , headerFromMessage - , messageFromHeader - , readHeader - , writeHeader - , readFields - , writeFields - , readBody - , readBodyWith - ) where + ( + MessageType(..) + , MessageFlag(..) + -- * Serializing header for message + , DBusHeader(..) + -- * Fields type and accessor + , DBusFields(..) + , fieldsNew + , fieldsNewWithBody + , fieldsSetPath + , fieldsSetInterface + , fieldsSetMember + , fieldsSetErrorName + , fieldsSetReplySerial + , fieldsSetDestination + , fieldsSetSender + , fieldsSetSignature + , fieldsSetUnixFD + -- * Message type + , DBusMessage(..) + , BusName(..) + , Body + , Serial + , ErrorName(..) + , Member(..) + , Interface(..) + , messageNew + , messageMapFields + -- * Parsing and serializing functions + , headerFromMessage + , messageFromHeader + , readHeader + , writeHeader + , readFields + , writeFields + , writeBody + , readBody + , readBodyWith + , readBodyRaw + ) where +import Data.Data import Data.Word +import Data.String import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Control.Applicative ((<$>)) import Control.Monad.State +import Network.DBus.Internal import Network.DBus.Wire import Network.DBus.Type import Network.DBus.Signature -- | dbus message types data MessageType = - TypeInvalid - | TypeMethodCall - | TypeMethodReturn - | TypeError - | TypeSignal - deriving (Show,Eq,Enum) + TypeInvalid + | TypeMethodCall + | TypeMethodReturn + | TypeError + | TypeSignal + deriving (Eq,Enum) +instance Show MessageType where + show TypeInvalid = "invalid" + show TypeMethodCall = "method_call" + show TypeMethodReturn = "method_return" + show TypeError = "error" + show TypeSignal = "signal" + -- | dbus message flags data MessageFlag = - FlagNoReplyExpected - | FlagNoAutoStart - deriving (Show,Eq) + FlagNoReplyExpected + | FlagNoAutoStart + deriving (Show,Eq) -- | dbus serial number type Serial = Word32 -data Header = Header - { headerEndian :: DbusEndian - , headerMessageType :: !MessageType - , headerVersion :: !Int - , headerFlags :: !Int - , headerBodyLength :: !Int - , headerSerial :: !Serial - , headerFieldsLength :: !Int - } deriving (Show,Eq) +data DBusHeader = DBusHeader + { headerEndian :: DBusEndian + , headerMessageType :: !MessageType + , headerVersion :: !Int + , headerFlags :: !Int + , headerBodyLength :: !Int + , headerSerial :: !Serial + , headerFieldsLength :: !Int + } deriving (Show,Eq) -type Body = [DbusType] +type BodyRaw = (Signature,ByteString) +type Body = [DBusValue] -type Interface = ByteString -type Member = ByteString -type BusName = ByteString -type ErrorName = ByteString +newtype Interface = Interface { unInterface :: String } + deriving (Show,Eq,Ord) +newtype Member = Member { unMember :: String } + deriving (Show,Eq,Ord) +newtype BusName = BusName { unBusName :: String } + deriving (Show,Eq,Ord) +newtype ErrorName = ErrorName { unErrorName :: String } + deriving (Show,Eq,Ord,Data,Typeable) -data Field = - FieldPath ObjectPath - | FieldInterface Interface - | FieldMember Member - | FieldErrorName ErrorName - | FieldReplySerial Serial - | FieldDestination BusName - | FieldSender ByteString - | FieldSignature Signature - | FieldUnixFds Word32 - deriving (Show,Eq) +instance IsString Interface where + fromString = Interface -fieldVal :: Field -> Int -fieldVal (FieldPath _) = 1 -fieldVal (FieldInterface _) = 2 -fieldVal (FieldMember _) = 3 -fieldVal (FieldErrorName _) = 4 -fieldVal (FieldReplySerial _) = 5 -fieldVal (FieldDestination _) = 6 -fieldVal (FieldSender _) = 7 -fieldVal (FieldSignature _) = 8 -fieldVal (FieldUnixFds _) = 9 - -data Message = Message - { msgEndian :: DbusEndian - , msgType :: !MessageType - , msgVersion :: !Int - , msgFlags :: !Int - , msgSerial :: !Serial - , msgFields :: [Field] - , msgBody :: ByteString - } deriving (Show,Eq) +instance IsString Member where + fromString = Member -defaultMessage :: Message -defaultMessage = Message - { msgEndian = LE - , msgType = TypeInvalid - , msgVersion = 1 - , msgFlags = 0 - , msgSerial = 0 - , msgFields = [] - , msgBody = B.empty - } +instance IsString BusName where + fromString = BusName -headerFromMessage :: Message -> Header -headerFromMessage msg = Header - { headerEndian = msgEndian msg - , headerMessageType = msgType msg - , headerVersion = msgVersion msg - , headerFlags = msgFlags msg - , headerBodyLength = 0 - , headerSerial = msgSerial msg - , headerFieldsLength = 0 - } +instance IsString ErrorName where + fromString = ErrorName -messageFromHeader :: Header -> Message -messageFromHeader hdr = Message - { msgEndian = headerEndian hdr - , msgType = headerMessageType hdr - , msgVersion = headerVersion hdr - , msgFlags = headerFlags hdr - , msgSerial = headerSerial hdr - , msgFields = [] - , msgBody = B.empty - } +type UnixFD = Word32 --- | create a new method call message -msgMethodCall :: BusName -> ObjectPath -> Interface -> Member -> Body -> Message -msgMethodCall destination path interface method body = defaultMessage - { msgType = TypeMethodCall - , msgFields = - [ FieldPath path - , FieldDestination destination - , FieldInterface interface - , FieldMember method - ] ++ if null body then [] else [ FieldSignature $ signatureBody body ] - , msgBody = writeBody body - } +data DBusFields = DBusFields + { fieldsPath :: Maybe ObjectPath + , fieldsInterface :: Maybe Interface + , fieldsMember :: Maybe Member + , fieldsErrorName :: Maybe ErrorName + , fieldsReplySerial :: Maybe Serial + , fieldsDestination :: Maybe BusName + , fieldsSender :: Maybe BusName + , fieldsSignature :: Signature + , fieldsUnixFD :: Maybe UnixFD + } deriving (Show,Eq) --- | create a new signal message -msgSignal :: ObjectPath -> Interface -> Member -> Body -> Message -msgSignal path interface method body = defaultMessage - { msgType = TypeSignal - , msgFields = - [ FieldPath path - , FieldInterface interface - , FieldMember method - ] ++ if null body then [] else [ FieldSignature $ signatureBody body ] - , msgBody = writeBody body - } +data DBusMessage = DBusMessage + { msgEndian :: DBusEndian + , msgType :: !MessageType + , msgVersion :: !Int + , msgFlags :: !Int + , msgSerial :: !Serial + , msgFields :: DBusFields + , msgBodyRaw :: ByteString + } deriving (Show,Eq) --- | create a new method return message -msgMethodReturn :: Serial -> Body -> Message -msgMethodReturn replySerial body = defaultMessage - { msgType = TypeMethodReturn - , msgFields = - [ FieldReplySerial replySerial - ] ++ if null body then [] else [ FieldSignature $ signatureBody body ] - , msgBody = writeBody body - } +fieldsSetPath :: ObjectPath -> DBusFields -> DBusFields +fieldsSetPath v fields = fields { fieldsPath = Just v } --- | create a new error message -msgError :: ErrorName -> Serial -> Body -> Message -msgError errorName replySerial body = defaultMessage - { msgType = TypeError - , msgFields = - [ FieldErrorName errorName - , FieldReplySerial replySerial - ] ++ if null body then [] else [ FieldSignature $ signatureBody body ] - , msgBody = writeBody body - } +fieldsSetInterface :: Interface -> DBusFields -> DBusFields +fieldsSetInterface v fields = fields { fieldsInterface = Just v } +fieldsSetMember :: Member -> DBusFields -> DBusFields +fieldsSetMember v fields = fields { fieldsMember = Just v } + +fieldsSetErrorName :: ErrorName -> DBusFields -> DBusFields +fieldsSetErrorName v fields = fields { fieldsErrorName = Just v } + +fieldsSetReplySerial :: Serial -> DBusFields -> DBusFields +fieldsSetReplySerial v fields = fields { fieldsReplySerial = Just v } + +fieldsSetDestination :: BusName -> DBusFields -> DBusFields +fieldsSetDestination v fields = fields { fieldsDestination = Just v } + +fieldsSetSender :: BusName -> DBusFields -> DBusFields +fieldsSetSender v fields = fields { fieldsSender = Just v } + +fieldsSetSignature :: Signature -> DBusFields -> DBusFields +fieldsSetSignature v fields = fields { fieldsSignature = v } + +fieldsSetUnixFD :: UnixFD -> DBusFields -> DBusFields +fieldsSetUnixFD v fields = fields { fieldsUnixFD = Just v } + +fieldsNew = DBusFields Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing + +fieldsNewWithBody body = fieldsNew { fieldsSignature = if null body then [] else signatureBody body } + +messageNew :: MessageType -> Body -> (DBusFields -> DBusFields) -> DBusMessage +messageNew ty body fieldsSetter = DBusMessage + { msgEndian = LE + , msgType = ty + , msgVersion = 1 + , msgFlags = 0 + , msgSerial = 0 + , msgFields = fieldsSetter $ fieldsNewWithBody body + , msgBodyRaw = writeBody body + } + +messageMapFields :: (DBusFields -> DBusFields) -> DBusMessage -> DBusMessage +messageMapFields f msg = msg { msgFields = f $ msgFields msg } + +headerFromMessage :: DBusMessage -> DBusHeader +headerFromMessage msg = DBusHeader + { headerEndian = msgEndian msg + , headerMessageType = msgType msg + , headerVersion = msgVersion msg + , headerFlags = msgFlags msg + , headerBodyLength = 0 + , headerSerial = msgSerial msg + , headerFieldsLength = 0 + } + +messageFromHeader :: DBusHeader -> DBusMessage +messageFromHeader hdr = DBusMessage + { msgEndian = headerEndian hdr + , msgType = headerMessageType hdr + , msgVersion = headerVersion hdr + , msgFlags = headerFlags hdr + , msgSerial = headerSerial hdr + , msgFields = fieldsNew + , msgBodyRaw = B.empty + } + -- | unserialize a dbus header (16 bytes) -readHeader :: ByteString -> Header -readHeader b = getWire LE 0 getHeader b - where getHeader = do - e <- getw8 - let bswap32 = id -- FIXME - let swapf = if fromIntegral e /= fromEnum 'l' then bswap32 else id - mt <- toEnum . fromIntegral <$> getw8 - flags <- fromIntegral <$> getw8 - ver <- fromIntegral <$> getw8 - blen <- fromIntegral . swapf <$> getw32 - serial <- swapf <$> getw32 - flen <- fromIntegral . swapf <$> getw32 +readHeader :: ByteString -> DBusHeader +readHeader b = getWire endianness 1 getHeader remainingBytes where + (firstByte,remainingBytes) = B.splitAt 1 b + endianness = if (fromIntegral $ B.head firstByte) /= fromEnum 'l' then BE else LE + getHeader = do + mt <- toEnum . fromIntegral <$> getw8 + flags <- fromIntegral <$> getw8 + ver <- fromIntegral <$> getw8 + blen <- fromIntegral <$> getw32 + serial <- getw32 + flen <- fromIntegral <$> getw32 - return $! Header - { headerEndian = if fromIntegral e /= fromEnum 'l' then BE else LE - , headerMessageType = mt - , headerVersion = ver - , headerFlags = flags - , headerBodyLength = blen - , headerSerial = serial - , headerFieldsLength = flen - } + return DBusHeader + { headerEndian = endianness + , headerMessageType = mt + , headerVersion = ver + , headerFlags = flags + , headerBodyLength = blen + , headerSerial = serial + , headerFieldsLength = flen + } -- | serialize a dbus header -writeHeader :: Header -> ByteString +writeHeader :: DBusHeader -> ByteString writeHeader hdr = putWire [putHeader] - where putHeader = do - putw8 $ fromIntegral $ fromEnum $ if headerEndian hdr == BE then 'b' else 'l' - putw8 $ fromIntegral $ fromEnum $ headerMessageType hdr - putw8 $ fromIntegral $ headerFlags hdr - putw8 $ fromIntegral $ headerVersion hdr - putw32 $ fromIntegral $ headerBodyLength hdr - putw32 $ fromIntegral $ headerSerial hdr - putw32 $ fromIntegral $ headerFieldsLength hdr + where putHeader = do + putw8 $ fromIntegral $ fromEnum $ if headerEndian hdr == BE then 'B' else 'l' + putw8 $ fromIntegral $ fromEnum $ headerMessageType hdr + putw8 $ fromIntegral $ headerFlags hdr + putw8 $ fromIntegral $ headerVersion hdr + putw32 $ fromIntegral $ headerBodyLength hdr + putw32 $ fromIntegral $ headerSerial hdr + putw32 $ fromIntegral $ headerFieldsLength hdr -- | unserialize dbus message fields -readFields :: ByteString -> [Field] -readFields b = getWire LE 16 getFields b - where - getFields :: GetWire [Field] - getFields = isWireEmpty >>= \empty -> if empty then return [] else liftM2 (:) getField getFields +readFields :: DBusEndian -> ByteString -> DBusFields +readFields endianness = getWire endianness 16 (getFields fieldsNew) + where + getFields :: DBusFields -> GetWire DBusFields + getFields fields = isWireEmpty >>= \empty -> if empty then return fields else getField fields >>= getFields - getField :: GetWire Field - getField = do - ty <- fromIntegral <$> getw8 - signature <- getVariant - when (getSigVal ty /= signature) $ error "field type invalid" - t <- getFieldVal ty - alignRead 8 - return t + getField :: DBusFields -> GetWire DBusFields + getField fields = do + ty <- fromIntegral <$> getw8 + signature <- getVariant + when (getSigVal ty /= signature) $ error "field type invalid" + setter <- getFieldVal ty + alignRead 8 + return (setter fields) - getSigVal 1 = SigObjectPath - getSigVal 2 = SigString - getSigVal 3 = SigString - getSigVal 4 = SigString - getSigVal 5 = SigUInt32 - getSigVal 6 = SigString - getSigVal 7 = SigString - getSigVal 8 = SigSignature - getSigVal 9 = SigUnixFD - getSigVal n = error ("unknown field: " ++ show n) + getSigVal 1 = SigObjectPath + getSigVal 2 = SigString + getSigVal 3 = SigString + getSigVal 4 = SigString + getSigVal 5 = SigUInt32 + getSigVal 6 = SigString + getSigVal 7 = SigString + getSigVal 8 = SigSignature + getSigVal 9 = SigUnixFD + getSigVal n = error ("unknown field: " ++ show n) - getFieldVal :: Int -> GetWire Field - getFieldVal 1 = FieldPath <$> getObjectPath - getFieldVal 2 = FieldInterface <$> getString - getFieldVal 3 = FieldMember <$> getString - getFieldVal 4 = FieldErrorName <$> getString - getFieldVal 5 = FieldReplySerial <$> getw32 - getFieldVal 6 = FieldDestination <$> getString - getFieldVal 7 = FieldSender <$> getString - getFieldVal 8 = FieldSignature <$> getSignature - getFieldVal 9 = FieldUnixFds <$> getw32 - getFieldVal n = error ("unknown field: " ++ show n) - + getFieldVal :: Int -> GetWire (DBusFields -> DBusFields) + getFieldVal 1 = fieldsSetPath <$> getObjectPath + getFieldVal 2 = fieldsSetInterface . fromString . packedStringToString <$> getString + getFieldVal 3 = fieldsSetMember . fromString . packedStringToString <$> getString + getFieldVal 4 = fieldsSetErrorName . fromString . packedStringToString <$> getString + getFieldVal 5 = fieldsSetReplySerial <$> getw32 + getFieldVal 6 = fieldsSetDestination . fromString . packedStringToString <$> getString + getFieldVal 7 = fieldsSetSender . fromString . packedStringToString <$> getString + getFieldVal 8 = fieldsSetSignature <$> getSignature + getFieldVal 9 = fieldsSetUnixFD <$> getw32 + getFieldVal n = error ("unknown field: " ++ show n) + -- | serialize dbus message fields -- this doesn't include the necessary padding at the end. -writeFields :: [Field] -> ByteString -writeFields fields = putWire (putFields fields) - where - putFields :: [Field] -> [PutWire] - putFields l = map putField l - putField f = alignWrite 8 >> putw8 (fromIntegral $ fieldVal f) >> putFieldVal f +writeFields :: DBusFields -> ByteString +writeFields fields = putWire . (:[]) $ do + putField 1 SigObjectPath putObjectPath $ fieldsPath fields + putField 2 SigString (putUString . unInterface) $ fieldsInterface fields + putField 3 SigString (putUString . unMember) $ fieldsMember fields + putField 4 SigString (putUString . unErrorName) $ fieldsErrorName fields + putField 5 SigUInt32 putw32 $ fieldsReplySerial fields + putField 6 SigString (putUString . unBusName) $ fieldsDestination fields + putField 7 SigString (putUString . unBusName) $ fieldsSender fields + putField 8 SigSignature putSignature $ if null (fieldsSignature fields) then Nothing else Just $ fieldsSignature fields + putField 9 SigUInt32 putw32 $ fieldsUnixFD fields + where + putUString = putString . fromString - putFieldVal :: Field -> PutWire - putFieldVal (FieldPath s) = putVariant SigObjectPath >> putObjectPath s - putFieldVal (FieldInterface s) = putVariant SigString >> putString s - putFieldVal (FieldMember s) = putVariant SigString >> putString s - putFieldVal (FieldErrorName s) = putVariant SigString >> putString s - putFieldVal (FieldReplySerial s) = putVariant SigUInt32 >> putw32 s - putFieldVal (FieldDestination s) = putVariant SigString >> putString s - putFieldVal (FieldSender s) = putVariant SigString >> putString s - putFieldVal (FieldSignature s) = putVariant SigSignature >> putSignature s - putFieldVal (FieldUnixFds _) = putVariant SigUInt32 >> putw32 0 + putField :: Word8 -> Type -> (a -> PutWire) -> Maybe a -> PutWire + putField _ _ _ Nothing = return () + putField w s putter (Just v) = + alignWrite 8 >> putw8 w >> putVariant s >> putter v -- | serialize body writeBody :: Body -> ByteString -writeBody els = putWire (map putType els) +writeBody els = putWire (map putValue els) signatureBody :: Body -> Signature -signatureBody body = map sigType body +signatureBody = map sigType +-- | process a raw body (byteString) with the specified endianness and signature. +readBodyRaw :: DBusEndian -> Signature -> ByteString -> Body +readBodyRaw endian sig = getWire endian 0 (mapM getValue sig) + -- | read message's body with a defined signature -readBodyWith :: Message -> Signature -> Body -readBodyWith m sigs = getWire (msgEndian m) 0 (mapM getType sigs) (msgBody m) +readBodyWith :: DBusMessage -> Signature -> Body +readBodyWith m sigs = readBodyRaw (msgEndian m) sigs (msgBodyRaw m) -- | read message's body using the signature field as reference -readBody :: Message -> Body -readBody m = readBodyWith m (getFieldSig $ msgFields m) - where - getFieldSig fields = case filter isFieldSignature fields of - [FieldSignature s] -> s - _ -> [] - - isFieldSignature (FieldSignature _) = True - isFieldSignature _ = False +readBody :: DBusMessage -> Body +readBody m = readBodyWith m (fieldsSignature $ msgFields m) diff --git a/Network/DBus/MessageType.hs b/Network/DBus/MessageType.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/MessageType.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Network.DBus.MessageType +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- + +module Network.DBus.MessageType + ( + -- * high level message type + DBusCall(..) + , DBusReturn(..) + , DBusError(..) + , DBusSignal(..) + , DBusMessageable(..) + ) where + +import Control.Exception +import Data.Data +import Network.DBus.Message +import Network.DBus.Type + +class DBusMessageable a where + toDBusMessage :: a -> DBusMessage + fromDBusMessage :: DBusMessage -> Maybe a + +data DBusSignal = DBusSignal + { signalPath :: ObjectPath + , signalMember :: Member + , signalInterface :: Interface + , signalBody :: Body + } deriving (Show,Eq) + +data DBusCall = DBusCall + { callPath :: ObjectPath + , callMember :: Member + , callInterface :: Maybe Interface + , callBody :: Body + } deriving (Show,Eq) + +data DBusReturn = DBusReturn + { returnReplySerial :: Serial + , returnBody :: Body + } deriving (Show,Eq) + +data DBusError = DBusError + { errorReplySerial :: Serial + , errorName :: ErrorName + , errorBody :: Body + } deriving (Show,Eq,Data,Typeable) + +instance Exception DBusError + +instance DBusMessageable DBusCall where + toDBusMessage call = messageNew TypeMethodCall (callBody call) $ + (fieldsSetPath (callPath call) . + maybe id fieldsSetInterface (callInterface call) . + fieldsSetMember (callMember call)) + fromDBusMessage msg@(msgFields -> fields) = + case (fieldsPath fields, fieldsMember fields) of + (Just path, Just member) -> Just $ DBusCall path member (fieldsInterface fields) (readBody msg) + _ -> Nothing + +instance DBusMessageable DBusSignal where + toDBusMessage signal = messageNew TypeSignal (signalBody signal) $ + (fieldsSetPath (signalPath signal) . + fieldsSetInterface (signalInterface signal) . + fieldsSetMember (signalMember signal)) + fromDBusMessage msg@(msgFields -> fields) = + case (fieldsPath fields, fieldsMember fields, fieldsInterface fields) of + (Just path, Just member, Just intf) -> Just $ DBusSignal path member intf (readBody msg) + _ -> Nothing + +instance DBusMessageable DBusReturn where + toDBusMessage r = messageNew TypeMethodReturn (returnBody r) $ + fieldsSetReplySerial (returnReplySerial r) + fromDBusMessage msg@(msgFields -> fields) = + case fieldsReplySerial fields of + Just rserial -> Just $ DBusReturn rserial (readBody msg) + _ -> Nothing + +instance DBusMessageable DBusError where + toDBusMessage e = messageNew TypeError (errorBody e) $ + (fieldsSetReplySerial (errorReplySerial e) + . fieldsSetErrorName (errorName e)) + fromDBusMessage msg@(msgFields -> fields) = + case (fieldsReplySerial fields, fieldsErrorName fields) of + (Just rserial, Just errname) -> Just $ DBusError rserial errname (readBody msg) + _ -> Nothing diff --git a/Network/DBus/Signature.hs b/Network/DBus/Signature.hs --- a/Network/DBus/Signature.hs +++ b/Network/DBus/Signature.hs @@ -1,12 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Network.DBus.Signature +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus.Signature - ( Signature - , SignatureElem(..) - -- * serialization - , serializeSignature - , unserializeSignature - ) where + ( Signature + , SignatureElem + , Type(..) + -- * serialization + , serializeSignature + , unserializeSignature + ) where import Data.Char (chr, ord) +import Data.Data import Data.Serialize.Get import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -14,33 +24,36 @@ import Control.Applicative ((<$>)) -- | One possible signature element -data SignatureElem = - SigByte - | SigBool - | SigInt16 - | SigUInt16 - | SigInt32 - | SigUInt32 - | SigInt64 - | SigUInt64 - | SigDouble - | SigString - | SigObjectPath - | SigSignature - | SigArray SignatureElem - | SigStruct [SignatureElem] - | SigVariant - | SigDict SignatureElem SignatureElem - | SigUnixFD - deriving (Show,Eq) +data Type = + SigByte + | SigBool + | SigInt16 + | SigUInt16 + | SigInt32 + | SigUInt32 + | SigInt64 + | SigUInt64 + | SigDouble + | SigString + | SigObjectPath + | SigSignature + | SigArray Type + | SigStruct [Type] + | SigVariant + | SigDict Type Type + | SigUnixFD + deriving (Show,Eq,Data,Typeable) +{-# DEPRECATED SignatureElem "use Type instead" #-} +type SignatureElem = Type + -- | A list of signature element -type Signature = [SignatureElem] +type Signature = [Type] marshallString :: String -> ByteString marshallString = B.pack . map (fromIntegral . ord) -marshallSignatureElem :: SignatureElem -> ByteString +marshallSignatureElem :: Type -> ByteString marshallSignatureElem SigByte = marshallString "y" marshallSignatureElem SigBool = marshallString "b" marshallSignatureElem SigInt16 = marshallString "n" @@ -68,51 +81,52 @@ -- | unserialize a signature unserializeSignature :: ByteString -> Either String Signature unserializeSignature = runGet loop where - loop :: Get Signature - loop = do - o <- getOneNoCollection - r <- remaining - if r > 0 then liftM (o :) loop else return [o] - getOneNoCollection = getOne >>= \o -> case o of - Left _ -> error "parsing error, end of collection not in a collection" - Right z -> return z - getOne :: Get (Either SigStop SignatureElem) - getOne = do - t <- chr . fromIntegral <$> getWord8 - case t of - ')' -> return $ Left StopStruct - '}' -> return $ Left StopDict - 'y' -> return $ Right SigByte - 'b' -> return $ Right SigBool - 'n' -> return $ Right SigInt16 - 'q' -> return $ Right SigUInt16 - 'i' -> return $ Right SigInt32 - 'u' -> return $ Right SigUInt32 - 'x' -> return $ Right SigInt64 - 't' -> return $ Right SigUInt64 - 'd' -> return $ Right SigDouble - 's' -> return $ Right SigString - 'o' -> return $ Right SigObjectPath - 'g' -> return $ Right SigSignature - 'a' -> Right <$> getArray - '(' -> Right <$> getStruct - 'v' -> return $ Right SigVariant - '{' -> Right <$> getDict - 'h' -> return $ Right SigUnixFD - _ -> error ("unknown signature element: " ++ (show $ ord t)) - getArray = SigArray <$> getOneNoCollection - getDict = do - l <- loopTill StopDict - case l of - [k,v] -> return $ SigDict k v - _ -> error "dictionary wrong size" - getStruct = do - l <- loopTill StopStruct - case l of - [] -> error "structure empty" - _ -> return $ SigStruct l - loopTill stop = do - o <- getOne - case o of - Left s -> if stop == s then return [] else error "collection not terminated properly" - Right z -> liftM (z :) (loopTill stop) + loop :: Get Signature + loop = do + r <- remaining + if r > 0 + then getOneNoCollection >>= \o -> liftM (o :) loop + else return [] + getOneNoCollection = getOne >>= \o -> case o of + Left _ -> error "parsing error, end of collection not in a collection" + Right z -> return z + getOne :: Get (Either SigStop SignatureElem) + getOne = do + t <- chr . fromIntegral <$> getWord8 + case t of + ')' -> return $ Left StopStruct + '}' -> return $ Left StopDict + 'y' -> return $ Right SigByte + 'b' -> return $ Right SigBool + 'n' -> return $ Right SigInt16 + 'q' -> return $ Right SigUInt16 + 'i' -> return $ Right SigInt32 + 'u' -> return $ Right SigUInt32 + 'x' -> return $ Right SigInt64 + 't' -> return $ Right SigUInt64 + 'd' -> return $ Right SigDouble + 's' -> return $ Right SigString + 'o' -> return $ Right SigObjectPath + 'g' -> return $ Right SigSignature + 'a' -> Right <$> getArray + '(' -> Right <$> getStruct + 'v' -> return $ Right SigVariant + '{' -> Right <$> getDict + 'h' -> return $ Right SigUnixFD + _ -> error ("unknown signature element: " ++ (show $ ord t)) + getArray = SigArray <$> getOneNoCollection + getDict = do + l <- loopTill StopDict + case l of + [k,v] -> return $ SigDict k v + _ -> error "dictionary wrong size" + getStruct = do + l <- loopTill StopStruct + case l of + [] -> error "structure empty" + _ -> return $ SigStruct l + loopTill stop = do + o <- getOne + case o of + Left s -> if stop == s then return [] else error "collection not terminated properly" + Right z -> liftM (z :) (loopTill stop) diff --git a/Network/DBus/StdMessage.hs b/Network/DBus/StdMessage.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/StdMessage.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Network.DBus.StdMessage +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.DBus.StdMessage + ( + -- * dbus server standard interface + dbusDestination + , dbusPath + , dbusInterface + -- * dbus standard message + , msgDBusHello + , msgDBusListNames + , msgDBusAddMatch + ) where + +import Network.DBus.Message +import Network.DBus.MessageType +import Network.DBus.Type +import Data.String + +dbusDestination :: BusName +dbusDestination = "org.freedesktop.DBus" +dbusPath = "/org/freedesktop/DBus" +dbusInterface = "org.freedesktop.DBus" + +msgDBusHello = DBusCall dbusPath "Hello" (Just dbusInterface) [] +msgDBusListNames = DBusCall dbusPath "ListNames" (Just dbusInterface) [] + +msgDBusAddMatch matchingRule = DBusCall dbusPath "AddMatch" (Just dbusInterface) [ DBusString $ fromString matchingRule ] diff --git a/Network/DBus/Type.hs b/Network/DBus/Type.hs --- a/Network/DBus/Type.hs +++ b/Network/DBus/Type.hs @@ -1,67 +1,116 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : Network.DBus.Type +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus.Type - ( - ObjectPath - , DbusType(..) - , putType - , getType - , sigType - ) where + ( ObjectPath + , DBusValue(..) + , DBusTypeable(..) + , putValue + , getValue + , sigType + ) where import Data.Word +import Data.Data import Data.Int -import Data.ByteString (ByteString) +import Data.String +import qualified Data.ByteString as B import Network.DBus.Wire import Network.DBus.Signature +import Network.DBus.Internal import qualified Network.DBus.IEEE754 as IEEE754 import Control.Applicative ((<$>)) +import Control.Monad (liftM) --- | DBus ObjectPath -type ObjectPath = ByteString +-- | DBus Types +data DBusValue = + DBusByte Word8 + | DBusBoolean Bool + | DBusInt16 Int16 + | DBusUInt16 Word16 + | DBusInt32 Int32 + | DBusUInt32 Word32 + | DBusInt64 Int64 + | DBusUInt64 Word64 + | DBusDouble Double + | DBusString PackedString + | DBusObjectPath ObjectPath + | DBusSignature Signature + | DBusByteArray B.ByteString -- special case of the DBusArray + | DBusArray Type [DBusValue] + | DBusStruct Signature [DBusValue] + | DBusDict DBusValue DBusValue + | DBusVariant DBusValue + | DBusUnixFD Word32 + deriving (Show,Eq,Data,Typeable) --- | Dbus Types -data DbusType = - DbusByte Word8 - | DbusBoolean Bool - | DbusInt16 Int16 - | DbusUInt16 Word16 - | DbusInt32 Int32 - | DbusUInt32 Word32 - | DbusInt64 Int64 - | DbusUInt64 Word64 - | DbusDouble Double - | DbusString ByteString - | DbusObjectPath ObjectPath - | DbusSignature Signature - | DbusArray SignatureElem [DbusType] - | DbusStruct Signature [DbusType] - | DbusDict DbusType DbusType - | DbusVariant DbusType - | DbusUnixFD Word32 - deriving (Show,Eq) +class DBusTypeable a where + toSignature :: a -> Type + toDBusValue :: a -> DBusValue + fromDBusValue :: DBusValue -> Maybe a +#define SIMPLE_DBUS_INSTANCE(hsType,constructor) \ + instance DBusTypeable hsType where \ + { toSignature = sigType . constructor \ + ; toDBusValue = constructor \ + ; fromDBusValue (constructor x) = Just x \ + ; fromDBusValue _ = Nothing \ + } + +instance DBusTypeable DBusValue where + toSignature = sigType + toDBusValue = id + fromDBusValue = Just + +SIMPLE_DBUS_INSTANCE(Word8, DBusByte) +SIMPLE_DBUS_INSTANCE(Bool, DBusBoolean) +SIMPLE_DBUS_INSTANCE(Int16, DBusInt16) +SIMPLE_DBUS_INSTANCE(Word16, DBusUInt16) +SIMPLE_DBUS_INSTANCE(Int32, DBusInt32) +SIMPLE_DBUS_INSTANCE(Word32, DBusUInt32) +SIMPLE_DBUS_INSTANCE(Int64, DBusInt64) +SIMPLE_DBUS_INSTANCE(Word64, DBusUInt64) +SIMPLE_DBUS_INSTANCE(Double, DBusDouble) +SIMPLE_DBUS_INSTANCE(ObjectPath, DBusObjectPath) + +instance DBusTypeable String where + toSignature _ = SigString + toDBusValue = DBusString . fromString + fromDBusValue (DBusString s) = Just (show s) + fromDBusValue _ = Nothing + -- | return signature element of a dbus type -sigType :: DbusType -> SignatureElem -sigType (DbusByte _) = SigByte -sigType (DbusBoolean _) = SigBool -sigType (DbusInt16 _) = SigInt16 -sigType (DbusUInt16 _) = SigUInt16 -sigType (DbusInt32 _) = SigInt32 -sigType (DbusUInt32 _) = SigUInt32 -sigType (DbusInt64 _) = SigInt64 -sigType (DbusUInt64 _) = SigUInt64 -sigType (DbusDouble _) = SigDouble -sigType (DbusString _) = SigString -sigType (DbusObjectPath _) = SigObjectPath -sigType (DbusSignature _) = SigSignature -sigType (DbusStruct s _) = SigStruct s -sigType (DbusVariant _) = SigVariant -sigType (DbusArray s _) = SigArray s -sigType (DbusDict k v) = SigDict (sigType k) (sigType v) -sigType (DbusUnixFD _) = SigUnixFD +sigType :: DBusValue -> Type +sigType (DBusByte _) = SigByte +sigType (DBusBoolean _) = SigBool +sigType (DBusInt16 _) = SigInt16 +sigType (DBusUInt16 _) = SigUInt16 +sigType (DBusInt32 _) = SigInt32 +sigType (DBusUInt32 _) = SigUInt32 +sigType (DBusInt64 _) = SigInt64 +sigType (DBusUInt64 _) = SigUInt64 +sigType (DBusDouble _) = SigDouble +sigType (DBusString _) = SigString +sigType (DBusObjectPath _) = SigObjectPath +sigType (DBusSignature _) = SigSignature +sigType (DBusStruct s _) = SigStruct s +sigType (DBusVariant _) = SigVariant +sigType (DBusByteArray _) = SigArray SigByte +sigType (DBusArray s _) = SigArray s +sigType (DBusDict k v) = SigDict (sigType k) (sigType v) +sigType (DBusUnixFD _) = SigUnixFD -- | return the alignement required for a specific signature element. -alignSigElement :: SignatureElem -> Int +alignSigElement :: Type -> Int alignSigElement SigByte = 1 alignSigElement SigBool = 1 alignSigElement SigInt16 = 2 @@ -81,50 +130,61 @@ alignSigElement SigUnixFD = 4 -- | serialize a dbus type -putType :: DbusType -> PutWire -putType (DbusByte w) = putw8 w -putType (DbusBoolean b) = putw32 (if b then 1 else 0) -putType (DbusInt16 i) = putw16 $ fromIntegral i -putType (DbusUInt16 w) = putw16 w -putType (DbusInt32 i) = putw32 $ fromIntegral i -putType (DbusUInt32 w) = putw32 w -putType (DbusInt64 i) = putw64 $ fromIntegral i -putType (DbusUInt64 w) = putw64 w -putType (DbusDouble d) = putw64 $ IEEE754.encode d -putType (DbusString s) = putString s -putType (DbusObjectPath s) = putString s -putType (DbusSignature s) = putSignature s -putType (DbusUnixFD fd) = putw32 fd -putType (DbusStruct _ l) = alignWrite 8 >> mapM_ putType l -putType (DbusDict k v) = putType (DbusStruct [] [k,v]) -putType (DbusVariant t) = putSignature [sigType t] >> putType t -putType (DbusArray s l) = putw32 (fromIntegral len) >> alignWrite alignElement >> mapM_ putType l - where - len = length l * sizeofElement - sizeofElement = 4 - alignElement = alignSigElement s +putValue :: DBusValue -> PutWire +putValue (DBusByte w) = putw8 w +putValue (DBusBoolean b) = putw32 (if b then 1 else 0) +putValue (DBusInt16 i) = putw16 $ fromIntegral i +putValue (DBusUInt16 w) = putw16 w +putValue (DBusInt32 i) = putw32 $ fromIntegral i +putValue (DBusUInt32 w) = putw32 w +putValue (DBusInt64 i) = putw64 $ fromIntegral i +putValue (DBusUInt64 w) = putw64 w +putValue (DBusDouble d) = putw64 $ IEEE754.encode d +putValue (DBusString s) = putString s +putValue (DBusObjectPath s) = putObjectPath s +putValue (DBusSignature s) = putSignature s +putValue (DBusUnixFD fd) = putw32 fd +putValue (DBusStruct _ l) = alignWrite 8 >> mapM_ putValue l +putValue (DBusDict k v) = putValue (DBusStruct [] [k,v]) +putValue (DBusVariant t) = putSignature [sigType t] >> putValue t +putValue (DBusByteArray l) = + putw32 (fromIntegral $ B.length l) >> alignWrite alignElement >> putBytes l + where alignElement = alignSigElement SigByte +putValue (DBusArray s l) = do + pos <- putWireGetPosition + let alignmentStart = pos + alignWriteCalculate 4 pos + 4 + let alignmentEnd = alignmentStart + alignWriteCalculate alignElement alignmentStart + let content = putWireAt alignmentEnd [mapM_ putValue l] + putw32 (fromIntegral $ B.length content) >> alignWrite alignElement >> putBytes content + where + alignElement = alignSigElement s -- | unserialize a dbus type from a signature Element -getType :: SignatureElem -> GetWire DbusType -getType SigByte = DbusByte <$> getw8 -getType SigBool = DbusBoolean . iToB <$> getw32 where iToB i = i == 1 -getType SigInt16 = DbusInt16 . fromIntegral <$> getw16 -getType SigUInt16 = DbusUInt16 <$> getw16 -getType SigInt32 = DbusInt32 . fromIntegral <$> getw32 -getType SigUInt32 = DbusUInt32 <$> getw32 -getType SigInt64 = DbusInt64 . fromIntegral <$> getw64 -getType SigUInt64 = DbusUInt64 <$> getw64 -getType SigDouble = DbusDouble . IEEE754.decode <$> getw64 -getType SigString = DbusString <$> getString -getType SigObjectPath = DbusObjectPath <$> getObjectPath -getType SigSignature = DbusSignature <$> getSignature -getType (SigDict k v) = getType (SigStruct [k,v]) -getType SigUnixFD = DbusUnixFD <$> getw32 -getType SigVariant = getVariant >>= getType >>= return . DbusVariant -getType (SigStruct sigs) = - alignRead 8 >> mapM getType sigs >>= return . DbusStruct sigs -getType (SigArray t) = do - len <- getw32 - alignRead (alignSigElement t) - l <- getMultiple (fromIntegral len) (getType t) - return $ DbusArray t l +getValue :: Type -> GetWire DBusValue +getValue SigByte = DBusByte <$> getw8 +getValue SigBool = DBusBoolean . iToB <$> getw32 where iToB i = i == 1 +getValue SigInt16 = DBusInt16 . fromIntegral <$> getw16 +getValue SigUInt16 = DBusUInt16 <$> getw16 +getValue SigInt32 = DBusInt32 . fromIntegral <$> getw32 +getValue SigUInt32 = DBusUInt32 <$> getw32 +getValue SigInt64 = DBusInt64 . fromIntegral <$> getw64 +getValue SigUInt64 = DBusUInt64 <$> getw64 +getValue SigDouble = DBusDouble . IEEE754.decode <$> getw64 +getValue SigString = DBusString <$> getString +getValue SigObjectPath = DBusObjectPath <$> getObjectPath +getValue SigSignature = DBusSignature <$> getSignature +getValue (SigDict k v) = do + alignRead 8 + key <- getValue k + val <- getValue v + return $ DBusDict key val +getValue SigUnixFD = DBusUnixFD <$> getw32 +getValue SigVariant = liftM DBusVariant (getVariant >>= getValue) +getValue (SigStruct sigs) = + liftM (DBusStruct sigs) (alignRead 8 >> mapM getValue sigs) +getValue (SigArray t) = do + len <- getw32 + alignRead (alignSigElement t) + case t of + SigByte -> DBusByteArray <$> getBytes (fromIntegral len) + _ -> DBusArray t <$> getMultiple (fromIntegral len) (getValue t) diff --git a/Network/DBus/Wire.hs b/Network/DBus/Wire.hs --- a/Network/DBus/Wire.hs +++ b/Network/DBus/Wire.hs @@ -1,38 +1,51 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Network.DBus.Wire +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.DBus.Wire - ( DbusEndian(..) - -- * getter - , GetWire - , getWire - , isWireEmpty - , alignRead - , getw8 - , getw16 - , getw32 - , getw64 - , getString - , getSignature - , getVariant - , getObjectPath - , getMultiple - -- * putter - , PutWire - , putWire - , alignWrite - , putw8 - , putw16 - , putw32 - , putw64 - , putString - , putSignature - , putVariant - , putObjectPath - ) where + ( DBusEndian(..) + -- * getter + , GetWire + , getWire + , isWireEmpty + , alignRead + , getw8 + , getw16 + , getw32 + , getw64 + , getString + , getSignature + , getVariant + , getObjectPath + , getBytes + , getMultiple + -- * putter + , PutWire + , putWire + , putWireAt + , putWireGetPosition + , putBytes + , alignWrite + , alignWriteCalculate + , putw8 + , putw16 + , putw32 + , putw64 + , putString + , putSignature + , putVariant + , putObjectPath + ) where import Data.Word import Data.Bits -import Data.Binary.Get +import Data.Binary.Get hiding (getBytes) import Data.ByteString (ByteString) +import Data.String import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -40,14 +53,15 @@ import Control.Monad.Reader import Control.Monad.State import Network.DBus.Signature +import Network.DBus.Internal -data DbusEndian = LE | BE deriving (Show,Eq) -type DbusGet = (DbusEndian, Int) +data DBusEndian = LE | BE deriving (Show,Eq) +type DBusGet = (DBusEndian, Int) -- Specified endianness and alignment of this context. -newtype GetWire a = GetWire { runGW :: ReaderT DbusGet Get a } - deriving (Monad, MonadReader DbusGet, Functor) +newtype GetWire a = GetWire { runGW :: ReaderT DBusGet Get a } + deriving (Monad, MonadReader DBusGet, Functor) -getWire :: DbusEndian -> Int -> GetWire a -> ByteString -> a +getWire :: DBusEndian -> Int -> GetWire a -> ByteString -> a getWire endian align f b = runGet (runReaderT (runGW f) (endian,align)) (L.fromChunks [b]) liftGet :: Get a -> GetWire a @@ -61,11 +75,11 @@ alignRead :: Int -> GetWire () alignRead n = do - (_, start) <- ask - br <- liftGet (fromIntegral <$> bytesRead) - case (br + start) `mod` n of - 0 -> return () - i -> liftGet (skip $ n - i) + (_, start) <- ask + br <- liftGet (fromIntegral <$> bytesRead) + case (br + start) `mod` n of + 0 -> return () + i -> liftGet (skip $ n - i) getw8 :: GetWire Word8 getw8 = liftGet getWord8 @@ -79,110 +93,120 @@ getw64 :: GetWire Word64 getw64 = alignRead 8 >> onEndian (liftGet getWord64le) (liftGet getWord64be) -getSignatureOne :: GetWire SignatureElem +getSignatureOne :: GetWire Type getSignatureOne = do - sigs <- getSignature - case sigs of - [s] -> return s - _ -> error "one signature with wrong format" + sigs <- getSignature + case sigs of + [s] -> return s + _ -> error "one signature with wrong format" getSignature :: GetWire Signature getSignature = do - len <- fromIntegral <$> getw8 - sigBS <- liftGet $ getByteString len - _ <- getw8 - case unserializeSignature sigBS of - Left err -> error err - Right sig -> return sig + len <- fromIntegral <$> getw8 + sigBS <- liftGet $ getByteString len + _ <- getw8 + case unserializeSignature sigBS of + Left err -> error err + Right sig -> return sig -getVariant :: GetWire SignatureElem +getVariant :: GetWire Type getVariant = getSignatureOne -getString :: GetWire ByteString +getBytes = liftGet . getByteString + +getString :: GetWire PackedString getString = do - nbBytes <- fromIntegral <$> getw32 - s <- liftGet $ getByteString nbBytes - _ <- getw8 - return s + nbBytes <- fromIntegral <$> getw32 + s <- liftGet $ getByteString nbBytes + _ <- getw8 + return $ PackedString s -getObjectPath :: GetWire ByteString -getObjectPath = getString +getObjectPath :: GetWire ObjectPath +getObjectPath = ObjectPath . packedStringToString <$> getString getMultiple :: Show a => Int -> GetWire a -> GetWire [a] getMultiple 0 _ = return [] getMultiple n f = do - r1 <- liftGet remaining - a <- f - r2 <- liftGet remaining - let r = fromIntegral (r1-r2) - liftM (a :) (getMultiple (n-r) f) + r1 <- liftGet remaining + a <- f + r2 <- liftGet remaining + let r = fromIntegral (r1-r2) + liftM (a :) (getMultiple (n-r) f) type PutWireM a = State (Int, [ByteString]) a type PutWire = PutWireM () +putWireGetPosition :: PutWireM Int +putWireGetPosition = gets fst + +putWireAt :: Int -> [PutWire] -> ByteString +putWireAt i f = B.concat $ reverse $ snd $ execState (sequence_ f) (i, []) + putWire :: [PutWire] -> ByteString -putWire f = B.concat $ reverse $ snd $ execState (sequence_ f) (0, []) +putWire = putWireAt 0 putBytes :: ByteString -> PutWire putBytes s = modify (\(i, l) -> (i + B.length s, s : l)) +alignWriteCalculate :: Int -> Int -> Int +alignWriteCalculate n pos = negMod $ pos `mod` n + where + negMod 0 = 0 + negMod x = n - x + alignWrite :: Int -> PutWire -alignWrite n = do - i <- fst <$> get - case i `mod` n of - 0 -> return () - x -> putBytes $ B.replicate (n - x) 0 +alignWrite n = gets (alignWriteCalculate n . fst) >>= \l -> putBytes $ B.replicate l 0 putw8 :: Word8 -> PutWire putw8 = putBytes . B.singleton putw16 :: Word16 -> PutWire putw16 w = alignWrite 2 >> putBytes (B.pack le) - where - le = [p2,p1] - be = [p1,p2] - p1 = fromIntegral $ w `shiftR` 8 - p2 = fromIntegral w + where + le = [p2,p1] + --be = [p1,p2] + p1 = fromIntegral $ w `shiftR` 8 + p2 = fromIntegral w putw32 :: Word32 -> PutWire putw32 w = alignWrite 4 >> putBytes (B.pack le) - where - le = [p4,p3,p2,p1] - be = [p1,p2,p3,p4] - p1 = fromIntegral $ w `shiftR` 24 - p2 = fromIntegral $ w `shiftR` 16 - p3 = fromIntegral $ w `shiftR` 8 - p4 = fromIntegral w + where + le = [p4,p3,p2,p1] + --be = [p1,p2,p3,p4] + p1 = fromIntegral $ w `shiftR` 24 + p2 = fromIntegral $ w `shiftR` 16 + p3 = fromIntegral $ w `shiftR` 8 + p4 = fromIntegral w putw64 :: Word64 -> PutWire putw64 w = alignWrite 8 >> putBytes (B.pack le) - where - le = [p8,p7,p6,p5,p4,p3,p2,p1] - be = [p1,p2,p3,p4,p5,p6,p7,p8] - p1 = fromIntegral $ w `shiftR` 56 - p2 = fromIntegral $ w `shiftR` 48 - p3 = fromIntegral $ w `shiftR` 40 - p4 = fromIntegral $ w `shiftR` 32 - p5 = fromIntegral $ w `shiftR` 24 - p6 = fromIntegral $ w `shiftR` 16 - p7 = fromIntegral $ w `shiftR` 8 - p8 = fromIntegral w + where + le = [p8,p7,p6,p5,p4,p3,p2,p1] + --be = [p1,p2,p3,p4,p5,p6,p7,p8] + p1 = fromIntegral $ w `shiftR` 56 + p2 = fromIntegral $ w `shiftR` 48 + p3 = fromIntegral $ w `shiftR` 40 + p4 = fromIntegral $ w `shiftR` 32 + p5 = fromIntegral $ w `shiftR` 24 + p6 = fromIntegral $ w `shiftR` 16 + p7 = fromIntegral $ w `shiftR` 8 + p8 = fromIntegral w -putString :: ByteString -> PutWire -putString b = do - putw32 (fromIntegral $ B.length b) - putBytes b - putw8 0 +putString :: PackedString -> PutWire +putString (PackedString b) = do + putw32 (fromIntegral $ B.length b) + putBytes b + putw8 0 putSignature :: Signature -> PutWire putSignature sig = do - putw8 (fromIntegral $ B.length b) - putBytes b - putw8 0 - where b = serializeSignature sig + putw8 (fromIntegral $ B.length b) + putBytes b + putw8 0 + where b = serializeSignature sig -putVariant :: SignatureElem -> PutWire +putVariant :: Type -> PutWire putVariant = putSignature . (:[]) -putObjectPath :: ByteString -> PutWire -putObjectPath = putString +putObjectPath :: ObjectPath -> PutWire +putObjectPath = putString . fromString . unObjectPath diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,33 +2,33 @@ ======== The udbus haskell package provides a BSD implementation of the DBus protocol in -pure Haskell, giving access to a simple lowlevel interface. The interfaces are -coherent and basic, sacrificing some ease of use (in using more appropriate -haskell types for dbus array for example) in favor of being able to write generated -code easily. +pure Haskell, giving access to a simple lowlevel (Network.DBus.Actions) interface +and a simple high level interface with a simple mainloop dispatcher (Network.DBus) +The interfaces are coherent and basic, sacrificing some ease of use (in using +more appropriate haskell types for dbus array for example) in favor of being +able to write generated code easily. + The code doesn't check if the object values (objectpath, interface, etc) are appropriates on sending, nor on receiving. The dbus daemon should have prevented invalid values to be received, and for sending, the user need to take extra care of the values sent. -Dbus startup negotiation need to be done properly by the user, that includes -sending the hello method call at startup (see Example). - TODO & Caveats -------------- -Dbus endianness is not handle properly to serialize message if the user choose -big endian. User should always select little endian regardless of the actual -machine architecture. However, receiving message in both endianness is supported. +User should always select little endian regardless of the actual machine +architecture when creating message. However, receiving message in both +endianness is supported. -Double are expected to be handled as IEEE754 by the compiler. Serialization of double -is handled in a GHC specific way (making the package GHC specific), expecting -that any architecture represent double the IEEE754 way. So far, this seems to be -true for every architecture supported by GHC. +Double are expected to be handled as IEEE754 by the compiler. Serialization of +double is handled in a GHC specific way (making the package GHC specific), +expecting that any architecture represent double the IEEE754 way. So far, this +seems to be true for every architecture supported by GHC. Stability --------- + While the low level interfaces should remains the same, it's not unexpected that some high level interface would be grafted on top of the actual interfaces. diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,101 @@ +import Text.Printf +import Data.String +import Test.QuickCheck +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import qualified Data.ByteString as B +import Network.DBus.Type +import Network.DBus.Signature +import Network.DBus.Internal +import Network.DBus.Message +import Network.DBus.Wire +import Control.Monad +import Control.Applicative ((<$>)) + +----------------------------------------------------------------------------------- +genSimpleSig = + [ return SigByte + , return SigBool + , return SigInt16 + , return SigUInt16 + , return SigInt32 + , return SigUInt32 + , return SigInt64 + , return SigUInt64 + , return SigDouble + , return SigString + , return SigObjectPath + , return SigSignature + , return SigVariant + ] + +genSigElem :: Int -> Gen Type +genSigElem 0 = oneof genSimpleSig +genSigElem n = oneof (genSimpleSig ++ [ liftM SigArray subSig, liftM SigStruct (replicateM 2 subSig) ]) + where + subSig :: Gen Type + subSig = genSigElem (n `div` 2) + +genSig :: Gen Signature +genSig = replicateM 4 (resize 2 $ sized genSigElem) + +-- just there to make it instance of arbitrary without having typesynonym +newtype DSignature = DSignature Signature + deriving (Eq) + +instance Show DSignature where + show (DSignature x) = show x +instance Arbitrary DSignature where + arbitrary = DSignature <$> genSig +----------------------------------------------------------------------------------- + +instance Arbitrary PackedString where + arbitrary = fromString <$> arbitrary + +instance Arbitrary ObjectPath where + arbitrary = ObjectPath <$> arbitrary + +arbitraryBS = B.pack <$> (choose (1,580) >>= \l -> replicateM l arbitrary) + +genBody :: Gen (Signature, [DBusValue]) +genBody = genSig >>= \sig -> (mapM sigToBody sig >>= \body ->return (sig,body)) where + sigToBody SigByte = DBusByte <$> arbitrary + sigToBody SigBool = DBusBoolean <$> arbitrary + sigToBody SigInt16 = DBusInt16 <$> arbitrary + sigToBody SigUInt16 = DBusUInt16 <$> arbitrary + sigToBody SigInt32 = DBusInt32 <$> arbitrary + sigToBody SigUInt32 = DBusUInt32 <$> arbitrary + sigToBody SigInt64 = DBusInt64 <$> arbitrary + sigToBody SigUInt64 = DBusUInt64 <$> arbitrary + sigToBody SigDouble = DBusDouble <$> arbitrary + sigToBody SigObjectPath = DBusObjectPath <$> arbitrary + sigToBody SigString = DBusString <$> arbitrary + sigToBody SigVariant = sized genSigElem >>= sigToBody >>= return . DBusVariant + sigToBody SigSignature = DBusSignature <$> genSig + sigToBody (SigStruct sigs) = mapM sigToBody sigs >>= return . DBusStruct sigs + sigToBody (SigArray sig) + | sig == SigByte = DBusByteArray <$> arbitraryBS + | otherwise = mapM sigToBody (replicate 3 sig) >>= return . DBusArray sig + sigToBody _ = DBusString <$> arbitrary + +data BodyContent = BodyContent Signature [DBusValue] + deriving (Show,Eq) +instance Arbitrary BodyContent where + arbitrary = genBody >>= \(sig, val) -> return $ BodyContent sig val +----------------------------------------------------------------------------------- + +property_signature_marshalling (DSignature x) = (unserializeSignature $ serializeSignature x) == Right x +property_body_marshalling (BodyContent sig c) = (readBodyRaw LE sig $ writeBody c) `assertEq` c + +assertEq :: (Show a, Eq a) => a -> a -> Bool +assertEq a b + | a == b = True + | otherwise = error ("equality failed:\ngot: " ++ show a ++ "\nexpected " ++ show b) + +main = defaultMain tests where + tests = [testMarshalling] + testMarshalling = testGroup "Marshalling" + [ testProperty "Signature" property_signature_marshalling + , testProperty "Values" property_body_marshalling + ] diff --git a/udbus.cabal b/udbus.cabal --- a/udbus.cabal +++ b/udbus.cabal @@ -1,5 +1,5 @@ Name: udbus -Version: 0.1.1 +Version: 0.2.0 Description: Small and flexible implementation of the dbus protocol. License: BSD3 License-file: LICENSE @@ -24,20 +24,26 @@ Library Build-Depends: base >= 3 && < 5 - , cereal >= 0.3.0 , binary + , cereal , bytestring + , utf8-string , network + , containers , mtl , unix , ghc-prim Exposed-modules: Network.DBus + Network.DBus.Actions Other-modules: Network.DBus.IEEE754 Network.DBus.Message + Network.DBus.MessageType + Network.DBus.StdMessage + Network.DBus.Internal Network.DBus.Signature Network.DBus.Type Network.DBus.Wire - ghc-options: -Wall + ghc-options: -Wall -fno-warn-missing-signatures Executable dbus Main-is: DBus.hs @@ -46,6 +52,19 @@ Build-Depends: network else Buildable: False + +executable Tests + Main-is: Tests.hs + if flag(test) + Buildable: True + Build-Depends: base >= 3 && < 5 + , QuickCheck >= 2 + , test-framework + , test-framework-quickcheck2 + , bytestring + else + Buildable: False + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures source-repository head type: git