pontarius-xmpp/source/Network/Xmpp/Marshal.hs

-- 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, ViewPatterns, 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" xpPrim)
             (xpAttrImplied "id"   xpPrim)
             (xpAttrImplied "from" xpPrim)
             (xpAttrImplied "to"   xpPrim)
             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"   xpPrim)
              (xpAttrImplied "from" xpPrim)
              (xpAttrImplied "to"   xpPrim)
              xpLangTag
              (xpDefault Available $ xpAttr "type" xpPrim)
         )
         (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"   xpPrim)
             (xpAttrImplied "from" xpPrim)
             (xpAttrImplied "to"   xpPrim)
             xpLangTag
             ((xpAttr        "type" xpPrim))
         )
         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"   xpPrim)
             (xpAttrImplied "from" xpPrim)
             (xpAttrImplied "to"   xpPrim)
             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"
        xpPrim
        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" xpPrim)
         (xp3Tuple
              xpErrorCondition
              (xpOption $ xpElem "{jabber:client}text"
                   (xpAttrImplied xmlLang xpPrim)
                   (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"   xpPrim)
              (xpAttrImplied "from" xpPrim)
              (xpAttrImplied "to"   xpPrim)
              (xpAttrImplied xmlLang xpPrim)
              -- 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"   xpPrim)
              (xpAttrImplied "from" xpPrim)
              (xpAttrImplied "to"   xpPrim)
              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"   xpPrim)
              (xpAttrImplied "from" xpPrim)
              (xpAttrImplied "to"   xpPrim)
              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"
                   xpPrim
                   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 xpPrim

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" xpPrim)
         (xpAttrImplied "to" xpPrim)
         (xpAttrImplied "id" xpId)
         xpLangTag
    )

-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
xpStreamFeatures :: PU [Node] StreamFeatures
xpStreamFeatures = ("xpStreamFeatures","") <?> xpWrap
    (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest)
    (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest))
    (xpElemNodes
         (Name
             "features"
             (Just "http://etherx.jabber.org/streams")
             (Just "stream")
         )
         (xpTriple
              (xpOption pickleTlsFeature)
              (xpOption pickleSaslFeature)
              (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))