diff --git a/DBus.hs b/DBus.hs new file mode 100644 --- /dev/null +++ b/DBus.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Posix.User +import Network.DBus +import Network.DBus.Message +import Network.DBus.Type +import Network.DBus.Signature +import Data.Word +import Control.Monad.Trans + +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 + + let msg = msgMethodCall dbusDestination dbusPath dbusInterface "ListNames" [] + messageSend msg + msg <- messageRecv + let b = readBody msg + liftIO $ putStrLn $ show b + + 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 + ] + + liftIO $ putStrLn $ show msg + messageSend msg + msgR <- messageRecv + liftIO $ putStrLn $ show msgR + +main = getRealUserID >>= mainDbus . fromIntegral diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2011 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Network/DBus.hs b/Network/DBus.hs new file mode 100644 --- /dev/null +++ b/Network/DBus.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.DBus + ( DBusHandle + , authenticate + , authenticateUID + + , connectSession + , connectSystem + , connectHandle + + , withContext + , withSession + , withSystem + + , messageSend + , messageRecv + + -- * from Message module + , MessageType(..) + , MessageFlag(..) + , Field(..) + , Message(..) + , Serial + , msgMethodCall + , msgMethodReturn + , msgError + , msgSignal + + -- * read a message body + , readBody + , readBodyWith + + -- * from Signature module + , SignatureElem(..) + , Signature + + -- * from Type module + , ObjectPath + , DbusType(..) + ) where + +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 + +import Control.Arrow +import Control.Applicative ((<$>)) +import Control.Exception +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.Signature + +-- | Represent an open access to dbus. for now only based on system handle. +newtype DBusHandle = DBusHandle Handle + +type DBusContext a = StateT (DBusHandle, Serial) IO a + +withHandle :: (Handle -> IO a) -> DBusContext a +withHandle f = do + (DBusHandle h) <- fst <$> get + liftIO (f h) + +hGet :: Int -> DBusContext ByteString +hGet i = withHandle (\h -> BC.hGet h i) + +hPut :: ByteString -> DBusContext () +hPut b = withHandle (\h -> BC.hPut h b) + +hPuts :: [ByteString] -> DBusContext () +hPuts bs = withHandle (\h -> L.hPut h $ L.fromChunks bs) + +hGetLine :: DBusContext () +hGetLine = withHandle BC.hGetLine >> return () + +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 "" + +authenticate :: ByteString -> DBusContext () +authenticate auth = do + hPut $ BC.concat ["\0AUTH EXTERNAL ", auth, "\r\n"] + _ <- hGetLine + hPut "BEGIN\r\n" + +close :: DBusHandle -> IO () +close (DBusHandle h) = hClose h + +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 + +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] + +connectOver _ _ = do + error "not implemented yet" + +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 + +-- | 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 + +-- | connect to the dbus system bus +connectSystem :: IO DBusHandle +connectSystem = connectUnix "/var/run/dbus/system_bus_socket" + +-- | connect onto a previously open handle +connectHandle :: Handle -> IO DBusHandle +connectHandle h = return $ DBusHandle h + +-- | 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 close (\h -> evalStateT f (h,1)) + +-- | create a new Dbus context on session bus +withSession :: DBusContext a -> IO a +withSession = withContext connectSession + +-- | create a new Dbus context on system bus +withSystem :: DBusContext a -> IO a +withSystem = withContext connectSystem + +-- | 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 + +-- | 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 } + +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 new file mode 100644 --- /dev/null +++ b/Network/DBus/IEEE754.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} +module Network.DBus.IEEE754 (encode, decode) where + +import GHC.Prim +import GHC.Types +import GHC.Word + +-- | encode a double to a IEEE754 format +encode :: Double -> Word64 +encode (D# x) = W64# (unsafeCoerce# x) + +-- | decode a double from a IEEE754 format +decode :: Word64 -> Double +decode (W64# x) = D# (unsafeCoerce# x) diff --git a/Network/DBus/Message.hs b/Network/DBus/Message.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Message.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE OverloadedStrings #-} +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 + +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import Control.Applicative ((<$>)) +import Control.Monad.State + +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) + +-- | dbus message flags +data MessageFlag = + 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) + +type Body = [DbusType] + +type Interface = ByteString +type Member = ByteString +type BusName = ByteString +type ErrorName = ByteString + +data Field = + FieldPath ObjectPath + | FieldInterface Interface + | FieldMember Member + | FieldErrorName ErrorName + | FieldReplySerial Serial + | FieldDestination BusName + | FieldSender ByteString + | FieldSignature Signature + | FieldUnixFds Word32 + deriving (Show,Eq) + +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) + +defaultMessage :: Message +defaultMessage = Message + { msgEndian = LE + , msgType = TypeInvalid + , msgVersion = 1 + , msgFlags = 0 + , msgSerial = 0 + , msgFields = [] + , msgBody = B.empty + } + +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 + } + +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 + } + +-- | 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 + } + +-- | 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 + } + +-- | 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 + } + +-- | 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 + } + +-- | 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 + + return $! Header + { headerEndian = if fromIntegral e /= fromEnum 'l' then BE else LE + , headerMessageType = mt + , headerVersion = ver + , headerFlags = flags + , headerBodyLength = blen + , headerSerial = serial + , headerFieldsLength = flen + } + +-- | serialize a dbus header +writeHeader :: Header -> 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 + +-- | 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 + + 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 + + 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) + +-- | 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 + + 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 + +-- | serialize body +writeBody :: Body -> ByteString +writeBody els = putWire (map putType els) + +signatureBody :: Body -> Signature +signatureBody body = map sigType body + +-- | read message's body with a defined signature +readBodyWith :: Message -> Signature -> Body +readBodyWith m sigs = getWire (msgEndian m) 0 (mapM getType sigs) (msgBody 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 diff --git a/Network/DBus/Signature.hs b/Network/DBus/Signature.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Signature.hs @@ -0,0 +1,118 @@ +module Network.DBus.Signature + ( Signature + , SignatureElem(..) + -- * serialization + , serializeSignature + , unserializeSignature + ) where + +import Data.Char (chr, ord) +import Data.Serialize.Get +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Control.Monad +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) + +-- | A list of signature element +type Signature = [SignatureElem] + +marshallString :: String -> ByteString +marshallString = B.pack . map (fromIntegral . ord) + +marshallSignatureElem :: SignatureElem -> ByteString +marshallSignatureElem SigByte = marshallString "y" +marshallSignatureElem SigBool = marshallString "b" +marshallSignatureElem SigInt16 = marshallString "n" +marshallSignatureElem SigUInt16 = marshallString "q" +marshallSignatureElem SigInt32 = marshallString "i" +marshallSignatureElem SigUInt32 = marshallString "u" +marshallSignatureElem SigInt64 = marshallString "x" +marshallSignatureElem SigUInt64 = marshallString "t" +marshallSignatureElem SigDouble = marshallString "d" +marshallSignatureElem SigString = marshallString "s" +marshallSignatureElem SigObjectPath = marshallString "o" +marshallSignatureElem SigSignature = marshallString "g" +marshallSignatureElem SigVariant = marshallString "v" +marshallSignatureElem SigUnixFD = marshallString "h" +marshallSignatureElem (SigArray t) = B.concat [marshallString "a", marshallSignatureElem t] +marshallSignatureElem (SigStruct l) = B.concat ([marshallString "("] ++ map marshallSignatureElem l ++ [marshallString ")"]) +marshallSignatureElem (SigDict k v) = B.concat [marshallString "{", marshallSignatureElem k, marshallSignatureElem v, marshallString "}"] + +-- | serialize a signature +serializeSignature :: Signature -> ByteString +serializeSignature elements = B.concat $ map marshallSignatureElem elements + +data SigStop = StopStruct | StopDict deriving (Eq) + +-- | 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) diff --git a/Network/DBus/Type.hs b/Network/DBus/Type.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Type.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Rank2Types #-} +module Network.DBus.Type + ( + ObjectPath + , DbusType(..) + , putType + , getType + , sigType + ) where + +import Data.Word +import Data.Int +import Data.ByteString (ByteString) +import Network.DBus.Wire +import Network.DBus.Signature +import qualified Network.DBus.IEEE754 as IEEE754 +import Control.Applicative ((<$>)) + +-- | DBus ObjectPath +type ObjectPath = ByteString + +-- | 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) + +-- | 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 + +-- | return the alignement required for a specific signature element. +alignSigElement :: SignatureElem -> Int +alignSigElement SigByte = 1 +alignSigElement SigBool = 1 +alignSigElement SigInt16 = 2 +alignSigElement SigUInt16 = 2 +alignSigElement SigInt32 = 4 +alignSigElement SigUInt32 = 4 +alignSigElement SigInt64 = 8 +alignSigElement SigUInt64 = 8 +alignSigElement SigDouble = 8 +alignSigElement SigString = 4 +alignSigElement SigObjectPath = 4 +alignSigElement SigSignature = 1 +alignSigElement (SigDict _ _) = 8 +alignSigElement (SigStruct _) = 8 +alignSigElement SigVariant = 1 +alignSigElement (SigArray _) = 4 +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 + +-- | 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 diff --git a/Network/DBus/Wire.hs b/Network/DBus/Wire.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Wire.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +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 + +import Data.Word +import Data.Bits +import Data.Binary.Get +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Control.Applicative ((<$>)) +import Control.Monad.Reader +import Control.Monad.State +import Network.DBus.Signature + +data DbusEndian = LE | BE deriving (Show,Eq) +type DbusGet = (DbusEndian, Int) + +newtype GetWire a = GetWire { runGW :: ReaderT DbusGet Get a } + deriving (Monad, MonadReader DbusGet, Functor) + +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 +liftGet = GetWire . lift + +isWireEmpty :: GetWire Bool +isWireEmpty = liftGet isEmpty + +onEndian :: GetWire a -> GetWire a -> GetWire a +onEndian lef bef = ask >>= \(e, _) -> if e == LE then lef else bef + +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) + +getw8 :: GetWire Word8 +getw8 = liftGet getWord8 + +getw16 :: GetWire Word16 +getw16 = alignRead 2 >> onEndian (liftGet getWord16le) (liftGet getWord16be) + +getw32 :: GetWire Word32 +getw32 = alignRead 4 >> onEndian (liftGet getWord32le) (liftGet getWord32be) + +getw64 :: GetWire Word64 +getw64 = alignRead 8 >> onEndian (liftGet getWord64le) (liftGet getWord64be) + +getSignatureOne :: GetWire SignatureElem +getSignatureOne = do + 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 + +getVariant :: GetWire SignatureElem +getVariant = getSignatureOne + +getString :: GetWire ByteString +getString = do + nbBytes <- fromIntegral <$> getw32 + s <- liftGet $ getByteString nbBytes + _ <- getw8 + return s + +getObjectPath :: GetWire ByteString +getObjectPath = 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) + +type PutWireM a = State (Int, [ByteString]) a +type PutWire = PutWireM () + +putWire :: [PutWire] -> ByteString +putWire f = B.concat $ reverse $ snd $ execState (sequence_ f) (0, []) + +putBytes :: ByteString -> PutWire +putBytes s = modify (\(i, l) -> (i + B.length s, s : l)) + +alignWrite :: Int -> PutWire +alignWrite n = do + i <- fst <$> get + case i `mod` n of + 0 -> return () + x -> putBytes $ B.replicate (n - x) 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 + +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 + +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 + +putString :: ByteString -> PutWire +putString 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 + +putVariant :: SignatureElem -> PutWire +putVariant = putSignature . (:[]) + +putObjectPath :: ByteString -> PutWire +putObjectPath = putString diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +hs-udbus +======== + +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. + +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. + +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. + +Example +------- + +A simple example on how to use the interfaces is available at the root of the +package as DBus.hs diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/udbus.cabal b/udbus.cabal new file mode 100644 --- /dev/null +++ b/udbus.cabal @@ -0,0 +1,52 @@ +Name: udbus +Version: 0.1 +Description: Small and flexible implementation of the dbus protocol. +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +Synopsis: Small DBus implementation +Build-Type: Simple +Category: Network +stability: experimental +Cabal-Version: >=1.6 +Homepage: http://github.com/vincenthz/hs-udbus +data-files: README.md + +Flag test + Description: Build unit test + Default: False + +Flag executable + Description: Build the executable + Default: False + +Library + Build-Depends: base >= 3 && < 5 + , cereal >= 0.3.0 + , binary + , bytestring + , network + , mtl + , unix + , ghc-prim + Exposed-modules: Network.DBus + Other-modules: Network.DBus.IEEE754 + Network.DBus.Message + Network.DBus.Signature + Network.DBus.Type + Network.DBus.Wire + ghc-options: -Wall + +Executable dbus + Main-is: DBus.hs + if flag(executable) + Buildable: True + Build-Depends: network + else + Buildable: False + +source-repository head + type: git + location: git://github.com/vincenthz/hs-udbus