Browse Source

fix xpLangTag

add language tag to stream pickler
master
Philipp Balzarek 14 years ago
parent
commit
fe5da1a5bc
  1. 2
      source/Network/Xmpp/Pickle.hs
  2. 20
      source/Network/Xmpp/Stream.hs

2
source/Network/Xmpp/Pickle.hs

@ -38,7 +38,7 @@ xpElemEmpty name = xpWrap (\((),()) -> ())
xpElem name xpUnit xpUnit xpElem name xpUnit xpUnit
xmlLang :: Name xmlLang :: Name
xmlLang = Name "lang" Nothing (Just "xml") xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
xpLangTag :: PU [Attribute] (Maybe LangTag) xpLangTag :: PU [Attribute] (Maybe LangTag)
xpLangTag = xpAttrImplied xmlLang xpPrim xpLangTag = xpAttrImplied xmlLang xpPrim

20
source/Network/Xmpp/Stream.hs

@ -64,7 +64,8 @@ xmppStartStream = runErrorT $ do
Just hostname -> lift $ do Just hostname -> lift $ do
pushXmlDecl pushXmlDecl
pushOpenElement $ pushOpenElement $
pickleElem pickleStream ("1.0", Nothing, Just hostname) -- TODO: set lang tag
pickleElem xpStream ("1.0", Nothing, Just hostname, Nothing)
features <- ErrorT . pullToSink $ runErrorT xmppStream features <- ErrorT . pullToSink $ runErrorT xmppStream
modify (\s -> s {sFeatures = features}) modify (\s -> s {sFeatures = features})
return () return ()
@ -87,7 +88,9 @@ xmppStream = do
xmppStreamHeader :: StreamSink () xmppStreamHeader :: StreamSink ()
xmppStreamHeader = do xmppStreamHeader = do
lift $ throwOutJunk lift $ throwOutJunk
(ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents -- TODO: Do somehting with the lang tag
(ver, _, _, lang) <- streamUnpickleElem xpStream
=<< openElementFromEvents
unless (ver == "1.0") . throwError $ StreamWrongVersion ver unless (ver == "1.0") . throwError $ StreamWrongVersion ver
return () return ()
xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures :: StreamSink ServerFeatures
@ -95,21 +98,22 @@ xmppStream = do
e <- lift $ elements =$ CL.head e <- lift $ elements =$ CL.head
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamConnectionError
Just r -> streamUnpickleElem pickleStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r
-- Pickler/Unpickler for the stream, with the version, from and to attributes. -- Pickler/Unpickler for the stream, with the version, from and to attributes.
pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) xpStream :: PU [Node] (Text, Maybe Text, Maybe Text, Maybe LangTag)
pickleStream = xpElemAttrs xpStream = xpElemAttrs
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
(xpTriple (xp4Tuple
(xpAttr "version" xpId) (xpAttr "version" xpId)
(xpOption $ xpAttr "from" xpId) (xpOption $ xpAttr "from" xpId)
(xpOption $ xpAttr "to" xpId) (xpOption $ xpAttr "to" xpId)
xpLangTag
) )
-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
pickleStreamFeatures :: PU [Node] ServerFeatures xpStreamFeatures :: PU [Node] ServerFeatures
pickleStreamFeatures = xpWrap xpStreamFeatures = xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest) (\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF tls sasl rest) -> (tls, lmb sasl, rest)) (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
(xpElemNodes (xpElemNodes

Loading…
Cancel
Save