-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
--
-- This program 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 General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module DBus.Internal.Message
    ( Message(..)

    , UnknownMessage(..)
    , MethodCall(..)
    , MethodReturn(..)
    , MethodError(..)
    , methodErrorMessage
    , Signal(..)
    , ReceivedMessage(..)

    -- for use in Wire
    , HeaderField(..)
    , setMethodCallFlags
    ) where

import           Data.Bits ((.|.), (.&.))
import           Data.Maybe (fromMaybe, listToMaybe)
import           Data.Word (Word8, Word32)

import           DBus.Internal.Types

class Message a where
    messageTypeCode :: a -> Word8
    messageHeaderFields :: a -> [HeaderField]
    messageBody :: a -> [Variant]

    messageFlags :: a -> Word8
    messageFlags a
_ = Word8
0

maybe' :: (a -> b) -> Maybe a -> [b]
maybe' :: forall a b. (a -> b) -> Maybe a -> [b]
maybe' a -> b
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\a
x' -> [a -> b
f a
x'])

data UnknownMessage = UnknownMessage
    { UnknownMessage -> Word8
unknownMessageType :: Word8
    , UnknownMessage -> Maybe BusName
unknownMessageSender :: Maybe BusName
    , UnknownMessage -> [Variant]
unknownMessageBody :: [Variant]
    }
    deriving (Int -> UnknownMessage -> ShowS
[UnknownMessage] -> ShowS
UnknownMessage -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnknownMessage] -> ShowS
$cshowList :: [UnknownMessage] -> ShowS
show :: UnknownMessage -> [Char]
$cshow :: UnknownMessage -> [Char]
showsPrec :: Int -> UnknownMessage -> ShowS
$cshowsPrec :: Int -> UnknownMessage -> ShowS
Show, UnknownMessage -> UnknownMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnknownMessage -> UnknownMessage -> Bool
$c/= :: UnknownMessage -> UnknownMessage -> Bool
== :: UnknownMessage -> UnknownMessage -> Bool
$c== :: UnknownMessage -> UnknownMessage -> Bool
Eq)

data HeaderField
    = HeaderPath        ObjectPath
    | HeaderInterface   InterfaceName
    | HeaderMember      MemberName
    | HeaderErrorName   ErrorName
    | HeaderReplySerial Serial
    | HeaderDestination BusName
    | HeaderSender      BusName
    | HeaderSignature   Signature
    | HeaderUnixFds     Word32
    deriving (Int -> HeaderField -> ShowS
[HeaderField] -> ShowS
HeaderField -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HeaderField] -> ShowS
$cshowList :: [HeaderField] -> ShowS
show :: HeaderField -> [Char]
$cshow :: HeaderField -> [Char]
showsPrec :: Int -> HeaderField -> ShowS
$cshowsPrec :: Int -> HeaderField -> ShowS
Show, HeaderField -> HeaderField -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderField -> HeaderField -> Bool
$c/= :: HeaderField -> HeaderField -> Bool
== :: HeaderField -> HeaderField -> Bool
$c== :: HeaderField -> HeaderField -> Bool
Eq)

-- | A method call is a request to run some procedure exported by the
-- remote process. Procedures are identified by an (object_path,
-- interface_name, method_name) tuple.
data MethodCall = MethodCall
    {
    -- | The object path of the method call. Conceptually, object paths
    -- act like a procedural language's pointers. Each object referenced
    -- by a path is a collection of procedures.
      MethodCall -> ObjectPath
methodCallPath :: ObjectPath

    -- | The interface of the method call. Each object may implement any
    -- number of interfaces. Each method is part of at least one
    -- interface.
    --
    -- In certain cases, this may be @Nothing@, but most users should set
    -- it to a value.
    , MethodCall -> Maybe InterfaceName
methodCallInterface :: Maybe InterfaceName

    -- | The method name of the method call. Method names are unique within
    -- an interface, but might not be unique within an object.
    , MethodCall -> MemberName
methodCallMember :: MemberName

    -- | The name of the application that sent this call.
    --
    -- Most users will just leave this empty, because the bus overwrites
    -- the sender for security reasons. Setting the sender manually is
    -- used for peer-peer connections.
    --
    -- Defaults to @Nothing@.
    , MethodCall -> Maybe BusName
methodCallSender :: Maybe BusName

    -- | The name of the application to send the call to.
    --
    -- Most users should set this. If a message with no destination is
    -- sent to the bus, the bus will behave as if the destination was
    -- set to @org.freedesktop.DBus@. For peer-peer connections, the
    -- destination can be empty because there is only one peer.
    --
    -- Defaults to @Nothing@.
    , MethodCall -> Maybe BusName
methodCallDestination :: Maybe BusName

    -- | Set whether a reply is expected. This can save network and cpu
    -- resources by inhibiting unnecessary replies.
    --
    -- Defaults to @True@.
    , MethodCall -> Bool
methodCallReplyExpected :: Bool

    -- | Set whether the bus should auto-start the remote
    --
    -- Defaults to @True@.
    , MethodCall -> Bool
methodCallAutoStart :: Bool

    -- | The arguments to the method call. See 'toVariant'.
    --
    -- Defaults to @[]@.
    , MethodCall -> [Variant]
methodCallBody :: [Variant]
    }
    deriving (MethodCall -> MethodCall -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodCall -> MethodCall -> Bool
$c/= :: MethodCall -> MethodCall -> Bool
== :: MethodCall -> MethodCall -> Bool
$c== :: MethodCall -> MethodCall -> Bool
Eq, Int -> MethodCall -> ShowS
[MethodCall] -> ShowS
MethodCall -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MethodCall] -> ShowS
$cshowList :: [MethodCall] -> ShowS
show :: MethodCall -> [Char]
$cshow :: MethodCall -> [Char]
showsPrec :: Int -> MethodCall -> ShowS
$cshowsPrec :: Int -> MethodCall -> ShowS
Show)

setMethodCallFlags :: MethodCall -> Word8 -> MethodCall
setMethodCallFlags :: MethodCall -> Word8 -> MethodCall
setMethodCallFlags MethodCall
c Word8
w = MethodCall
c
    { methodCallReplyExpected :: Bool
methodCallReplyExpected = Word8
w forall a. Bits a => a -> a -> a
.&. Word8
0x1 forall a. Eq a => a -> a -> Bool
== Word8
0
    , methodCallAutoStart :: Bool
methodCallAutoStart = Word8
w forall a. Bits a => a -> a -> a
.&. Word8
0x2 forall a. Eq a => a -> a -> Bool
== Word8
0
    }

instance Message MethodCall where
    messageTypeCode :: MethodCall -> Word8
messageTypeCode MethodCall
_ = Word8
1
    messageFlags :: MethodCall -> Word8
messageFlags MethodCall
c = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Bits a => a -> a -> a
(.|.) Word8
0
        [ if MethodCall -> Bool
methodCallReplyExpected MethodCall
c then Word8
0 else Word8
0x1
        , if MethodCall -> Bool
methodCallAutoStart MethodCall
c then Word8
0 else Word8
0x2
        ]
    messageBody :: MethodCall -> [Variant]
messageBody = MethodCall -> [Variant]
methodCallBody
    messageHeaderFields :: MethodCall -> [HeaderField]
messageHeaderFields MethodCall
m = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ ObjectPath -> HeaderField
HeaderPath (MethodCall -> ObjectPath
methodCallPath MethodCall
m)
          , MemberName -> HeaderField
HeaderMember (MethodCall -> MemberName
methodCallMember MethodCall
m)
          ]
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' InterfaceName -> HeaderField
HeaderInterface (MethodCall -> Maybe InterfaceName
methodCallInterface MethodCall
m)
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderSender (MethodCall -> Maybe BusName
methodCallSender MethodCall
m)
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderDestination (MethodCall -> Maybe BusName
methodCallDestination MethodCall
m)
        ]

-- | A method return is a reply to a method call, indicating that the call
-- succeeded.
data MethodReturn = MethodReturn
    {
    -- | The serial of the original method call. This lets the original
    -- caller match up this reply to the pending call.
      MethodReturn -> Serial
methodReturnSerial :: Serial

    -- | The name of the application that is returning from a call.
    --
    -- Most users will just leave this empty, because the bus overwrites
    -- the sender for security reasons. Setting the sender manually is
    -- used for peer-peer connections.
    --
    -- Defaults to @Nothing@.
    , MethodReturn -> Maybe BusName
methodReturnSender :: Maybe BusName

    -- | The name of the application that initiated the call.
    --
    -- Most users should set this. If a message with no destination is
    -- sent to the bus, the bus will behave as if the destination was
    -- set to @org.freedesktop.DBus@. For peer-peer connections, the
    -- destination can be empty because there is only one peer.
    --
    -- Defaults to @Nothing@.
    , MethodReturn -> Maybe BusName
methodReturnDestination :: Maybe BusName

    -- | Values returned from the method call. See 'toVariant'.
    --
    -- Defaults to @[]@.
    , MethodReturn -> [Variant]
methodReturnBody :: [Variant]
    }
    deriving (Int -> MethodReturn -> ShowS
[MethodReturn] -> ShowS
MethodReturn -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MethodReturn] -> ShowS
$cshowList :: [MethodReturn] -> ShowS
show :: MethodReturn -> [Char]
$cshow :: MethodReturn -> [Char]
showsPrec :: Int -> MethodReturn -> ShowS
$cshowsPrec :: Int -> MethodReturn -> ShowS
Show, MethodReturn -> MethodReturn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodReturn -> MethodReturn -> Bool
$c/= :: MethodReturn -> MethodReturn -> Bool
== :: MethodReturn -> MethodReturn -> Bool
$c== :: MethodReturn -> MethodReturn -> Bool
Eq)

instance Message MethodReturn where
    messageTypeCode :: MethodReturn -> Word8
messageTypeCode MethodReturn
_ = Word8
2
    messageBody :: MethodReturn -> [Variant]
messageBody       = MethodReturn -> [Variant]
methodReturnBody
    messageHeaderFields :: MethodReturn -> [HeaderField]
messageHeaderFields MethodReturn
m = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ Serial -> HeaderField
HeaderReplySerial (MethodReturn -> Serial
methodReturnSerial MethodReturn
m)
          ]
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderSender (MethodReturn -> Maybe BusName
methodReturnSender MethodReturn
m)
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderDestination (MethodReturn -> Maybe BusName
methodReturnDestination MethodReturn
m)
        ]

-- | A method error is a reply to a method call, indicating that the call
-- received an error and did not succeed.
data MethodError = MethodError
    {
    -- | The name of the error type. Names are used so clients can
    -- handle certain classes of error differently from others.
      MethodError -> ErrorName
methodErrorName :: ErrorName

    -- | The serial of the original method call. This lets the original
    -- caller match up this reply to the pending call.
    , MethodError -> Serial
methodErrorSerial :: Serial

    -- | The name of the application that is returning from a call.
    --
    -- Most users will just leave this empty, because the bus overwrites
    -- the sender for security reasons. Setting the sender manually is
    -- used for peer-peer connections.
    --
    -- Defaults to @Nothing@.
    , MethodError -> Maybe BusName
methodErrorSender :: Maybe BusName

    -- | The name of the application that initiated the call.
    --
    -- Most users should set this. If a message with no destination is
    -- sent to the bus, the bus will behave as if the destination was
    -- set to @org.freedesktop.DBus@. For peer-peer connections, the
    -- destination can be empty because there is only one peer.
    --
    -- Defaults to @Nothing@.
    , MethodError -> Maybe BusName
methodErrorDestination :: Maybe BusName

    -- | Additional information about the error. By convention, if
    -- the error body contains any items, the first item should be a
    -- string describing the error.
    , MethodError -> [Variant]
methodErrorBody :: [Variant]
    }
    deriving (Int -> MethodError -> ShowS
[MethodError] -> ShowS
MethodError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MethodError] -> ShowS
$cshowList :: [MethodError] -> ShowS
show :: MethodError -> [Char]
$cshow :: MethodError -> [Char]
showsPrec :: Int -> MethodError -> ShowS
$cshowsPrec :: Int -> MethodError -> ShowS
Show, MethodError -> MethodError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodError -> MethodError -> Bool
$c/= :: MethodError -> MethodError -> Bool
== :: MethodError -> MethodError -> Bool
$c== :: MethodError -> MethodError -> Bool
Eq)

instance Message MethodError where
    messageTypeCode :: MethodError -> Word8
messageTypeCode MethodError
_ = Word8
3
    messageBody :: MethodError -> [Variant]
messageBody       = MethodError -> [Variant]
methodErrorBody
    messageHeaderFields :: MethodError -> [HeaderField]
messageHeaderFields MethodError
m = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ ErrorName -> HeaderField
HeaderErrorName (MethodError -> ErrorName
methodErrorName MethodError
m)
          , Serial -> HeaderField
HeaderReplySerial (MethodError -> Serial
methodErrorSerial MethodError
m)
          ]
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderSender (MethodError -> Maybe BusName
methodErrorSender MethodError
m)
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderDestination (MethodError -> Maybe BusName
methodErrorDestination MethodError
m)
        ]

-- | Get a human-readable description of the error, by returning the first
-- item in the error body if it's a string.
methodErrorMessage :: MethodError -> String
methodErrorMessage :: MethodError -> [Char]
methodErrorMessage MethodError
err = forall a. a -> Maybe a -> a
fromMaybe [Char]
"(no error message)" forall a b. (a -> b) -> a -> b
$ do
    Variant
field <- forall a. [a] -> Maybe a
listToMaybe (MethodError -> [Variant]
methodErrorBody MethodError
err)
    [Char]
msg <- forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
field
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
msg
        then forall a. Maybe a
Nothing
        else forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
msg

-- | Signals are broadcast by applications to notify other clients of some
-- event.
data Signal = Signal
    {
    -- | The path of the object that emitted this signal.
      Signal -> ObjectPath
signalPath :: ObjectPath

    -- | The interface that this signal belongs to.
    , Signal -> InterfaceName
signalInterface :: InterfaceName

    -- | The name of this signal.
    , Signal -> MemberName
signalMember :: MemberName

    -- | The name of the application that emitted this signal.
    --
    -- Most users will just leave this empty, because the bus overwrites
    -- the sender for security reasons. Setting the sender manually is
    -- used for peer-peer connections.
    --
    -- Defaults to @Nothing@.
    , Signal -> Maybe BusName
signalSender :: Maybe BusName

    -- | The name of the application to emit the signal to. If @Nothing@,
    -- the signal is sent to any application that has registered an
    -- appropriate match rule.
    --
    -- Defaults to @Nothing@.
    , Signal -> Maybe BusName
signalDestination :: Maybe BusName

    -- | Additional information about the signal, such as the new value
    -- or the time.
    --
    -- Defaults to @[]@.
    , Signal -> [Variant]
signalBody :: [Variant]
    }
    deriving (Int -> Signal -> ShowS
[Signal] -> ShowS
Signal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Signal] -> ShowS
$cshowList :: [Signal] -> ShowS
show :: Signal -> [Char]
$cshow :: Signal -> [Char]
showsPrec :: Int -> Signal -> ShowS
$cshowsPrec :: Int -> Signal -> ShowS
Show, Signal -> Signal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signal -> Signal -> Bool
$c/= :: Signal -> Signal -> Bool
== :: Signal -> Signal -> Bool
$c== :: Signal -> Signal -> Bool
Eq)

instance Message Signal where
    messageTypeCode :: Signal -> Word8
messageTypeCode Signal
_ = Word8
4
    messageBody :: Signal -> [Variant]
messageBody       = Signal -> [Variant]
signalBody
    messageHeaderFields :: Signal -> [HeaderField]
messageHeaderFields Signal
m = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ ObjectPath -> HeaderField
HeaderPath (Signal -> ObjectPath
signalPath Signal
m)
          , MemberName -> HeaderField
HeaderMember (Signal -> MemberName
signalMember Signal
m)
          , InterfaceName -> HeaderField
HeaderInterface (Signal -> InterfaceName
signalInterface Signal
m)
          ]
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderSender (Signal -> Maybe BusName
signalSender Signal
m)
        , forall a b. (a -> b) -> Maybe a -> [b]
maybe' BusName -> HeaderField
HeaderDestination (Signal -> Maybe BusName
signalDestination Signal
m)
        ]

-- | Not an actual message type, but a wrapper around messages received from
-- the bus. Each value contains the message's 'Serial'.
--
-- If casing against these constructors, always include a default case to
-- handle messages of an unknown type. New message types may be added to the
-- D-Bus specification, and applications should handle them gracefully by
-- either ignoring or logging them.
data ReceivedMessage
    = ReceivedMethodCall Serial MethodCall
    | ReceivedMethodReturn Serial MethodReturn
    | ReceivedMethodError Serial MethodError
    | ReceivedSignal Serial Signal
    | ReceivedUnknown Serial UnknownMessage
    deriving (Int -> ReceivedMessage -> ShowS
[ReceivedMessage] -> ShowS
ReceivedMessage -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ReceivedMessage] -> ShowS
$cshowList :: [ReceivedMessage] -> ShowS
show :: ReceivedMessage -> [Char]
$cshow :: ReceivedMessage -> [Char]
showsPrec :: Int -> ReceivedMessage -> ShowS
$cshowsPrec :: Int -> ReceivedMessage -> ShowS
Show, ReceivedMessage -> ReceivedMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReceivedMessage -> ReceivedMessage -> Bool
$c/= :: ReceivedMessage -> ReceivedMessage -> Bool
== :: ReceivedMessage -> ReceivedMessage -> Bool
$c== :: ReceivedMessage -> ReceivedMessage -> Bool
Eq)