network-dbus (empty) → 0.0
raw patch · 7 files changed
+1304/−0 lines, 7 filesdep +basedep +binarydep +bytestringbuild-type:Customsetup-changed
Dependencies added: base, binary, bytestring, containers, mtl, network, parsec, unix, utf8-string
Files
- COPYING +16/−0
- Network/DBus/Connection.hs +304/−0
- Network/DBus/Message.hs +260/−0
- Network/DBus/Type.hs +205/−0
- Network/DBus/Value.hs +488/−0
- Setup.hs +9/−0
- network-dbus.cabal +22/−0
+ COPYING view
@@ -0,0 +1,16 @@++Copyright (c) 2007-2009, Will Thompson+Copyright (c) 2008-2009, Dafydd Harries++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+
+ Network/DBus/Connection.hs view
@@ -0,0 +1,304 @@++module Network.DBus.Connection (+ Connection(),+ ConnectionAddress(..),+ Handler,+ MatchClause(..),+ MatchRule,+ connectToBus,+ getSessionBusAddress,+ getSystemBusAddress,+ parseAddress,+ sendMessage,+ sendAndWait,+ addHandler,+ removeHandler,+ uniqueName+) where++import Control.Concurrent+import Control.Monad (forever, forM_, when)+import Data.List (intersperse)+import Data.Maybe (fromJust)+import Data.Typeable (cast)+import Data.Word+import Network.Socket+import Numeric (showHex)+import System.Environment (getEnvironment)+import System.IO+import System.Posix.User (getEffectiveUserID)++import Network.DBus.Message+import Network.DBus.Value++data MatchClause+ = MatchType MessageType+ | MatchSender DString+ | MatchInterface DString+ | MatchMember DString+ | MatchPath ObjectPath+ | MatchDestination DString+ | MatchArg Int DString+ deriving Show++type MatchRule = [MatchClause]++matchString :: MatchRule -> String+matchString = concat . intersperse "," . map toStr+ where toStr (MatchType t) = "type='" ++ typeToStr t ++ "'"+ toStr (MatchSender s) = "sender='" ++ getString s ++ "'"+ toStr (MatchInterface s) = "interface='" ++ getString s ++ "'"+ toStr (MatchMember s) = "member='" ++ getString s ++ "'"+ toStr (MatchPath o) = "path='" ++ getPath o ++ "'"+ toStr (MatchDestination s) = "destination='" ++ getString s ++ "'"+ toStr (MatchArg n s) = "arg" ++ show n ++ "='" ++ getString s ++ "'"++ typeToStr Signal = "signal"+ typeToStr MethodCall = "method_call"+ typeToStr MethodReturn = "method_return"+ typeToStr Error = "error"++match :: MatchRule -> Message -> Bool+match cs msg = all (flip matchClause msg) cs+ where Nothing =?= _ = False+ (Just x) =?= y = x == y++ [] # _ = Nothing+ (x:_) # 0 = Just x+ (_:xs) # n = xs # (n - 1)++ matchClause :: MatchClause -> Message -> Bool+ matchClause (MatchType t) m = (== t) . mType $ m+ matchClause (MatchSender s) m = (=?= s) . mSender $ m+ matchClause (MatchInterface s) m = (=?= s) . mInterface $ m+ matchClause (MatchMember s) m = (=?= s) . mMember $ m+ matchClause (MatchPath o) m = (=?= o) . mPath $ m+ matchClause (MatchDestination s) m = (=?= s) . mDestination $ m+ matchClause (MatchArg n s) m = case mBody m # n of+ Nothing -> False+ Just x -> (Variant s) == x++type Handler = Message -> IO ()++data Connection = Connection {+ cSerial :: MVar Word32,+ cSock :: Socket,+ cHandle :: Handle,+ cUniqueName :: DString,+ cThread :: ThreadId,+ cPendingCalls :: MVar [(Word32, MVar Message)],+ cHandlerSerial :: MVar Int,+ cHandlers :: MVar [(Int, Maybe MatchRule, Handler)] }++data ConnectionAddress =+ Unix { addrPath :: String, addrGuid :: Maybe String } |+ UnixAbstract { addrPath :: String, addrGuid :: Maybe String }+ deriving Show++uniqueName :: Connection -> DString+uniqueName = cUniqueName++getSessionBusAddress :: IO (Maybe ConnectionAddress)+getSessionBusAddress = do+ e <- getEnvironment+ return $ lookup "DBUS_SESSION_BUS_ADDRESS" e >>= parseAddress++getSystemBusAddress :: IO (Maybe ConnectionAddress)+getSystemBusAddress = do+ e <- getEnvironment+ return $ case lookup "DBUS_SYSTEM_BUS_ADDRESS" e of+ Just addr -> parseAddress addr+ Nothing -> Just $ Unix "/var/run/dbus/system_bus_socket" Nothing++splitOn :: (Eq a) => a -> [a] -> [[a]]+splitOn _ [] = []+splitOn e xs = let (before, after) = break (== e) xs+ in before : case after of+ [] -> []+ (_:xs') -> splitOn e xs'++-- Example:+-- unix:abstract=/tmp/dbus-Gxt8Av4CSA,guid=7515a79962a02df7ca39e3b049982f9e++parseAddress :: String -> Maybe ConnectionAddress+parseAddress str = do+ (addrType, pairsStr) <-+ case break (==':') str of+ (x, ':':y) -> Just (x, y)+ _ -> Nothing+ pairs <- parsePairs pairsStr+ let guid = lookup "guid" pairs+ case addrType of+ "unix" -> do+ case lookup "abstract" pairs of+ Just p -> Just $ UnixAbstract p guid+ Nothing -> case lookup "path" pairs of+ Just p -> Just $ Unix p guid+ Nothing -> fail "malformed unix address"+ _ -> fail "unknown address type"+ where parsePairs = mapM parsePair . splitOn ','+ parsePair xs = case break (== '=') xs of+ (name, ('=':value)) -> return (name, value)+ _ -> fail "bad pair"++hello :: Message+hello = methodCall+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkDString "Hello")+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkObjectPath "/org/freedesktop/DBus")+ []++sendMessage :: Connection -> Message -> IO Word32+sendMessage conn msg = modifyMVar (cSerial conn) $ \ s -> do+ writeMessage (cHandle conn) (msg { mSerial = s })+ hFlush (cHandle conn)+ return (s + 1, s)++sendExpectingReply :: Connection -> Message -> IO (MVar Message)+sendExpectingReply conn msg = do+ pc <- takeMVar (cPendingCalls conn)+ mvar <- newEmptyMVar+ serial <- sendMessage conn msg+ putMVar (cPendingCalls conn) $ (serial, mvar) : pc+ return mvar++sendAndWait :: Connection -> Message -> IO Message+sendAndWait conn msg = sendExpectingReply conn msg >>= takeMVar++receiveMessage :: Connection -> IO Message+receiveMessage conn = readMessage (cHandle conn)++hexEncode :: String -> String+hexEncode = concatMap (encodeByte . fromEnum)+ where encodeByte n+ | n < 16 = '0' : showHex n ""+ | otherwise = showHex n ""++authenticate :: Handle -> IO ()+authenticate handle = do+ hPutChar handle '\0'+ -- XXX: do this properly+ uid <- getEffectiveUserID+ let auth = concat ["AUTH EXTERNAL ", hexEncode . show $ uid, "\r\n"]+ hPutStr handle auth+ hFlush handle+ response <- hGetLine handle+ case words response of+ ["OK", _] -> hPutStr handle "BEGIN\r\n" >> hFlush handle+ _ -> fail "authentication failed"++lookupRemoveBy :: (a -> Maybe b) -> [a] -> Maybe (b, [a])+lookupRemoveBy f l = loop l id+ where loop [] _ = Nothing+ loop (x:xs) g = case f x of+ Nothing -> loop xs (g . (x:))+ Just y -> Just (y, g xs)++addHandler :: Connection -> Maybe MatchRule -> Handler -> IO Int+addHandler conn rule f = do+ hid <- modifyMVar (cHandlerSerial conn) $ \s -> return (s + 1, s)+ modifyMVar_ (cHandlers conn) $ \handlers ->+ return $ (hid, rule, f) : handlers+ case rule of+ Nothing -> return ()+ -- XXX: catch errors?+ -- XXX: wait for reply?+ Just rule' -> do+ sendMessage conn $ addMatch (mkDString0 $ matchString rule')+ return ()+ return hid++ where addMatch :: DString -> Message+ addMatch = methodCall+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkDString "AddMatch")+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkObjectPath "/org/freedesktop/DBus")+ . (:[]) . Variant++removeHandler :: Connection -> Int -> IO ()+removeHandler conn hid = do+ rule <- modifyMVar (cHandlers conn) $ \handlers ->+ case lookupRemoveBy (\(hid', rule, _) ->+ if hid' == hid then Just rule else Nothing) handlers of+ Nothing -> return (handlers, Nothing)+ Just (rule, handlers') -> return (handlers', rule)+ case rule of+ Nothing -> return ()+ -- XXX: catch errors?+ -- XXX: wait for reply?+ Just rule' -> do+ sendMessage conn $ removeMatch (matchString rule')+ return ()++ where removeMatch :: String -> Message+ removeMatch = methodCall+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkDString "RemoveMatch")+ (fromJust $ mkDString "org.freedesktop.DBus")+ (fromJust $ mkObjectPath "/org/freedesktop/DBus")+ . (:[]) . Variant++-- XXX: perhaps:+-- withHandler :: Connection -> Maybe MatchRule -> Handler -> IO a -> IO a++lookupRemove :: Eq a => a -> [(a, b)] -> Maybe (b, [(a, b)])+lookupRemove x = lookupRemoveBy (\(a, b) -> if a == x then Just b else Nothing)++receiveLoop :: Connection -> IO ()+receiveLoop conn = forever $ receiveMessage conn >>= \msg -> do+ case mReplySerial msg of+ Nothing -> return ()+ Just serial -> modifyMVar_ (cPendingCalls conn) $ \pc -> do+ case lookupRemove serial pc of+ -- XXX: catch BlockedOnDeadMVar+ Just (mvar, pc') -> putMVar mvar msg >> return pc'+ Nothing -> return pc++ ms <- readMVar (cHandlers conn)+ -- XXX: this is O(n) in the number of handlers+ forM_ ms $ \(_, rule', handler) ->+ case rule' of+ Nothing -> handler msg >> return ()+ Just rule -> when (match rule msg) (handler msg >> return ())++connectToBus :: ConnectionAddress -> IO Connection+connectToBus dbusAddr = do+ sock <- socket AF_UNIX Stream 0+ let addr = sockAddr dbusAddr+ Network.Socket.connect sock addr+ handle <- socketToHandle sock ReadWriteMode++ authenticate handle++ writeMessage handle $ hello { mSerial = 1 }+ hFlush handle+ reply <- readMessage handle+ name <- case mBody reply of+ [Variant name] -> return $ fromJust (cast name)+ _ -> fail "Hello() call failed during connection"++ serial <- newMVar 2+ pendingCalls <- newMVar []+ handlerSerial <- newMVar 0+ handlers <- newMVar []+ let conn = Connection {+ cSerial = serial,+ cSock = sock,+ cHandle = handle,+ cUniqueName = name,+ cThread = undefined,+ cPendingCalls = pendingCalls,+ cHandlerSerial = handlerSerial,+ cHandlers = handlers+ }+ threadId <- forkIO $ receiveLoop conn+ return $ conn { cThread = threadId }++ where++ sockAddr :: ConnectionAddress -> SockAddr+ sockAddr Unix { addrPath = path } = SockAddrUnix $ path+ sockAddr UnixAbstract { addrPath = path } = SockAddrUnix $ '\0' : path+
+ Network/DBus/Message.hs view
@@ -0,0 +1,260 @@++module Network.DBus.Message (+ Message(..),+ MessageType(..),+ Flag(..),+ dbusProtocolVersion,+ endiannessValue,+ readMessage,+ writeMessage,+ deserializeMessage,+ serializeMessage,+ methodCall+) where++import Control.Monad (liftM3, when)+import Data.Bits ((.|.), (.&.))+import Data.Char (ord)+import Data.List (foldl')+import Data.Maybe (fromJust)+import Data.Typeable (cast)+import Data.Word+import System.IO (Handle)++import qualified Control.Monad.State as S+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as BS++import Network.DBus.Type+import Network.DBus.Value++data MessageType = MethodCall+ | MethodReturn+ | Error+ | Signal+ deriving (Show, Enum, Eq)++endiannessValue :: Endianness -> Word8+endiannessValue e = fromIntegral . ord $ case e of+ LittleEndian -> 'l'+ BigEndian -> 'B'++data Flag = NoReplyExpected+ | NoAutoStart+ deriving (Eq, Show)++flagValue :: Flag -> Word8+flagValue f = case f of NoReplyExpected -> 0x1+ NoAutoStart -> 0x2++flagsValue :: [Flag] -> Word8+flagsValue = foldl' (.|.) 0 . map flagValue++decodeFlags :: Word8 -> [Flag]+decodeFlags 0 = []+decodeFlags n | n .&. 0x1 /= 0 = NoReplyExpected : decodeFlags (n - 0x1)+ | n .&. 0x2 /= 0 = NoAutoStart : decodeFlags (n - 0x2)+ | otherwise = error $ "unrecognised flag value " ++ show n++dbusProtocolVersion :: Word8+dbusProtocolVersion = 1++data Message = Message { mType :: MessageType+ , mFlags :: [Flag]+ , mSerial :: Word32+ , mPath :: Maybe ObjectPath+ , mInterface :: Maybe DString+ , mMember :: Maybe DString+ , mErrorName :: Maybe DString+ , mReplySerial :: Maybe Word32+ , mDestination :: Maybe DString+ , mSender :: Maybe DString+ , mBody :: [Variant]+ }+ deriving (Eq, Show)++nativeEndianness :: Endianness+nativeEndianness = case BS.unpack . runPut $ putWord16host 1 of+ [0, 1] -> BigEndian+ _ -> LittleEndian+++decodeFields :: [(Word8, Variant)] ->+ (Maybe ObjectPath, Maybe DString, Maybe DString, Maybe DString,+ Maybe Word32, Maybe DString, Maybe DString, Maybe Signature)+decodeFields fs = (path, iface, member, err, rs, dest, sender, sig)+ where decode (Variant x) = fromJust . cast $ x+ path = decode `fmap` lookup 1 fs+ iface = decode `fmap` lookup 2 fs+ member = decode `fmap` lookup 3 fs+ err = decode `fmap` lookup 4 fs+ rs = decode `fmap` lookup 5 fs+ dest = decode `fmap` lookup 6 fs+ sender = decode `fmap` lookup 7 fs+ sig = decode `fmap` lookup 8 fs++parseInit = do+ e <- getWord8 >>= \b ->+ case toEnum . fromIntegral $ b of+ 'B' -> return BigEndian+ 'l' -> return LittleEndian+ c -> fail $ "bad endianness " ++ show c+ t <- getWord8 >>= return . toEnum . (subtract 1) . fromIntegral+ f <- getWord8 >>= return . decodeFlags+ v <- getWord8+ let getWord32 = case e of BigEndian -> getWord32be+ LittleEndian -> getWord32le+ (bl, s, fl) <- liftM3 (,,) getWord32 getWord32 getWord32+ return (e, t :: MessageType, f :: [Flag], v, bl, s, fl)++-- XXX: duplication with readMessage++deserializeMessage :: BS.ByteString -> (Message, BS.ByteString)+deserializeMessage = runGet $ do+ initBuf <- lookAhead $ getLazyByteString 16+ (endianness, type_, flags, _version, bodyLength, serial, fieldsLength)+ <- parseInit++ -- XXX: Error if version isn't 1.++ fieldsBuf <- getLazyByteString . fromIntegral $ fieldsLength+ let (path, iface, member, err, rs, dest, sender, sig) =+ decodeFields $ runDeserializer endianness+ (do S.lift (skip 12)+ deserializer :: Deserializer [(Word8, Variant)]) $+ initBuf `BS.append` fieldsBuf+ bytesCount = 16 + BS.length fieldsBuf+ offset = bytesCount `mod` 8+ paddingBytes = if offset == 0 then 0 else 8 - offset++ -- skip padding+ padding <- getLazyByteString (fromIntegral paddingBytes)+ when (not $ BS.all (== 0) padding) $+ fail $ "non-null bytes in padding"++ body <- case sig of+ Nothing -> return []+ Just ts ->+ runDeserializer endianness (deserializeAs ts) `fmap`+ (getLazyByteString . fromIntegral $ bodyLength)+ rest <- getRemainingLazyByteString++ let msg = Message {+ mType = type_,+ mFlags = flags,+ mSerial = serial,+ mPath = path,+ mInterface = iface,+ mMember = member,+ mErrorName = err,+ mReplySerial = rs,+ mDestination = dest,+ mSender = sender,+ mBody = body }+ return (msg, rest)++-- XXX: duplication with deserializeMessage++readMessage :: Handle -> IO Message+readMessage handle = do+ initBuf <- BS.hGet handle 16+ let (endianness, type_, flags, _version, bodyLength, serial, fieldsLength)+ = runGet parseInit initBuf++ -- XXX: Error if version isn't 1.++ fieldsBuf <- BS.hGet handle . fromIntegral $ fieldsLength+ let (path, iface, member, err, rs, dest, sender, sig) =+ decodeFields $ runDeserializer endianness+ (do S.lift (skip 12)+ deserializer :: Deserializer [(Word8, Variant)]) $+ initBuf `BS.append` fieldsBuf+ bytesCount = 16 + BS.length fieldsBuf+ offset = bytesCount `mod` 8+ paddingBytes = if offset == 0 then 0 else 8 - offset++ -- skip padding+ padding <- BS.hGet handle (fromIntegral paddingBytes)+ when (not $ BS.all (== 0) padding) $+ fail $ "non-null bytes in padding"++ body <- case sig of+ Nothing -> return []+ Just ts -> do+ bodyBuf <- BS.hGet handle . fromIntegral $ bodyLength+ return $ runDeserializer endianness (deserializeAs ts) bodyBuf++ return $ Message {+ mType = type_,+ mFlags = flags,+ mSerial = serial,+ mPath = path,+ mInterface = iface,+ mMember = member,+ mErrorName = err,+ mReplySerial = rs,+ mDestination = dest,+ mSender = sender,+ mBody = body }++encodeFields :: Message -> [(Word8, Variant)]+encodeFields m = concat [+ extract 1 mPath m,+ extract 2 mInterface m,+ extract 3 mMember m,+ extract 4 mErrorName m,+ extract 5 mReplySerial m,+ extract 6 mDestination m,+ extract 7 mSender m,+ case mBody m of+ [] -> []+ xs -> [(8, Variant $ sig xs)]]+ where extract n rec = maybe [] (\v -> [(n, Variant v)]) . rec+ sig = Signature . map (\(Variant v) -> dtype v)++serializeMessage :: Message -> BS.ByteString+serializeMessage m = runPut $ do+ let e = nativeEndianness+ putWord8 . fromIntegral . fromEnum . endiannessValue $ e+ putWord8 . fromIntegral . (+1) . fromEnum . mType $ m+ putWord8 . flagsValue . mFlags $ m+ putWord8 dbusProtocolVersion++ let fields = runSerializer e $ do+ advanceBy 12+ serializer . encodeFields $ m+ padTo 8+ body = runSerializer e $ do+ advanceBy $ 12 + fromIntegral (BS.length fields)+ mapM_ (\(Variant v) -> serializer v) $ mBody m++ let putWord32 = case e of BigEndian -> putWord32be+ LittleEndian -> putWord32le++ putWord32 . fromIntegral . BS.length $ body+ putWord32 . mSerial $ m+ putLazyByteString fields+ putLazyByteString body++writeMessage :: Handle -> Message -> IO ()+writeMessage handle m = BS.hPutStr handle . serializeMessage $ m++-- XXX: reorder arguments for curring?++methodCall :: DString -> DString -> DString -> ObjectPath -> [Variant] ->+ Message+methodCall interface member destination path body = Message {+ mType = MethodCall,+ mFlags = [],+ mSerial = 1,+ mPath = Just path,+ mInterface = Just interface,+ mMember = Just member,+ mErrorName = Nothing,+ mReplySerial = Nothing,+ mDestination = Just destination,+ mSender = Nothing,+ mBody = body }++-- vim: sts=2 sw=2 et
+ Network/DBus/Type.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++module Network.DBus.Type (+ DBasicType(..),+ DType(..),+ Signature(..),+ hasExcessiveNesting,+ prettyType -- For debugging!+) where++import Data.List (intersperse)+import Data.Typeable (Typeable)+import Data.Maybe (fromJust)+import Text.ParserCombinators.Parsec++import qualified Data.Map as M++data DBasicType = DTypeByte+ | DTypeBoolean+ | DTypeInt16+ | DTypeInt32+ | DTypeInt64+ | DTypeUInt16+ | DTypeUInt32+ | DTypeUInt64+ | DTypeDouble+ | DTypeString+ | DTypeObjectPath+ | DTypeSignature+ deriving (Eq, Ord, Typeable)++data DType = DBasicType DBasicType+ | DTypeArray DType+ | DTypeStruct DType [DType] -- enforce non-empty contents+ | DTypeVariant+ | DTypeDictEntry DBasicType DType+ deriving (Eq, Ord, Typeable)++newtype Signature = Signature [DType]+ deriving (Eq, Ord, Typeable)++instance Show Signature where+ show (Signature ts) = ts >>= show++instance Read Signature where+ readsPrec _ s =+ case tryParseSignature s of+ Left _ -> []+ Right t -> [(t,"")]++hasExcessiveNesting :: DType -> Bool+hasExcessiveNesting v =+ let hen a s t =+ if (a > 32 || s > 32)+ then True+ else case t of+ (DTypeArray u) -> hen (a + 1) s u+ (DTypeStruct u us) -> any (hen a (s + 1)) (u:us)+ (DTypeDictEntry _ u) -> hen a s u+ _ -> False+ in hen (0 :: Int) (0 :: Int) v++instance Show DBasicType where+ show DTypeByte = "y"+ show DTypeBoolean = "b"+ show DTypeInt16 = "n"+ show DTypeUInt16 = "q"+ show DTypeInt32 = "i"+ show DTypeUInt32 = "u"+ show DTypeInt64 = "x"+ show DTypeUInt64 = "t"+ show DTypeDouble = "d"+ show DTypeString = "s"+ show DTypeObjectPath = "o"+ show DTypeSignature = "g"++instance Show DType where+ showsPrec _n t = case t of+ (DBasicType b) -> sho b+ (DTypeArray s) -> showChar 'a' . sho s+ (DTypeVariant) -> showChar 'v'+ (DTypeDictEntry k v) -> showChar '{' . sho k . sho v . showChar '}'+ (DTypeStruct u us) -> showParen True . foldl1 (.) $ map sho (u:us)+-- (DTypeStruct t ts) -> showParen (n > 0) . foldl1 (.) $ map sho (t:ts)+ where sho :: Show a => a -> ShowS+ sho = showsPrec 1++instance Read DType where+ readsPrec _ ty = case tryParseSingleType ty of+ Left _ -> []+ Right t -> [(t,"")]++class PrettyType t where+ prettyType :: t -> String++pp :: PrettyType t => t -> String+pp = prettyType++instance PrettyType DBasicType where+ prettyType t = case t of+ DTypeByte -> "Byte"+ DTypeBoolean -> "Boolean"+ DTypeInt16 -> "Int16"+ DTypeUInt16 -> "UInt16"+ DTypeInt32 -> "Int32"+ DTypeUInt32 -> "UInt32"+ DTypeInt64 -> "Int64"+ DTypeUInt64 -> "UInt64"+ DTypeDouble -> "Double"+ DTypeString -> "String"+ DTypeObjectPath -> "ObjectPath"+ DTypeSignature -> "Signature"++instance PrettyType DType where+ prettyType ct = case ct of+ (DBasicType t) -> prettyType t+ (DTypeArray t) -> "Array of " ++ pp t+ (DTypeStruct t ts) -> "Struct of ("+ ++ (glueWith ", " $ map pp (t:ts))+ ++ ")"+ (DTypeVariant) -> "Variant"+ (DTypeDictEntry k v) -> "DictEntry " ++ pp k ++ " => " ++ pp v+ where glueWith x = concat . intersperse x++-- parsing of signatures++tryParseSignature :: String -> Either ParseError Signature+tryParseSignature = parse parseSignature "<signature>"++parseSignature :: Parser Signature+parseSignature = do (t:ts) <- many1 parseType <?> "at least one type"+ eof+ return (Signature (t:ts))++tryParseSingleType :: String -> Either ParseError DType+tryParseSingleType = parse parseSingleType "<type>"++parseSingleType :: Parser DType+parseSingleType = do t <- parseType <?> "a single type"+ eof+ return t+++parseType :: Parser DType+parseType = choice [ parseBasicTypeWrapped+ , parseArray+ , parseStruct+ , parseVariant+ ]++parseBasicTypeWrapped :: Parser DType+parseBasicTypeWrapped = do bt <- parseBasicType+ return $ DBasicType bt++basicTypes :: M.Map Char DBasicType+basicTypes = M.fromList [ ('y', DTypeByte)+ , ('b', DTypeBoolean)+ , ('n', DTypeInt16)+ , ('q', DTypeUInt16)+ , ('i', DTypeInt32)+ , ('u', DTypeUInt32)+ , ('x', DTypeInt64)+ , ('t', DTypeUInt64)+ , ('d', DTypeDouble)+ , ('s', DTypeString)+ , ('o', DTypeObjectPath)+ , ('g', DTypeSignature)+ ]++parseBasicType :: Parser DBasicType+parseBasicType = do c <- oneOf sekritCodes+ return . fromJust $ M.lookup c basicTypes+ <?> "basic type [one of " ++ sekritCodes ++ "]"+ where sekritCodes = M.keys basicTypes++parseArray :: Parser DType+parseArray = do char 'a'+ t <- (parseType <?> "array contents type")+ <|>+ (parseDictEntry)+ return $ DTypeArray t+ <?> "array a*"++parseStruct :: Parser DType+parseStruct = do char '('+ (t:ts) <- many1 parseType+ <?> "at least one type within the struct"+ char ')' <?> "closing paren for struct"+ return $ DTypeStruct t ts+ <?> "struct (*)"++parseVariant :: Parser DType+parseVariant = do char 'v'+ return DTypeVariant+ <?> "variant v"++parseDictEntry :: Parser DType+parseDictEntry = do char '{'+ k <- parseBasicType <?> "basic type (as dict key)"+ v <- parseType <?> "dict value type"+ char '}' <?> "closing brace of dict entry"+ return $ DTypeDictEntry k v+ <?> "dict entry {**}"++-- vim: set sts=2 sw=2 et
+ Network/DBus/Value.hs view
@@ -0,0 +1,488 @@+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables,+ GeneralizedNewtypeDeriving, DeriveDataTypeable+ #-}++module Network.DBus.Value (+ Endianness(..),++ DValue(..), DBasicTypedValue(..),++ ObjectPath, mkObjectPath, getPath, -- constructor not exported++ DString, mkDString, mkDString0, getString,++ Variant(..), fromVariant,++ Bytes, Serializer, runSerializer, advanceBy, padTo,+ Deserializer, runDeserializer, skipTo, deserializeAs+) where++import Control.Monad (when, forM_, liftM2, liftM3, liftM4, liftM5)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)+import Data.Char (chr, ord)+import Foreign (Ptr, alloca, castPtr, peek, poke)+import System.IO.Unsafe (unsafePerformIO)++import qualified Control.Monad.State as S+import qualified Control.Monad.Reader as R+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as BS8+import qualified Data.Map as M+import qualified Data.Typeable as T++import Data.Binary.Get+import Data.Binary.Put++import Network.DBus.Type (DBasicType(..), DType(..), Signature(..))++data Endianness = LittleEndian+ | BigEndian+ deriving Show++type Bytes = Int++bigLittle :: a -> a -> Endianness -> a+bigLittle b l e = case e of BigEndian -> b+ LittleEndian -> l++padding :: Int -> Int -> Int+padding position alignment = let offset = position `mod` alignment+ in if offset > 0 then alignment - offset else 0++--+-- Serialization fu+--++type Serializer = R.ReaderT Endianness (S.StateT Bytes PutM) ()++runSerializer :: Endianness -> Serializer -> LBS.ByteString+runSerializer e s = runPut (S.runStateT (R.runReaderT s e) 0 >> return ())++advanceBy :: Bytes -> Serializer+advanceBy n = R.lift $ S.modify (+n)++padTo :: Bytes -> Serializer+padTo alignment = do+ pos <- R.lift S.get+ let bytes = padding pos alignment+ when (bytes > 0) $ R.lift $ S.lift (sequence_ . replicate bytes $ putWord8 0)+ advanceBy bytes++basicSerializer :: DValue a => (a -> Put) -> (a -> Put) -> a -> Serializer+basicSerializer b l thing = do+ padTo $ alignment thing+ e <- R.ask+ R.lift $ S.lift $ bigLittle b l e $ thing+ advanceBy $ alignment thing++--+-- Deserialization fu+--++type Deserializer a = R.ReaderT Endianness Get a++runDeserializer :: Endianness -> Deserializer a -> LBS.ByteString -> a+runDeserializer e d = runGet $ R.runReaderT d e++basicDeserializer :: forall a. DValue a => Get a -> Get a -> Deserializer a+basicDeserializer b l = do+ skipTo $ alignment (undefined :: a)+ R.ask >>= R.lift . bigLittle b l++skipTo :: Bytes -> Deserializer ()+skipTo alignment = do+ pos <- R.lift $ fromIntegral `fmap` bytesRead+ let jump = padding pos alignment+ when (jump > 0) $ do+ bytes <- R.lift (getByteString jump)+ when (not . BS.all (== 0) $ bytes) $ error "bad padding"++--+-- Value classes+--++class (Eq a, Show a, T.Typeable a) => DValue a where+ dtype :: a -> DType+ alignment :: a -> Bytes+ serializer :: a -> Serializer+ deserializer :: Deserializer a++class (DValue a, Ord a) => DBasicTypedValue a where+ dbasictype :: a -> DBasicType+ dbasictype x = let DBasicType t = dtype x in t++--+-- ObjectPath type wrapping Strings with mkObjectPath ensuring that the various+-- rules about object paths are respected.+--++newtype ObjectPath = MkObjectPath String+ deriving (Eq, Ord, T.Typeable)+instance Show ObjectPath where+ show (MkObjectPath path) = show path++getPath :: ObjectPath -> String+getPath (MkObjectPath p) = p++splitOn :: Eq a => a -> [a] -> [[a]]+splitOn c xs =+ let (foo, bar) = break (== c) xs+ in case bar of+ (_:bs) -> foo:splitOn c bs+ [] -> [foo]++mkObjectPath :: Monad m => String -> m ObjectPath+mkObjectPath [] = fail "object paths must be non-empty"+mkObjectPath str@(x:xs) = do+ when (x /= '/') $ fail "object paths must begin with /"+ when (any (`notElem` validChars) str) $+ fail ("object paths may only contain chars from '" ++ validChars ++ "'")+ when (not (null xs) && any null (splitOn '/' xs)) $+ fail "no element of an object path may be the empty string"+ return $ MkObjectPath str+ where validChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_/"++--+-- DString type wrapping Strings with mkDString ensuring there are no null+-- bytes.+--++newtype DString = MkDString { getString :: String }+ deriving (Eq, Ord, T.Typeable)++instance Show DString where+ show = show . getString++mkDString :: Monad m => String -> m DString+mkDString str = do+ when ('\NUL' `elem` str) $ fail "null bytes not allowed in D-Bus strings"+ return $ MkDString str++mkDString0 :: String -> DString+mkDString0 = MkDString . (filter (/= '\NUL'))++--+-- DBasicTypedValue instances+--++instance DBasicTypedValue ObjectPath where+instance DValue ObjectPath where+ dtype _ = DBasicType DTypeObjectPath+ alignment _ = 4+ serializer (MkObjectPath s) = serializer (MkDString s)+ deserializer = MkObjectPath `fmap` getString `fmap` deserializer++instance DBasicTypedValue Bool where+instance DValue Bool where+ dtype _ = DBasicType DTypeBoolean+ alignment _ = 4+ serializer b = serializer ((if b then 1 else 0) :: Word32)+ deserializer = do (b :: Word32) <- deserializer+ case b of+ 1 -> return True+ 0 -> return False+ _ -> fail "bad boolean value"++-- Useful, but you can't do [Char] without getting DTypeString+-- It's also a bit of a lie because characters are truncated FIXME:UTF-8+instance DBasicTypedValue Char where+instance DValue Char where+ dtype _ = DBasicType DTypeByte+ alignment _ = 1+ serializer c = let word = fromIntegral $ ord c :: Word8+ in serializer word+ deserializer = chr `fmap` fromIntegral+ `fmap` (deserializer :: Deserializer Word8)++instance DBasicTypedValue Word8 where+instance DValue Word8 where+ dtype _ = DBasicType DTypeByte+ alignment _ = 1+ serializer x = (R.lift $ S.lift $ putWord8 x) >> advanceBy 1 >> return ()+ deserializer = S.lift getWord8++instance DBasicTypedValue Word16 where+instance DValue Word16 where+ dtype _ = DBasicType DTypeUInt16+ alignment _ = 2+ serializer = basicSerializer putWord16be putWord16le+ deserializer = basicDeserializer getWord16be getWord16le++instance DBasicTypedValue Word32 where+instance DValue Word32 where+ dtype _ = DBasicType DTypeUInt32+ alignment _ = 4+ serializer = basicSerializer putWord32be putWord32le+ deserializer = basicDeserializer getWord32be getWord32le++instance DBasicTypedValue Word64 where+instance DValue Word64 where+ dtype _ = DBasicType DTypeUInt64+ alignment _ = 8+ serializer = basicSerializer putWord64be putWord64le+ deserializer = basicDeserializer getWord64be getWord64le++instance DBasicTypedValue Int16 where+instance DValue Int16 where+ dtype _ = DBasicType DTypeInt16+ alignment _ = 2+ serializer = basicSerializer (putWord16be . fromIntegral)+ (putWord16le . fromIntegral)+ deserializer = basicDeserializer (fromIntegral `fmap` getWord16be)+ (fromIntegral `fmap` getWord16le)++instance DBasicTypedValue Int32 where+instance DValue Int32 where+ dtype _ = DBasicType DTypeInt32+ alignment _ = 4+ serializer = basicSerializer (putWord32be . fromIntegral)+ (putWord32le . fromIntegral)+ deserializer = basicDeserializer (fromIntegral `fmap` getWord32be)+ (fromIntegral `fmap` getWord32le)++instance DBasicTypedValue Int64 where+instance DValue Int64 where+ dtype _ = DBasicType DTypeInt64+ alignment _ = 8+ serializer = basicSerializer (putWord64be . fromIntegral)+ (putWord64le . fromIntegral)+ deserializer = basicDeserializer (fromIntegral `fmap` getWord64be)+ (fromIntegral `fmap` getWord64le)++-- Nasty.++doubleToWord64 :: Double -> Word64+doubleToWord64 d = unsafePerformIO $ alloca $+ \(p :: Ptr Double) -> poke p d >> peek (castPtr p :: Ptr Word64)++word64ToDouble :: Word64 -> Double+word64ToDouble w = unsafePerformIO $ alloca $+ \(p :: Ptr Word64) -> poke p w >> peek (castPtr p :: Ptr Double)++instance DBasicTypedValue Double where+instance DValue Double where+ dtype _ = DBasicType DTypeDouble+ alignment _ = 8+ serializer = basicSerializer (putWord64be . doubleToWord64)+ (putWord64le . doubleToWord64)+ deserializer = basicDeserializer (word64ToDouble `fmap` getWord64be)+ (word64ToDouble `fmap` getWord64le)++getNull :: R.ReaderT Endianness Get ()+getNull = do+ c :: Word8 <- deserializer+ when (c /= 0) $ fail $ "expecting null byte, got " ++ show c++instance DBasicTypedValue DString where+instance DValue DString where+ dtype _ = DBasicType DTypeString+ alignment _ = 4+ serializer (MkDString s) = do+ let bytes = BS8.fromString s+ serializer (fromIntegral (BS.length bytes) :: Word32)+ mapM_ serializer . BS.unpack $ bytes+ serializer (0 :: Word8)+ deserializer = do+ l <- fromIntegral `fmap` (deserializer :: Deserializer Word32)+ s <- S.lift $ getByteString l+ getNull+ return . MkDString . BS8.toString $ s++instance DBasicTypedValue Signature where+instance DValue Signature where+ dtype _ = DBasicType DTypeSignature+ alignment _ = 1+ serializer s = do+ -- XXX: duplication of String serializer+ let s' = show s+ let l = length s'+ when (l > 255) $ fail "signatures must be no more than 255 bytes long."+ serializer (fromIntegral l :: Word8)+ let bytes = map (fromIntegral . ord) s' :: [Word8]+ mapM_ serializer bytes+ serializer (0 :: Word8)+ deserializer = do+ -- XXX: duplication of String deserializer+ l <- fromIntegral `fmap` S.lift getWord8+ s <- read `fmap` map (chr . fromIntegral)+ `fmap` BS.unpack+ `fmap` S.lift (getByteString l)+ getNull+ return s++data Variant = forall v. DValue v => Variant { unVariant :: v }+ deriving T.Typeable++fromVariant :: T.Typeable a => Variant -> Maybe a+fromVariant (Variant v) = T.cast v++instance Show Variant where+ showsPrec n (Variant v) =+ showParen (n > 0) ( showString "Variant "+ . showParen True (showsPrec (n+1) v)+ . showString " {- "+ . showsPrec 0 (dtype v)+ . showString " -}"+ )++instance Eq Variant where+ (Variant (x :: a)) == (Variant (y :: b)) = Just x == T.cast y++instance DValue Variant where+ dtype _ = DTypeVariant+ alignment _ = 1+ serializer (Variant v) = do+ serializer (Signature [dtype v])+ serializer v+ deserializer = do+ Signature [t] <- deserializer+ case mkDummy t of+ Dummy (_ :: a) -> Variant `fmap` (deserializer :: Deserializer a)++data Dummy = forall a. DValue a => Dummy a+data BasicDummy = forall a. DBasicTypedValue a => BasicDummy a++mkBasicDummy :: DBasicType -> BasicDummy+mkBasicDummy bt = case bt of+ DTypeByte -> BasicDummy (undefined :: Word8)+ DTypeBoolean -> BasicDummy (undefined :: Bool)+ DTypeInt16 -> BasicDummy (undefined :: Int16)+ DTypeInt32 -> BasicDummy (undefined :: Int32)+ DTypeInt64 -> BasicDummy (undefined :: Int64)+ DTypeUInt16 -> BasicDummy (undefined :: Word16)+ DTypeUInt32 -> BasicDummy (undefined :: Word32)+ DTypeUInt64 -> BasicDummy (undefined :: Word64)+ DTypeDouble -> BasicDummy (undefined :: Double)+ DTypeString -> BasicDummy (undefined :: DString)+ DTypeObjectPath -> BasicDummy (undefined :: ObjectPath)+ DTypeSignature -> BasicDummy (undefined :: Signature)++mkDummy :: DType -> Dummy+mkDummy t =+ case t of+ DBasicType bt -> case mkBasicDummy bt of BasicDummy x -> Dummy x+ DTypeVariant -> Dummy (Variant "ouroburos")+ -- heh. if you write this as let Dummy subdummy = ..., GHC says:+ -- My brain just exploded.+ DTypeArray u -> case u of+ -- using the types of Dummy values here requires PatternSignatures+ DTypeDictEntry keybt valt ->+ case mkBasicDummy keybt of+ BasicDummy (_keydummy :: k) -> case mkDummy valt of+ Dummy (_valdummy :: v) -> Dummy (M.empty :: M.Map k v)+ _ -> case mkDummy u of Dummy subdummy -> Dummy [subdummy]+ DTypeStruct u us -> let dummies = map mkDummy (u:us)+ in case dummies of+ [] -> error "world ended, this isn't possible."+ [Dummy _d1] -> error "Shit shit we don't support 1-element structs"+ [Dummy d1, Dummy d2] -> Dummy (d1, d2)+ [Dummy d1, Dummy d2, Dummy d3] -> Dummy (d1, d2, d3)+ [Dummy d1, Dummy d2, Dummy d3, Dummy d4] -> Dummy (d1, d2, d3, d4)+ [Dummy d1, Dummy d2, Dummy d3, Dummy d4, Dummy d5] -> Dummy (d1, d2, d3, d4, d5)+ _ -> error "FIXME: add more cases to mkDummy DTypeStruct when more tuple instances are added"+ DTypeDictEntry _ _ -> error "DTypeDictEntry is only valid as the element type of DTypeArray"++deserializeAs :: Signature -> Deserializer [Variant]+deserializeAs (Signature ts) = mapM magic ts+ where magic t = case mkDummy t of+ Dummy (_ :: b) ->+ Variant `fmap` (deserializer :: Deserializer b)++-- Used rather than "undefined" to help track down bugs wherein it gets+-- evaluated.+undefinedAt :: String -> a+undefinedAt = error . ("DValue " ++)++-- Instances for containers++instance (DBasicTypedValue k, DValue v) => DValue (M.Map k v) where+ dtype _ = let kType = dbasictype (undefinedAt "Map key" :: k)+ vType = dtype (undefinedAt "Map value" :: v)+ in DTypeArray (DTypeDictEntry kType vType)+ alignment _ = 4+ serializer = serializer . M.toList+ deserializer = M.fromList `fmap` deserializer++instance DValue a => DValue [a] where+ dtype _ = let t = dtype (undefinedAt "[]" :: a)+ in DTypeArray t+ alignment _ = 4+ serializer vs = do+ padTo 4+ pos <- R.lift S.get+ e <- R.ask+ let paddingLength = LBS.length $ runSerializer e $ do+ advanceBy (pos + 4)+ padTo $ alignment (undefined :: a)+ bytes = runSerializer e $ do+ advanceBy (pos + 4)+ padTo $ alignment (undefined :: a)+ mapM_ serializer vs+ l = LBS.length bytes - paddingLength+ when (l > (2^(26::Int))) $ fail "arrays cannot be longer than 2^26 :-/"+ serializer (fromIntegral l :: Word32)+ R.lift $ S.lift $ putLazyByteString bytes+ advanceBy . fromIntegral . LBS.length $ bytes+ deserializer = do+ l <- fromIntegral `fmap` (deserializer :: Deserializer Word32)+ skipTo $ alignment (undefined :: a)+ start <- fromIntegral `fmap` S.lift bytesRead+ go l start+ where go :: Int64 -> Int64 -> Deserializer [a]+ go n pos | n < 0 = fail "too few bytes in array"+ | n == 0 = return []+ | otherwise = do+ x <- deserializer+ pos' <- fromIntegral `fmap` S.lift bytesRead+ xs <- go (n + pos - pos') pos'+ return (x : xs)++instance (DValue a, DValue b) => DValue (a, b) where+ dtype _ = DTypeStruct (dtype (undefinedAt "(a,)" :: a))+ [dtype (undefinedAt "(,b)" :: b)]+ alignment _ = 8+ serializer (x, y) = padTo 8 >> serializer x >> serializer y+ deserializer = skipTo 8 >> liftM2 (,) deserializer deserializer++instance (DValue a, DValue b, DValue c) => DValue (a, b, c) where+ dtype _ = DTypeStruct (dtype (undefinedAt "(a,,)" :: a))+ [dtype (undefinedAt "(,b,)" :: b)+ ,dtype (undefinedAt "(,,c)" :: c)+ ]+ alignment _ = 8+ serializer (x,y,z) = padTo 8 >> serializer x >> serializer y+ >> serializer z+ deserializer = skipTo 8 >> liftM3 (,,)+ deserializer deserializer deserializer++instance (DValue a, DValue b, DValue c, DValue d) =>+ DValue (a, b, c, d) where+ dtype _ = DTypeStruct (dtype (undefinedAt "(a,,,)" :: a))+ [dtype (undefinedAt "(,b,,)" :: b)+ ,dtype (undefinedAt "(,,c,)" :: c)+ ,dtype (undefinedAt "(,,,d)" :: d)+ ]+ alignment _ = 8+ serializer (x,y,z,p) = padTo 8 >> serializer x >> serializer y+ >> serializer z >> serializer p+ deserializer = skipTo 8 >> liftM4 (,,,)+ deserializer deserializer deserializer deserializer++instance (DValue a, DValue b, DValue c, DValue d, DValue e) =>+ DValue (a, b, c, d, e) where+ dtype _ = DTypeStruct (dtype (undefinedAt "(a,,,,)" :: a))+ [dtype (undefinedAt "(,b,,,)" :: b)+ ,dtype (undefinedAt "(,,c,,)" :: c)+ ,dtype (undefinedAt "(,,,d,)" :: d)+ ,dtype (undefinedAt "(,,,,e)" :: e)+ ]+ alignment _ = 8+ serializer (x,y,z,p,q) = padTo 8 >> serializer x >> serializer y+ >> serializer z >> serializer p >> serializer q+ deserializer = skipTo 8 >> liftM5 (,,,,)+ deserializer deserializer deserializer deserializer+ deserializer++-- vim: sts=2 sw=2 et
+ Setup.hs view
@@ -0,0 +1,9 @@+import Distribution.Simple+import Distribution.Simple.Utils (rawSystemExit)+import Distribution.Verbosity (normal)++main = defaultMainWithHooks $+ simpleUserHooks { runTests = runDBusTests }++runDBusTests _ _ _ _ = rawSystemExit normal "runhaskell" ["test.hs"]+
+ network-dbus.cabal view
@@ -0,0 +1,22 @@+Name: network-dbus+Version: 0.0+Author: Will Thompson, Dafydd Harries+Maintainer: Dafydd Harries+Cabal-Version: >= 1.2+License: OtherLicense+License-file: COPYING+Category: Network+Stability: experimental+Build-Type: Custom+Synopsis: D-Bus+Description: D-Bus protocol library++Library+ Build-Depends: base < 4, binary, bytestring, containers, mtl, network,+ parsec, unix, utf8-string+ GHC-Options: -Wall -fno-warn-unused-imports+ Exposed-Modules:+ Network.DBus.Connection+ Network.DBus.Message+ Network.DBus.Type+ Network.DBus.Value