-- Picklers and unpicklers convert Haskell data to XML and XML to Haskell data,
-- respectively. By convensions, pickler/unpickler ("PU") function names start
-- out with "xp".
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Marshal where
import Data.XML.Pickle
import Data.XML.Types
import Data.Text
import Network.Xmpp.Types
xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
xpStreamStanza = xpEither xpStreamError xpStanza
xpStanza :: PU [Node] Stanza
xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest
, xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult
, xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError
, xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError
, xpWrap MessageS (\(MessageS x) -> x) xpMessage
, xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError
, xpWrap PresenceS (\(PresenceS x) -> x) xpPresence
]
where
-- Selector for which pickler to execute above.
stanzaSel :: Stanza -> Int
stanzaSel (IQRequestS _) = 0
stanzaSel (IQResultS _) = 1
stanzaSel (IQErrorS _) = 2
stanzaSel (MessageErrorS _) = 3
stanzaSel (MessageS _) = 4
stanzaSel (PresenceErrorS _) = 5
stanzaSel (PresenceS _) = 6
xpMessage :: PU [Node] (Message)
xpMessage = ("xpMessage" , "") <?+> xpWrap
(\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)
(\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))
(xpElem "{jabber:client}message"
(xp5Tuple
(xpDefault Normal $ xpAttr "type" xpMessageType)
(xpAttrImplied "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
-- TODO: NS?
)
(xpAll xpElemVerbatim)
)
xpPresence :: PU [Node] Presence
xpPresence = ("xpPresence" , "") <?+> xpWrap
(\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)
(\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))
(xpElem "{jabber:client}presence"
(xp5Tuple
(xpAttrImplied "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
(xpDefault Available $ xpAttr "type" xpPresenceType)
)
(xpAll xpElemVerbatim)
)
xpIQRequest :: PU [Node] IQRequest
xpIQRequest = ("xpIQRequest" , "") <?+> xpWrap
(\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body)
(\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))
(xpElem "{jabber:client}iq"
(xp5Tuple
(xpAttr "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
((xpAttr "type" xpIQRequestType))
)
xpElemVerbatim
)
xpIQResult :: PU [Node] IQResult
xpIQResult = ("xpIQResult" , "") <?+> xpWrap
(\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)
(\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))
(xpElem "{jabber:client}iq"
(xp5Tuple
(xpAttr "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
((xpAttrFixed "type" "result"))
)
(xpOption xpElemVerbatim)
)
----------------------------------------------------------
-- Errors
----------------------------------------------------------
xpErrorCondition :: PU [Node] StanzaErrorCondition
xpErrorCondition = ("xpErrorCondition" , "") <?+> xpWrap
(\(cond, (), ()) -> cond)
(\cond -> (cond, (), ()))
(xpElemByNamespace
"urn:ietf:params:xml:ns:xmpp-stanzas"
xpStanzaErrorCondition
xpUnit
xpUnit
)
xpStanzaError :: PU [Node] StanzaError
xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap
(\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)
(\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))
(xpElem "{jabber:client}error"
(xpAttr "type" xpStanzaErrorType)
(xp3Tuple
xpErrorCondition
(xpOption $ xpElem "{jabber:client}text"
(xpAttrImplied xmlLang xpLang)
(xpContent xpId)
)
(xpOption xpElemVerbatim)
)
)
xpMessageError :: PU [Node] (MessageError)
xpMessageError = ("xpMessageError" , "") <?+> xpWrap
(\((_, qid, from, to, lang), (err, ext)) ->
MessageError qid from to lang err ext)
(\(MessageError qid from to lang err ext) ->
(((), qid, from, to, lang), (err, ext)))
(xpElem "{jabber:client}message"
(xp5Tuple
(xpAttrFixed "type" "error")
(xpAttrImplied "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
(xpAttrImplied xmlLang xpLang)
-- TODO: NS?
)
(xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
)
xpPresenceError :: PU [Node] PresenceError
xpPresenceError = ("xpPresenceError" , "") <?+> xpWrap
(\((qid, from, to, lang, _),(err, ext)) ->
PresenceError qid from to lang err ext)
(\(PresenceError qid from to lang err ext) ->
((qid, from, to, lang, ()), (err, ext)))
(xpElem "{jabber:client}presence"
(xp5Tuple
(xpAttrImplied "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
(xpAttrFixed "type" "error")
)
(xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
)
xpIQError :: PU [Node] IQError
xpIQError = ("xpIQError" , "") <?+> xpWrap
(\((qid, from, to, lang, _tp),(err, body)) ->
IQError qid from to lang err body)
(\(IQError qid from to lang err body) ->
((qid, from, to, lang, ()), (err, body)))
(xpElem "{jabber:client}iq"
(xp5Tuple
(xpAttr "id" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
xpLangTag
((xpAttrFixed "type" "error"))
)
(xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
)
xpStreamError :: PU [Node] StreamErrorInfo
xpStreamError = ("xpStreamError" , "") <?+> xpWrap
(\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el)
(\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el))
(xpElemNodes
(Name
"error"
(Just "http://etherx.jabber.org/streams")
(Just "stream")
)
(xp3Tuple
(xpElemByNamespace
"urn:ietf:params:xml:ns:xmpp-streams"
xpStreamErrorCondition
xpUnit
xpUnit
)
(xpOption $ xpElem
"{urn:ietf:params:xml:ns:xmpp-streams}text"
xpLangTag
(xpContent xpId)
)
(xpOption xpElemVerbatim) -- Application specific error conditions
)
)
xpLangTag :: PU [Attribute] (Maybe LangTag)
xpLangTag = xpAttrImplied xmlLang xpLang
xpLang :: PU Text LangTag
xpLang = ("xpLang", "") <?>
xpPartial ( \input -> case langTagFromText input of
Nothing -> Left "Could not parse language tag."
Just j -> Right j)
langTagToText
xmlLang :: Name
xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
-- Given a pickler and an object, produces an Element.
pickleElem :: PU [Node] a -> a -> Element
pickleElem p = pickle $ xpNodeElem p
-- Given a pickler and an element, produces an object.
unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
unpickleElem p x = unpickle (xpNodeElem p) x
xpNodeElem :: PU [Node] a -> PU Element a
xpNodeElem = xpRoot . xpUnliftElems
mbl :: Maybe [a] -> [a]
mbl (Just l) = l
mbl Nothing = []
lmb :: [t] -> Maybe [t]
lmb [] = Nothing
lmb x = Just x
xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream = xpElemAttrs
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
(xp5Tuple
(xpAttr "version" xpId)
(xpAttrImplied "from" xpJid)
(xpAttrImplied "to" xpJid)
(xpAttrImplied "id" xpId)
xpLangTag
)
-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
xpStreamFeatures :: PU [Node] StreamFeatures
xpStreamFeatures = ("xpStreamFeatures","") <?> xpWrap
(\(tls, sasl, ver, rest) -> StreamFeatures tls (mbl sasl) ver rest)
(\(StreamFeatures tls sasl ver rest) -> (tls, lmb sasl, ver, rest))
(xpElemNodes
(Name
"features"
(Just "http://etherx.jabber.org/streams")
(Just "stream")
)
(xp4Tuple
(xpOption pickleTlsFeature)
(xpOption pickleSaslFeature)
(xpOption pickleRosterVer)
(xpAll xpElemVerbatim)
)
)
where
pickleTlsFeature :: PU [Node] Bool
pickleTlsFeature = ("pickleTlsFeature", "") <?>
xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "{urn:ietf:params:xml:ns:xmpp-tls}required")
pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = ("pickleSaslFeature", "") <?>
xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
(xpAll $ xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))
pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $
xpElemExists "{urn:xmpp:features:rosterver}optional"
xpJid :: PU Text Jid
xpJid = ("xpJid", "") <?>
xpPartial ( \input -> case jidFromText input of
Nothing -> Left "Could not parse JID."
Just j -> Right j)
jidToText
xpIQRequestType :: PU Text IQRequestType
xpIQRequestType = ("xpIQRequestType", "") <?>
xpPartial ( \input -> case iqRequestTypeFromText input of
Nothing -> Left "Could not parse IQ request type."
Just j -> Right j)
iqRequestTypeToText
where
iqRequestTypeFromText "get" = Just Get
iqRequestTypeFromText "set" = Just Set
iqRequestTypeFromText _ = Nothing
iqRequestTypeToText Get = "get"
iqRequestTypeToText Set = "set"
xpMessageType :: PU Text MessageType
xpMessageType = ("xpMessageType", "") <?>
xpPartial ( \input -> case messageTypeFromText input of
Nothing -> Left "Could not parse message type."
Just j -> Right j)
messageTypeToText
where
messageTypeFromText "chat" = Just Chat
messageTypeFromText "groupchat" = Just GroupChat
messageTypeFromText "headline" = Just Headline
messageTypeFromText "normal" = Just Normal
messageTypeFromText _ = Just Normal
messageTypeToText Chat = "chat"
messageTypeToText GroupChat = "groupchat"
messageTypeToText Headline = "headline"
messageTypeToText Normal = "normal"
xpPresenceType :: PU Text PresenceType
xpPresenceType = ("xpPresenceType", "") <?>
xpPartial ( \input -> case presenceTypeFromText input of
Nothing -> Left "Could not parse presence type."
Just j -> Right j)
presenceTypeToText
where
presenceTypeFromText "" = Just Available
presenceTypeFromText "available" = Just Available
presenceTypeFromText "unavailable" = Just Unavailable
presenceTypeFromText "subscribe" = Just Subscribe
presenceTypeFromText "subscribed" = Just Subscribed
presenceTypeFromText "unsubscribe" = Just Unsubscribe
presenceTypeFromText "unsubscribed" = Just Unsubscribed
presenceTypeFromText "probe" = Just Probe
presenceTypeFromText _ = Nothing
presenceTypeToText Available = "available"
presenceTypeToText Unavailable = "unavailable"
presenceTypeToText Subscribe = "subscribe"
presenceTypeToText Subscribed = "subscribed"
presenceTypeToText Unsubscribe = "unsubscribe"
presenceTypeToText Unsubscribed = "unsubscribed"
presenceTypeToText Probe = "probe"
xpStanzaErrorType :: PU Text StanzaErrorType
xpStanzaErrorType = ("xpStanzaErrorType", "") <?>
xpPartial ( \input -> case stanzaErrorTypeFromText input of
Nothing -> Left "Could not parse stanza error type."
Just j -> Right j)
stanzaErrorTypeToText
where
stanzaErrorTypeFromText "auth" = Just Auth
stanzaErrorTypeFromText "cancel" = Just Cancel
stanzaErrorTypeFromText "continue" = Just Continue
stanzaErrorTypeFromText "modify" = Just Modify
stanzaErrorTypeFromText "wait" = Just Wait
stanzaErrorTypeFromText _ = Nothing
stanzaErrorTypeToText Auth = "auth"
stanzaErrorTypeToText Cancel = "cancel"
stanzaErrorTypeToText Continue = "continue"
stanzaErrorTypeToText Modify = "modify"
stanzaErrorTypeToText Wait = "wait"
xpStanzaErrorCondition :: PU Text StanzaErrorCondition
xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") <?>
xpPartial ( \input -> case stanzaErrorConditionFromText input of
Nothing -> Left "Could not parse stanza error condition."
Just j -> Right j)
stanzaErrorConditionToText
where
stanzaErrorConditionToText BadRequest = "bad-request"
stanzaErrorConditionToText Conflict = "conflict"
stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented"
stanzaErrorConditionToText Forbidden = "forbidden"
stanzaErrorConditionToText Gone = "gone"
stanzaErrorConditionToText InternalServerError = "internal-server-error"
stanzaErrorConditionToText ItemNotFound = "item-not-found"
stanzaErrorConditionToText JidMalformed = "jid-malformed"
stanzaErrorConditionToText NotAcceptable = "not-acceptable"
stanzaErrorConditionToText NotAllowed = "not-allowed"
stanzaErrorConditionToText NotAuthorized = "not-authorized"
stanzaErrorConditionToText PaymentRequired = "payment-required"
stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable"
stanzaErrorConditionToText Redirect = "redirect"
stanzaErrorConditionToText RegistrationRequired = "registration-required"
stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found"
stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout"
stanzaErrorConditionToText ResourceConstraint = "resource-constraint"
stanzaErrorConditionToText ServiceUnavailable = "service-unavailable"
stanzaErrorConditionToText SubscriptionRequired = "subscription-required"
stanzaErrorConditionToText UndefinedCondition = "undefined-condition"
stanzaErrorConditionToText UnexpectedRequest = "unexpected-request"
stanzaErrorConditionFromText "bad-request" = Just BadRequest
stanzaErrorConditionFromText "conflict" = Just Conflict
stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented
stanzaErrorConditionFromText "forbidden" = Just Forbidden
stanzaErrorConditionFromText "gone" = Just Gone
stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError
stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound
stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed
stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable
stanzaErrorConditionFromText "not-allowed" = Just NotAllowed
stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized
stanzaErrorConditionFromText "payment-required" = Just PaymentRequired
stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable
stanzaErrorConditionFromText "redirect" = Just Redirect
stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired
stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound
stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout
stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint
stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable
stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired
stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition
stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest
stanzaErrorConditionFromText _ = Nothing
xpStreamErrorCondition :: PU Text StreamErrorCondition
xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>
xpPartial ( \input -> case streamErrorConditionFromText input of
Nothing -> Left "Could not parse stream error condition."
Just j -> Right j)
streamErrorConditionToText
where
streamErrorConditionToText StreamBadFormat = "bad-format"
streamErrorConditionToText StreamBadNamespacePrefix = "bad-namespace-prefix"
streamErrorConditionToText StreamConflict = "conflict"
streamErrorConditionToText StreamConnectionTimeout = "connection-timeout"
streamErrorConditionToText StreamHostGone = "host-gone"
streamErrorConditionToText StreamHostUnknown = "host-unknown"
streamErrorConditionToText StreamImproperAddressing = "improper-addressing"
streamErrorConditionToText StreamInternalServerError = "internal-server-error"
streamErrorConditionToText StreamInvalidFrom = "invalid-from"
streamErrorConditionToText StreamInvalidNamespace = "invalid-namespace"
streamErrorConditionToText StreamInvalidXml = "invalid-xml"
streamErrorConditionToText StreamNotAuthorized = "not-authorized"
streamErrorConditionToText StreamNotWellFormed = "not-well-formed"
streamErrorConditionToText StreamPolicyViolation = "policy-violation"
streamErrorConditionToText StreamRemoteConnectionFailed = "remote-connection-failed"
streamErrorConditionToText StreamReset = "reset"
streamErrorConditionToText StreamResourceConstraint = "resource-constraint"
streamErrorConditionToText StreamRestrictedXml = "restricted-xml"
streamErrorConditionToText StreamSeeOtherHost = "see-other-host"
streamErrorConditionToText StreamSystemShutdown = "system-shutdown"
streamErrorConditionToText StreamUndefinedCondition = "undefined-condition"
streamErrorConditionToText StreamUnsupportedEncoding = "unsupported-encoding"
streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature"
streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type"
streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version"
streamErrorConditionFromText "bad-format" = Just StreamBadFormat
streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix
streamErrorConditionFromText "conflict" = Just StreamConflict
streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout
streamErrorConditionFromText "host-gone" = Just StreamHostGone
streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown
streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing
streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError
streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom
streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace
streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml
streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized
streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed
streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation
streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed
streamErrorConditionFromText "reset" = Just StreamReset
streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint
streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml
streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost
streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown
streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition
streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding
streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature
streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType
streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion
streamErrorConditionFromText _ = Nothing