Unverified Commit 5a6e13aa authored by Will Thompson's avatar Will Thompson

Merge branch 'reduce-dependencies'

parents e506b5ca 2011ade5
Pipeline #184160 passed with stage
in 46 minutes and 45 seconds
{-
Bustle.GDBusMessage: bindings for GDBusMessage
Copyright © 2020 Will Thompson
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Bustle.GDBusMessage
(
-- * Types
GDBusMessage
, MessageType(..)
, Serial
, BusName
, formatBusName
, busName_
, ObjectPath
, formatObjectPath
, objectPath_
, InterfaceName
, formatInterfaceName
, interfaceName_
, MemberName
, formatMemberName
, memberName_
-- * Constructors
, makeNewGDBusMessage
, wrapNewGDBusMessage
, messageNewSignal
-- * Methods
, messageType
, messageSerial
, messageReplySerial
, messageSender
, messageDestination
, messageErrorName
, messagePath
, messageInterface
, messageMember
, messagePrintBody
, messageGetBodyString
)
where
import Data.Word
import Data.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.C
import Foreign.Marshal.Alloc
import System.Glib.GObject
import System.Glib.UTFString
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Maybe
import Bustle.GVariant
data MessageType = MessageTypeInvalid
| MessageTypeMethodCall
| MessageTypeMethodReturn
| MessageTypeError
| MessageTypeSignal
deriving
(Show, Ord, Eq, Enum)
-- 0 is unused in the wire protocol so indicates "no serial"
type Serial = Word32
newtype BusName = BusName String
deriving (Eq, Ord, Show)
instance IsString BusName where
fromString = busName_
newtype ObjectPath = ObjectPath String
deriving (Eq, Ord, Show)
instance IsString ObjectPath where
fromString = objectPath_
newtype InterfaceName = InterfaceName String
deriving (Eq, Ord, Show)
newtype MemberName = MemberName String
deriving (Eq, Ord, Show)
instance IsString MemberName where
fromString = memberName_
-- TODO: validate
busName_ :: String
-> BusName
busName_ = BusName
formatBusName :: BusName
-> String
formatBusName (BusName n) = n
objectPath_ :: String
-> ObjectPath
objectPath_ = ObjectPath
formatObjectPath :: ObjectPath
-> String
formatObjectPath (ObjectPath n) = n
interfaceName_ :: String
-> InterfaceName
interfaceName_ = InterfaceName
formatInterfaceName :: InterfaceName
-> String
formatInterfaceName (InterfaceName n) = n
memberName_ :: String
-> MemberName
memberName_ = MemberName
formatMemberName :: MemberName
-> String
formatMemberName (MemberName n) = n
newtype GDBusMessage = GDBusMessage { unGDBusMessage :: ForeignPtr GDBusMessage }
deriving (Eq, Ord, Show)
mkGDBusMessage :: (ForeignPtr GDBusMessage -> GDBusMessage, FinalizerPtr a)
mkGDBusMessage = (GDBusMessage, objectUnref)
instance GObjectClass GDBusMessage where
toGObject = GObject . castForeignPtr . unGDBusMessage
unsafeCastGObject = GDBusMessage . castForeignPtr . unGObject
makeNewGDBusMessage :: IO (Ptr GDBusMessage)
-> IO GDBusMessage
makeNewGDBusMessage = makeNewGObject mkGDBusMessage
wrapNewGDBusMessage :: IO (Ptr GDBusMessage)
-> IO GDBusMessage
wrapNewGDBusMessage = wrapNewGObject mkGDBusMessage
-- Foreign imports
foreign import ccall unsafe "g_dbus_message_new_signal"
g_dbus_message_new_signal :: CString
-> CString
-> CString
-> IO (Ptr GDBusMessage)
foreign import ccall unsafe "g_dbus_message_get_message_type"
g_dbus_message_get_message_type :: Ptr GDBusMessage
-> IO Int
foreign import ccall unsafe "g_dbus_message_get_serial"
g_dbus_message_get_serial :: Ptr GDBusMessage
-> IO Word32
foreign import ccall unsafe "g_dbus_message_get_reply_serial"
g_dbus_message_get_reply_serial :: Ptr GDBusMessage
-> IO Word32
foreign import ccall unsafe "g_dbus_message_get_sender"
g_dbus_message_get_sender :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_destination"
g_dbus_message_get_destination :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_error_name"
g_dbus_message_get_error_name :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_path"
g_dbus_message_get_path :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_interface"
g_dbus_message_get_interface :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_member"
g_dbus_message_get_member :: Ptr GDBusMessage
-> IO CString
foreign import ccall unsafe "g_dbus_message_get_body"
g_dbus_message_get_body :: Ptr GDBusMessage
-> IO (Ptr GVariant)
-- Bindings
messageNewSignal :: ObjectPath
-> InterfaceName
-> MemberName
-> IO GDBusMessage
messageNewSignal (ObjectPath o) (InterfaceName i) (MemberName m) =
withCString o $ \o_ptr ->
withCString i $ \i_ptr ->
withCString m $ \m_ptr ->
wrapNewGDBusMessage $ g_dbus_message_new_signal o_ptr i_ptr m_ptr
messageType :: GDBusMessage
-> IO MessageType
messageType message =
withForeignPtr (unGDBusMessage message) $ \c_message ->
toEnum <$> g_dbus_message_get_message_type c_message
messageSerial :: GDBusMessage
-> IO Serial
messageSerial message =
withForeignPtr (unGDBusMessage message) $ \c_message ->
g_dbus_message_get_serial c_message
messageReplySerial :: GDBusMessage
-> IO Serial
messageReplySerial message =
withForeignPtr (unGDBusMessage message) $ \c_message ->
g_dbus_message_get_reply_serial c_message
messageStr :: (String -> a)
-> (Ptr GDBusMessage -> IO CString)
-> GDBusMessage
-> IO (Maybe a)
messageStr ctor f message =
withForeignPtr (unGDBusMessage message) $ \c_message -> do
c_str <- f c_message
if c_str == nullPtr
then return Nothing
else Just . ctor <$> peekUTFString c_str
messageSender :: GDBusMessage
-> IO (Maybe BusName)
messageSender = messageStr BusName g_dbus_message_get_sender
messageDestination :: GDBusMessage
-> IO (Maybe BusName)
messageDestination = messageStr BusName g_dbus_message_get_destination
messageErrorName :: GDBusMessage
-> IO (Maybe String)
messageErrorName = messageStr id g_dbus_message_get_error_name
messagePath :: GDBusMessage
-> IO (Maybe ObjectPath)
messagePath = messageStr ObjectPath g_dbus_message_get_path
messageInterface :: GDBusMessage
-> IO (Maybe InterfaceName)
messageInterface = messageStr InterfaceName g_dbus_message_get_interface
messageMember :: GDBusMessage
-> IO (Maybe MemberName)
messageMember = messageStr MemberName g_dbus_message_get_member
messageGetBody :: GDBusMessage
-> IO (Maybe GVariant)
messageGetBody message = do
body <- liftIO $ withForeignPtr (unGDBusMessage message) g_dbus_message_get_body
if body == nullPtr
then return Nothing
else Just <$> makeNewGVariant (return body)
messagePrintBody :: GDBusMessage
-> IO String
messagePrintBody message = do
body <- messageGetBody message
case body of
Nothing -> return ""
Just b -> variantPrint b WithAnnotations
messageGetBodyString :: GDBusMessage
-> Word
-> IO (Maybe String)
messageGetBodyString message i = runMaybeT $ do
body <- MaybeT $ messageGetBody message
child <- MaybeT $ variantGetChild body i
MaybeT $ variantGetString child
{-
Bustle.GVariant: bindings for GVariant
Copyright © 2020 Will Thompson
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Bustle.GVariant
(
-- * Types
GVariant
, TypeAnnotate(..)
-- * Constructors
, makeNewGVariant
, wrapNewGVariant
-- * Methods
, variantGetChild
, variantGetString
, variantPrint
)
where
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.C
import System.Glib.UTFString
import Control.Monad (guard)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Maybe
data TypeAnnotate = NoAnnotations
| WithAnnotations
deriving
(Show, Ord, Eq, Enum)
newtype GVariant = GVariant { unGVariant :: ForeignPtr GVariant }
deriving (Eq, Ord, Show)
makeNewGVariant :: IO (Ptr GVariant)
-> IO GVariant
makeNewGVariant act = wrapNewGVariant (act >>= g_variant_ref)
wrapNewGVariant :: IO (Ptr GVariant)
-> IO GVariant
wrapNewGVariant act = do
vPtr <- act
v <- newForeignPtr g_variant_unref vPtr
return $ GVariant v
-- Foreign imports
foreign import ccall unsafe "g_variant_is_of_type"
g_variant_is_of_type :: Ptr a
-> CString
-> IO CInt
foreign import ccall unsafe "g_variant_n_children"
g_variant_n_children :: Ptr a
-> IO CSize
foreign import ccall unsafe "g_variant_get_child_value"
g_variant_get_child_value :: Ptr a
-> CSize
-> IO (Ptr a)
foreign import ccall unsafe "g_variant_get_string"
g_variant_get_string :: Ptr a
-> Ptr CSize
-> IO CString
foreign import ccall unsafe "g_variant_print"
g_variant_print :: Ptr a
-> CInt
-> IO CString
foreign import ccall unsafe "g_variant_ref"
g_variant_ref :: Ptr GVariant
-> IO (Ptr GVariant)
foreign import ccall unsafe "&g_variant_unref"
g_variant_unref :: FunPtr (Ptr GVariant -> IO ())
-- Bindings
variantNChildren :: GVariant
-> IO Word
variantNChildren v = withForeignPtr (unGVariant v) $ \vPtr -> do
fromIntegral <$> g_variant_n_children vPtr
variantGetChild :: GVariant
-> Word
-> IO (Maybe GVariant)
variantGetChild v i = withForeignPtr (unGVariant v) $ \vPtr -> runMaybeT $ do
n <- liftIO $ variantNChildren v
guard (i < n)
liftIO $ wrapNewGVariant $ g_variant_get_child_value vPtr (fromIntegral i)
variantGetString :: GVariant
-> IO (Maybe String)
variantGetString v = withForeignPtr (unGVariant v) $ \vPtr -> runMaybeT $ do
r <- liftIO $ withCString "s" $ g_variant_is_of_type vPtr
guard (r /= 0)
s <- liftIO $ g_variant_get_string vPtr nullPtr
liftIO $ peekUTFString s
variantPrint :: GVariant
-> TypeAnnotate
-> IO String
variantPrint v annotate = withForeignPtr (unGVariant v) $ \vPtr -> do
cstr <- g_variant_print vPtr (fromIntegral $ fromEnum annotate)
readUTFString cstr
......@@ -32,17 +32,13 @@ import qualified Data.Map as Map
import Data.Map (Map)
import Control.Exception (try)
import Control.Monad.State
import System.IO.Error ( mkIOError
, userErrorType
)
import Control.Monad.Trans.Maybe
import Network.Pcap
import DBus
import qualified Data.ByteString as BS
import System.Glib (GError)
import qualified Bustle.Types as B
import Bustle.GDBusMessage
import Bustle.Reader
-- Conversions from dbus-core's types into Bustle's more stupid types. This
-- whole section is pretty upsetting.
......@@ -63,23 +59,23 @@ convertBusName fallback n =
where
fallback_ = busName_ fallback
convertMember :: (a -> ObjectPath)
-> (a -> Maybe InterfaceName)
-> (a -> MemberName)
-> a
-> B.Member
convertMember getObjectPath getInterfaceName getMemberName m =
B.Member (getObjectPath m)
(getInterfaceName m)
(getMemberName m)
convertMember :: MonadIO m
=> GDBusMessage
-> m B.Member
convertMember m = liftIO $ do
p <- fromMaybe (objectPath_ "") <$> messagePath m
i <- messageInterface m
member <- fromMaybe (memberName_ "") <$> messageMember m
return $ B.Member p i member
type PendingMessages = Map (Maybe BusName, Serial)
(MethodCall, B.Detailed B.Message)
(B.Detailed B.Message)
popMatchingCall :: (MonadState PendingMessages m)
=> Maybe BusName
-> Serial
-> m (Maybe (MethodCall, B.Detailed B.Message))
-> m (Maybe (B.Detailed B.Message))
popMatchingCall name serial = do
ret <- tryPop (name, serial)
case (ret, name) of
......@@ -98,27 +94,30 @@ popMatchingCall name serial = do
insertPending :: MonadState PendingMessages m
=> Maybe BusName
-> Serial
-> MethodCall
-> B.Detailed B.Message
-> m ()
insertPending n s rawCall b = modify $ Map.insert (n, s) (rawCall, b)
isNOC :: Maybe BusName -> Signal -> Maybe (BusName, Maybe BusName, Maybe BusName)
isNOC (Just sender) s | looksLikeNOC =
case names of
[Just n, old, new] -> Just (n, old, new)
_ -> Nothing
insertPending n s b = modify $ Map.insert (n, s) b
isNOC :: MonadIO m
=> Maybe BusName
-> GDBusMessage
-> m (Maybe (BusName, Maybe BusName, Maybe BusName))
isNOC maybeSender message = liftIO $ runMaybeT $ do
sender <- MaybeT . return $ maybeSender
guard (sender == B.dbusName)
type_ <- liftIO $ messageType message
guard (type_ == MessageTypeSignal)
iface <- MaybeT $ messageInterface message
guard (iface == B.dbusInterface)
member <- MaybeT $ messageMember message
guard (formatMemberName member == "NameOwnerChanged")
n <- MaybeT $ messageGetBodyString message 0
old <- MaybeT $ messageGetBodyString message 1
new <- MaybeT $ messageGetBodyString message 2
return (busName_ n, asBusName old, asBusName new)
where
names :: [Maybe BusName]
names = map fromVariant $ signalBody s
looksLikeNOC =
(sender == B.dbusName) &&
(signalInterface s == B.dbusInterface) &&
(formatMemberName (signalMember s) == "NameOwnerChanged")
isNOC _ _ = Nothing
asBusName "" = Nothing
asBusName name = Just $ busName_ name
bustlifyNOC :: (BusName, Maybe BusName, Maybe BusName)
-> B.NOC
......@@ -138,130 +137,118 @@ bustlifyNOC ns@(name, oldOwner, newOwner)
uniquify = B.UniqueName
otherify = B.OtherName
tryBustlifyGetNameOwnerReply :: Maybe (MethodCall, a)
-> MethodReturn
-> Maybe B.NOC
tryBustlifyGetNameOwnerReply maybeCall mr = do
tryBustlifyGetNameOwnerReply :: MonadIO m
=> Maybe (B.Detailed a)
-> GDBusMessage
-> m (Maybe B.NOC)
tryBustlifyGetNameOwnerReply maybeCall reply = liftIO $ runMaybeT $ do
-- FIXME: obviously this should be more robust:
-- • check that the service really is the bus daemon
-- • don't crash if the body of the call or reply doesn't contain one bus name.
(rawCall, _) <- maybeCall
guard (formatMemberName (methodCallMember rawCall) == "GetNameOwner")
ownedName <- fromVariant (head (methodCallBody rawCall))
return $ bustlifyNOC ( ownedName
call <- MaybeT . return $ B.deReceivedMessage <$> maybeCall
member <- MaybeT $ messageMember call
guard (formatMemberName member == "GetNameOwner")
ownedName <- MaybeT $ messageGetBodyString call 0
owner <- MaybeT $ messageGetBodyString reply 0
return $ bustlifyNOC ( busName_ ownedName
, Nothing
, fromVariant (head (methodReturnBody mr))
, Just $ busName_ owner
)
bustlify :: MonadState PendingMessages m
bustlify :: (MonadIO m, MonadState PendingMessages m)
=> B.Microseconds
-> Int
-> ReceivedMessage
-> GDBusMessage
-> m B.DetailedEvent
bustlify µs bytes m = do
bm <- buildBustledMessage
return $ B.Detailed µs bm bytes m
where
sender = receivedMessageSender m
sender <- liftIO $ messageSender m
-- FIXME: can we do away with the un-Maybe-ing and just push that Nothing
-- means 'the monitor' downwards? Or skip the message if sender is Nothing.
wrappedSender = convertBusName "sen.der" sender
buildBustledMessage = case m of
(ReceivedMethodCall serial mc) -> do
let wrappedSender = convertBusName "sen.der" sender
serial <- liftIO $ messageSerial m
replySerial <- liftIO $ messageReplySerial m
destination <- liftIO $ messageDestination m
let detailed x = B.Detailed µs x bytes m
type_ <- liftIO $ messageType m
detailed <$> case type_ of
MessageTypeMethodCall -> do
member <- convertMember m
let call = B.MethodCall
{ B.serial = serialValue serial
{ B.serial = serial
, B.sender = wrappedSender
, B.destination = convertBusName "method.call.destination" $ methodCallDestination mc
, B.member = convertMember methodCallPath methodCallInterface methodCallMember mc
, B.destination = convertBusName "method.call.destination" destination
, B.member = member
}
-- FIXME: we shouldn't need to construct almost the same thing here
-- and 10 lines above maybe?
insertPending sender serial mc (B.Detailed µs call bytes m)
insertPending sender serial (detailed call)
return $ B.MessageEvent call
(ReceivedMethodReturn _serial mr) -> do
call <- popMatchingCall (methodReturnDestination mr) (methodReturnSerial mr)
return $ case tryBustlifyGetNameOwnerReply call mr of
MessageTypeMethodReturn -> do
call <- popMatchingCall destination replySerial
noc_ <- tryBustlifyGetNameOwnerReply call m
return $ case noc_ of
Just noc -> B.NOCEvent noc
Nothing -> B.MessageEvent $ B.MethodReturn