{-
  Copyright (C) 2009 John Millikin <jmillikin@gmail.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/>.
-}

{-# LANGUAGE OverloadedStrings #-}

module DBus.Message.Internal where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL

import qualified Data.Set as S
import Data.Word (Word8, Word32)
import Data.Maybe (fromMaybe)
import qualified DBus.Types as T
import DBus.Util (maybeIndex)

class Message a where
        messageTypeCode     :: a -> Word8
        messageHeaderFields :: a -> [HeaderField]
        messageFlags        :: a -> S.Set Flag
        messageBody         :: a -> [T.Variant]

data Flag
        = NoReplyExpected
        | NoAutoStart
        deriving (Show, Eq, Ord)

data HeaderField
        = Path        T.ObjectPath
        | Interface   T.InterfaceName
        | Member      T.MemberName
        | ErrorName   T.ErrorName
        | ReplySerial Serial
        | Destination T.BusName
        | Sender      T.BusName
        | Signature   T.Signature
        deriving (Show, Eq)

-- | A value used to uniquely identify a particular message within a session.
-- 'Serial's are 32-bit unsigned integers, and eventually wrap.

newtype Serial = Serial { serialValue :: Word32 }
        deriving (Eq, Ord)

instance Show Serial where
        show (Serial x) = show x

instance T.Variable Serial where
        toVariant (Serial x) = T.toVariant x
        fromVariant = fmap Serial . T.fromVariant

firstSerial :: Serial
firstSerial = Serial 1

nextSerial :: Serial -> Serial
nextSerial (Serial x) = Serial (x + 1)

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

data MethodCall = MethodCall
        { methodCallPath        :: T.ObjectPath
        , methodCallMember      :: T.MemberName
        , methodCallInterface   :: Maybe T.InterfaceName
        , methodCallDestination :: Maybe T.BusName
        , methodCallFlags       :: S.Set Flag
        , methodCallBody        :: [T.Variant]
        }
        deriving (Show, Eq)

instance Message MethodCall where
        messageTypeCode _ = 1
        messageFlags      = methodCallFlags
        messageBody       = methodCallBody
        messageHeaderFields m = concat
                [ [ Path    $ methodCallPath m
                  ,  Member $ methodCallMember m
                  ]
                , maybe' Interface . methodCallInterface $ m
                , maybe' Destination . methodCallDestination $ m
                ]

data MethodReturn = MethodReturn
        { methodReturnSerial      :: Serial
        , methodReturnDestination :: Maybe T.BusName
        , methodReturnBody        :: [T.Variant]
        }
        deriving (Show, Eq)

instance Message MethodReturn where
        messageTypeCode _ = 2
        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
        messageBody       = methodReturnBody
        messageHeaderFields m = concat
                [ [ ReplySerial $ methodReturnSerial m
                  ]
                , maybe' Destination . methodReturnDestination $ m
                ]

data Error = Error
        { errorName        :: T.ErrorName
        , errorSerial      :: Serial
        , errorDestination :: Maybe T.BusName
        , errorBody        :: [T.Variant]
        }
        deriving (Show, Eq)

instance Message Error where
        messageTypeCode _ = 3
        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
        messageBody       = errorBody
        messageHeaderFields m = concat
                [ [ ErrorName   $ errorName m
                  , ReplySerial $ errorSerial m
                  ]
                , maybe' Destination . errorDestination $ m
                ]

errorMessage :: Error -> Text
errorMessage msg = fromMaybe "(no error message)" $ do
        field <- maybeIndex (errorBody msg) 0
        text <- T.fromVariant field
        if TL.null text
                then Nothing
                else return text

data Signal = Signal
        { signalPath        :: T.ObjectPath
        , signalMember      :: T.MemberName
        , signalInterface   :: T.InterfaceName
        , signalDestination :: Maybe T.BusName
        , signalBody        :: [T.Variant]
        }
        deriving (Show, Eq)

instance Message Signal where
        messageTypeCode _ = 4
        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
        messageBody       = signalBody
        messageHeaderFields m = concat
                [ [ Path      $ signalPath m
                  , Member    $ signalMember m
                  , Interface $ signalInterface m
                  ]
                , maybe' Destination . signalDestination $ m
                ]

data Unknown = Unknown
        { unknownType    :: Word8
        , unknownFlags   :: S.Set Flag
        , unknownBody    :: [T.Variant]
        }
        deriving (Show, Eq)

-- | Not an actual message type, but a wrapper around messages received from
-- the bus. Each value contains the message's 'Serial' and possibly the
-- origin's 'T.BusName'

data ReceivedMessage
        = ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall
        | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn
        | ReceivedError        Serial (Maybe T.BusName) Error
        | ReceivedSignal       Serial (Maybe T.BusName) Signal
        | ReceivedUnknown      Serial (Maybe T.BusName) Unknown
        deriving (Show, Eq)

receivedSerial :: ReceivedMessage -> Serial
receivedSerial (ReceivedMethodCall   s _ _) = s
receivedSerial (ReceivedMethodReturn s _ _) = s
receivedSerial (ReceivedError        s _ _) = s
receivedSerial (ReceivedSignal       s _ _) = s
receivedSerial (ReceivedUnknown      s _ _) = s

receivedSender :: ReceivedMessage -> Maybe T.BusName
receivedSender (ReceivedMethodCall   _ s _) = s
receivedSender (ReceivedMethodReturn _ s _) = s
receivedSender (ReceivedError        _ s _) = s
receivedSender (ReceivedSignal       _ s _) = s
receivedSender (ReceivedUnknown      _ s _) = s

receivedBody :: ReceivedMessage -> [T.Variant]
receivedBody (ReceivedMethodCall   _ _ x) = messageBody x
receivedBody (ReceivedMethodReturn _ _ x) = messageBody x
receivedBody (ReceivedError        _ _ x) = messageBody x
receivedBody (ReceivedSignal       _ _ x) = messageBody x
receivedBody _ = []