diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. + diff --git a/Network/DBus/Connection.hs b/Network/DBus/Connection.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Connection.hs @@ -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 + 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,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 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,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 "" + +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 "" + +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 diff --git a/Network/DBus/Value.hs b/Network/DBus/Value.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Value.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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"] + diff --git a/network-dbus.cabal b/network-dbus.cabal new file mode 100644 --- /dev/null +++ b/network-dbus.cabal @@ -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