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