Stanza.hs

-- 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