-- 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 _ = 0

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

data UnknownMessage = UnknownMessage
    { unknownMessageType :: Word8
    , unknownMessageSender :: Maybe BusName
    , unknownMessageBody :: [Variant]
    }
    deriving (Show, Eq)

data HeaderField
    = HeaderPath        ObjectPath
    | HeaderInterface   InterfaceName
    | HeaderMember      MemberName
    | HeaderErrorName   ErrorName
    | HeaderReplySerial Serial
    | HeaderDestination BusName
    | HeaderSender      BusName
    | HeaderSignature   Signature
    | HeaderUnixFds     Word32
    deriving (Show, 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.
      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.
    , 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.
    , 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@.
    , 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@.
    , methodCallDestination :: Maybe BusName

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

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

    -- | The arguments to the method call. See 'toVariant'.
    --
    -- Defaults to @[]@.
    , methodCallBody :: [Variant]
    }
    deriving (Eq, Show)

setMethodCallFlags :: MethodCall -> Word8 -> MethodCall
setMethodCallFlags c w = c
    { methodCallReplyExpected = w .&. 0x1 == 0
    , methodCallAutoStart = w .&. 0x2 == 0
    }

instance Message MethodCall where
    messageTypeCode _ = 1
    messageFlags c = foldr (.|.) 0
        [ if methodCallReplyExpected c then 0 else 0x1
        , if methodCallAutoStart c then 0 else 0x2
        ]
    messageBody = methodCallBody
    messageHeaderFields m = concat
        [ [ HeaderPath (methodCallPath m)
          , HeaderMember (methodCallMember m)
          ]
        , maybe' HeaderInterface (methodCallInterface m)
        , maybe' HeaderSender (methodCallSender m)
        , maybe' HeaderDestination (methodCallDestination 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.
      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@.
    , 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@.
    , methodReturnDestination :: Maybe BusName

    -- | Values returned from the method call. See 'toVariant'.
    --
    -- Defaults to @[]@.
    , methodReturnBody :: [Variant]
    }
    deriving (Show, Eq)

instance Message MethodReturn where
    messageTypeCode _ = 2
    messageBody       = methodReturnBody
    messageHeaderFields m = concat
        [ [ HeaderReplySerial (methodReturnSerial m)
          ]
        , maybe' HeaderSender (methodReturnSender m)
        , maybe' HeaderDestination (methodReturnDestination 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.
      methodErrorName :: ErrorName

    -- | The serial of the original method call. This lets the original
    -- caller match up this reply to the pending call.
    , 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@.
    , 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@.
    , 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.
    , methodErrorBody :: [Variant]
    }
    deriving (Show, Eq)

instance Message MethodError where
    messageTypeCode _ = 3
    messageBody       = methodErrorBody
    messageHeaderFields m = concat
        [ [ HeaderErrorName (methodErrorName m)
          , HeaderReplySerial (methodErrorSerial m)
          ]
        , maybe' HeaderSender (methodErrorSender m)
        , maybe' HeaderDestination (methodErrorDestination 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 err = fromMaybe "(no error message)" $ do
    field <- listToMaybe (methodErrorBody err)
    msg <- fromVariant field
    if null msg
        then Nothing
        else return 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.
      signalPath :: ObjectPath

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

    -- | The name of this signal.
    , 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@.
    , 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@.
    , signalDestination :: Maybe BusName

    -- | Additional information about the signal, such as the new value
    -- or the time.
    --
    -- Defaults to @[]@.
    , signalBody :: [Variant]
    }
    deriving (Show, Eq)

instance Message Signal where
    messageTypeCode _ = 4
    messageBody       = signalBody
    messageHeaderFields m = concat
        [ [ HeaderPath (signalPath m)
          , HeaderMember (signalMember m)
          , HeaderInterface (signalInterface m)
          ]
        , maybe' HeaderSender (signalSender m)
        , maybe' HeaderDestination (signalDestination 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 (Show, Eq)