Browse Source

Moved two stream-related pickler/unpickler's to Marshal

master
Jon Kristensen 13 years ago
parent
commit
c08d7e75b7
  1. 42
      source/Network/Xmpp/Marshal.hs
  2. 39
      source/Network/Xmpp/Stream.hs

42
source/Network/Xmpp/Marshal.hs

@ -11,6 +11,8 @@ module Network.Xmpp.Marshal where
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Data.Text
import Network.Xmpp.Types import Network.Xmpp.Types
xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
@ -222,7 +224,7 @@ unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
unpickleElem p x = unpickle (xpNodeElem p) x unpickleElem p x = unpickle (xpNodeElem p) x
xpNodeElem :: PU [Node] a -> PU Element a xpNodeElem :: PU [Node] a -> PU Element a
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> xpNodeElem xp = PU { pickleTree = \x -> Prelude.head $ (pickleTree xp x) >>= \y ->
case y of case y of
NodeElement e -> [e] NodeElement e -> [e]
_ -> [] _ -> []
@ -238,3 +240,41 @@ mbl Nothing = []
lmb :: [t] -> Maybe [t] lmb :: [t] -> Maybe [t]
lmb [] = Nothing lmb [] = Nothing
lmb x = Just x 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] ServerFeatures
xpStreamFeatures = xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF 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 = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "required")
pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
(xpAll $ xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))

39
source/Network/Xmpp/Stream.hs

@ -229,45 +229,6 @@ streamS expectedTo = do
Nothing -> throwError XmppOtherFailure Nothing -> throwError XmppOtherFailure
Just r -> streamUnpickleElem xpStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r
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] ServerFeatures
xpStreamFeatures = xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF 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 = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "required")
pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
(xpAll $ xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))
-- | Connects to the XMPP server and opens the XMPP stream against the given -- | Connects to the XMPP server and opens the XMPP stream against the given
-- host name, port, and realm. -- host name, port, and realm.
openStream :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream)) openStream :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream))

Loading…
Cancel
Save