bustle-0.8.0: Bustle/GDBusMessage.hs
{-
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