path: root/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