udbus (empty) → 0.1
raw patch · 11 files changed
+1090/−0 lines, 11 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, cereal, ghc-prim, mtl, network, unix
Files
- DBus.hs +45/−0
- LICENSE +27/−0
- Network/DBus.hs +176/−0
- Network/DBus/IEEE754.hs +14/−0
- Network/DBus/Message.hs +299/−0
- Network/DBus/Signature.hs +118/−0
- Network/DBus/Type.hs +130/−0
- Network/DBus/Wire.hs +188/−0
- README.md +39/−0
- Setup.hs +2/−0
- udbus.cabal +52/−0
+ DBus.hs view
@@ -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
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>++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.
+ Network/DBus.hs view
@@ -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))
+ Network/DBus/IEEE754.hs view
@@ -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)
+ Network/DBus/Message.hs view
@@ -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
+ Network/DBus/Signature.hs view
@@ -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)
+ Network/DBus/Type.hs view
@@ -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
+ Network/DBus/Wire.hs view
@@ -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
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ udbus.cabal view
@@ -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 <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+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