-- Copyright (C) 2010-2011 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/>.

module Network.Protocol.XMPP.Stanza
        ( Stanza (..)

        , ReceivedStanza (..)
        , Message (..)
        , Presence (..)
        , IQ (..)
        , MessageType (..)
        , PresenceType (..)
        , IQType (..)

        , emptyMessage
        , emptyPresence
        , emptyIQ

        , elementToStanza
        ) where

import           Data.String (fromString)
import           Data.Maybe (listToMaybe)
import           Control.Monad (when)
import qualified Data.Text
import           Data.Text (Text)
import qualified Network.Protocol.XMPP.XML as X
import           Network.Protocol.XMPP.JID (JID, parseJID, formatJID)
import           Network.Protocol.XMPP.String (s)

class Stanza a where
        stanzaTo        :: a -> Maybe JID
        stanzaFrom      :: a -> Maybe JID
        stanzaID        :: a -> Maybe Text
        stanzaLang      :: a -> Maybe Text
        stanzaPayloads  :: a -> [X.Element]
        stanzaToElement :: a -> X.Element

data ReceivedStanza
        = ReceivedMessage Message
        | ReceivedPresence Presence
        | ReceivedIQ IQ
        deriving (Show)

data Message = Message
        { messageType     :: MessageType
        , messageTo       :: Maybe JID
        , messageFrom     :: Maybe JID
        , messageID       :: Maybe Text
        , messageLang     :: Maybe Text
        , messagePayloads :: [X.Element]
        }
        deriving (Show)

instance Stanza Message where
        stanzaTo = messageTo
        stanzaFrom = messageFrom
        stanzaID = messageID
        stanzaLang = messageLang
        stanzaPayloads = messagePayloads
        stanzaToElement x = stanzaToElement' x "message" typeStr where
                typeStr = case messageType x of
                        MessageNormal -> "normal"
                        MessageChat -> "chat"
                        MessageGroupChat -> "groupchat"
                        MessageHeadline -> "headline"
                        MessageError -> "error"

data MessageType
        = MessageNormal
        | MessageChat
        | MessageGroupChat
        | MessageHeadline
        | MessageError
        deriving (Show, Eq)

emptyMessage :: MessageType -> Message
emptyMessage t = Message
        { messageType = t
        , messageTo = Nothing
        , messageFrom = Nothing
        , messageID = Nothing
        , messageLang = Nothing
        , messagePayloads = []
        }

data Presence = Presence
        { presenceType     :: PresenceType
        , presenceTo       :: Maybe JID
        , presenceFrom     :: Maybe JID
        , presenceID       :: Maybe Text
        , presenceLang     :: Maybe Text
        , presencePayloads :: [X.Element]
        }
        deriving (Show)

instance Stanza Presence where
        stanzaTo = presenceTo
        stanzaFrom = presenceFrom
        stanzaID = presenceID
        stanzaLang = presenceLang
        stanzaPayloads = presencePayloads
        stanzaToElement x = stanzaToElement' x "presence" typeStr where
                typeStr = case presenceType x of
                        PresenceAvailable -> ""
                        PresenceUnavailable -> "unavailable"
                        PresenceSubscribe -> "subscribe"
                        PresenceSubscribed -> "subscribed"
                        PresenceUnsubscribe -> "unsubscribe"
                        PresenceUnsubscribed -> "unsubscribed"
                        PresenceProbe -> "probe"
                        PresenceError -> "error"

data PresenceType
        = PresenceAvailable
        | PresenceUnavailable
        | PresenceSubscribe
        | PresenceSubscribed
        | PresenceUnsubscribe
        | PresenceUnsubscribed
        | PresenceProbe
        | PresenceError
        deriving (Show, Eq)

emptyPresence :: PresenceType -> Presence
emptyPresence t = Presence
        { presenceType = t
        , presenceTo = Nothing
        , presenceFrom = Nothing
        , presenceID = Nothing
        , presenceLang = Nothing
        , presencePayloads = []
        }

data IQ = IQ
        { iqType    :: IQType
        , iqTo      :: Maybe JID
        , iqFrom    :: Maybe JID
        , iqID      :: Maybe Text
        , iqLang    :: Maybe Text
        , iqPayload :: Maybe X.Element
        }
        deriving (Show)

instance Stanza IQ where
        stanzaTo = iqTo
        stanzaFrom = iqFrom
        stanzaID = iqID
        stanzaLang = iqLang
        stanzaPayloads iq = case iqPayload iq of
                Just elemt -> [elemt]
                Nothing -> []
        stanzaToElement x = stanzaToElement' x "iq" typeStr where
                typeStr = case iqType x of
                        IQGet -> "get"
                        IQSet -> "set"
                        IQResult -> "result"
                        IQError -> "error"

data IQType
        = IQGet
        | IQSet
        | IQResult
        | IQError
        deriving (Show, Eq)

emptyIQ :: IQType -> IQ
emptyIQ t = IQ
        { iqType = t
        , iqTo = Nothing
        , iqFrom = Nothing
        , iqID = Nothing
        , iqLang = Nothing
        , iqPayload = Nothing
        }

stanzaToElement' :: Stanza a => a -> String -> String -> X.Element
stanzaToElement' stanza name typeStr = X.element (fromString name) attrs payloads where
        payloads = map X.NodeElement (stanzaPayloads stanza)
        attrs = concat
                [ mattr "to" (fmap formatJID . stanzaTo)
                , mattr "from" (fmap formatJID . stanzaFrom)
                , mattr "id" stanzaID
                , mattr "xml:lang" stanzaLang
                , mattr "type" (const $ fromString <$> if null typeStr then Nothing else Just typeStr)
                ]
        mattr label f = case f stanza of
                Nothing -> []
                Just text -> [(fromString label, text)]

elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza
elementToStanza ns elemt = do
        let elemNS = X.nameNamespace (X.elementName elemt)
        when (elemNS /= Just ns) Nothing

        let elemName = X.nameLocalName (X.elementName elemt)
        case Data.Text.unpack elemName of
                "message" -> ReceivedMessage `fmap` parseMessage elemt
                "presence" -> ReceivedPresence `fmap` parsePresence elemt
                "iq" -> ReceivedIQ `fmap` parseIQ elemt
                _ -> Nothing

parseStanzaCommon ::
           (Maybe String -> Maybe t)
        -> (t -> Maybe JID -> Maybe JID -> Maybe Text -> Maybe Text -> [X.Element] -> s)
        -> X.Element
        -> Maybe s
parseStanzaCommon parseType mk elemt = do
        to <- xmlJID (s"to") elemt
        from <- xmlJID (s"from") elemt
        typ <- parseType $ Data.Text.unpack <$> X.attributeText (s"type") elemt
        return $ mk
                typ
                to
                from
                (X.attributeText (s"id") elemt)
                (X.attributeText (s"lang") elemt)
                (X.elementChildren elemt)

parseMessage :: X.Element -> Maybe Message
parseMessage =
        parseStanzaCommon parseType Message
        where
        parseType Nothing            = Just MessageNormal
        parseType (Just "normal")    = Just MessageNormal
        parseType (Just "chat")      = Just MessageChat
        parseType (Just "groupchat") = Just MessageGroupChat
        parseType (Just "headline")  = Just MessageHeadline
        parseType (Just "error")     = Just MessageError
        parseType (Just _)           = Nothing

parsePresence :: X.Element -> Maybe Presence
parsePresence =
        parseStanzaCommon parseType Presence
        where
        parseType Nothing               = Just PresenceAvailable
        parseType (Just "unavailable")  = Just PresenceUnavailable
        parseType (Just "subscribe")    = Just PresenceSubscribe
        parseType (Just "subscribed")   = Just PresenceSubscribed
        parseType (Just "unsubscribe")  = Just PresenceUnsubscribe
        parseType (Just "unsubscribed") = Just PresenceUnsubscribed
        parseType (Just "probe")        = Just PresenceProbe
        parseType (Just "error")        = Just PresenceError
        parseType (Just _)              = Nothing

parseIQ :: X.Element -> Maybe IQ
parseIQ =
        parseStanzaCommon parseType mk
        where
        mk a b c d e f = IQ a b c d e (listToMaybe f)

        parseType (Just "get")    = Just IQGet
        parseType (Just "set")    = Just IQSet
        parseType (Just "result") = Just IQResult
        parseType (Just "error")  = Just IQError
        parseType _               = Nothing

xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)
xmlJID name elemt = case X.attributeText name elemt of
        Nothing -> Just Nothing
        Just raw -> case parseJID raw of
                Just jid -> Just (Just jid)
                Nothing -> Nothing