asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

unsplit picklers

master
Philipp Balzarek 14 years ago
parent
f53abf0176
commit
786b8cd487
4 changed files with 102 additions and 90 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 39
      source/Network/Xmpp.hs
  2. 49
      source/Network/Xmpp/Errors.hs
  3. 92
      source/Network/Xmpp/Stream.hs
  4. 4
      source/Network/Xmpp/Types.hs

39
source/Network/Xmpp.hs
Unescape View File

@ -175,36 +175,27 @@ connect address hostname = do
xmppRawConnect address hostname xmppRawConnect address hostname
result <- xmppStartStream result <- xmppStartStream
case result of case result of
-- TODO: Descriptive texts in stream errors? Left e -> do
Left (StreamNotStreamElement _name) -> do pushElement . pickleElem xpStreamError $ toError e
_ <- pushElement $ pickleElem xpStreamError $
XmppStreamError StreamInvalidXml Nothing Nothing
xmppCloseStreams xmppCloseStreams
return () return ()
Left (StreamInvalidStreamNamespace _ns) -> do Right () -> return ()
_ <- pushElement $ pickleElem xpStreamError $ return result
where
-- TODO: Descriptive texts in stream errors?
toError (StreamNotStreamElement _name) =
XmppStreamError StreamInvalidXml Nothing Nothing
toError (StreamInvalidStreamNamespace _ns) =
XmppStreamError StreamInvalidNamespace Nothing Nothing XmppStreamError StreamInvalidNamespace Nothing Nothing
xmppCloseStreams toError (StreamInvalidStreamPrefix _prefix) =
return ()
Left (StreamInvalidStreamPrefix _prefix) -> do
_ <- pushElement $ pickleElem xpStreamError $
XmppStreamError StreamBadNamespacePrefix Nothing Nothing XmppStreamError StreamBadNamespacePrefix Nothing Nothing
xmppCloseStreams -- TO: Catch remaining xmppStartStream errors.
return () toError (StreamWrongVersion _ver) =
-- TODO: Catch remaining xmppStartStream errors.
Left (StreamWrongVersion _ver) -> do
_ <- pushElement $ pickleElem xpStreamError $
XmppStreamError StreamUnsupportedVersion Nothing Nothing XmppStreamError StreamUnsupportedVersion Nothing Nothing
xmppCloseStreams toError (StreamWrongLangTag _) =
return ()
Left (StreamWrongLangTag _lang) -> do
_ <- pushElement $ pickleElem xpStreamError $
XmppStreamError StreamInvalidXml Nothing Nothing XmppStreamError StreamInvalidXml Nothing Nothing
xmppCloseStreams toError StreamUnknownError =
return () XmppStreamError StreamBadFormat Nothing Nothing
Right () ->
return ()
return result
-- | Authenticate to the server using the first matching method and bind a -- | Authenticate to the server using the first matching method and bind a

49
source/Network/Xmpp/Errors.hs
Unescape View File

@ -0,0 +1,49 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.Errors where
import Control.Applicative ((<$>))
import Control.Monad(unless)
import Control.Monad.Error
import Control.Monad.Error.Class
import qualified Data.Text as Text
import Data.XML.Types
import Network.Xmpp.Types
import Network.Xmpp.Pickle
-- Finds unpickling problems. Not to be used for data validation
findStreamErrors :: Element -> StreamError
findStreamErrors (Element name attrs children)
| (nameLocalName name /= "stream")
= StreamNotStreamElement $ nameLocalName name
| (nameNamespace name /= Just "http://etherx.jabber.org/streams")
= StreamInvalidStreamNamespace $ nameNamespace name
| otherwise = checkchildren (flattenAttrs attrs)
where
checkchildren children =
let to' = lookup "to" children
ver' = lookup "version" children
xl = lookup xmlLang children
in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to')
-> StreamWrongTo to'
| Nothing == ver'
-> StreamWrongVersion Nothing
| Just (Nothing :: Maybe LangTag) ==
(safeRead <$> xl)
-> StreamWrongLangTag xl
| otherwise
-> StreamUnknownError
safeRead x = case reads $ Text.unpack x of
[] -> Nothing
[(y,_),_] -> Just y
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs attrs = map (\(name, content) ->
( name
, Text.concat $ map uncontentify content)
)
attrs
where
uncontentify (ContentText t) = t
uncontentify _ = ""

92
source/Network/Xmpp/Stream.hs
Unescape View File

@ -12,7 +12,7 @@ import Data.Conduit
import Data.Conduit.BufferedSource import Data.Conduit.BufferedSource
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Maybe (fromJust, isJust, isNothing) import Data.Maybe (fromJust, isJust, isNothing)
import Data.Text as T import Data.Text as Text
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Data.Void(Void) import Data.Void(Void)
@ -20,6 +20,7 @@ import Data.Void(Void)
import Network.Xmpp.Monad import Network.Xmpp.Monad
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Errors
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
@ -62,7 +63,7 @@ xmppStartStream :: XmppConMonad (Either StreamError ())
xmppStartStream = runErrorT $ do xmppStartStream = runErrorT $ do
state <- get state <- get
-- Set the `to' attribute depending on the state of the connection. -- Set the `to' attribute depending on the state of the connection.
let to = case sConnectionState state of let from = case sConnectionState state of
XmppConnectionPlain -> if sJidWhenPlain state XmppConnectionPlain -> if sJidWhenPlain state
then sJid state else Nothing then sJid state else Nothing
XmppConnectionSecured -> sJid state XmppConnectionSecured -> sJid state
@ -71,11 +72,13 @@ xmppStartStream = runErrorT $ do
Just hostname -> lift $ do Just hostname -> lift $ do
pushXmlDecl pushXmlDecl
pushOpenElement $ pushOpenElement $
pickleElem pickleOutStream ( to pickleElem xpStream ( "1.0"
, Just hostname , from
, Just (Jid Nothing hostname Nothing)
, Nothing
, sPreferredLang state , sPreferredLang state
) )
(lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream from
modify (\s -> s { sFeatures = features modify (\s -> s { sFeatures = features
, sStreamLang = Just lt , sStreamLang = Just lt
, sStreamId = id , sStreamId = id
@ -84,7 +87,7 @@ xmppStartStream = runErrorT $ do
) )
return () return ()
-- Creates a new connection source (of Events) using the raw source (of bytes) -- Sets a new Event source using the raw source (of bytes)
-- and calls xmppStartStream. -- and calls xmppStartStream.
xmppRestartStream :: XmppConMonad (Either StreamError ()) xmppRestartStream :: XmppConMonad (Either StreamError ())
xmppRestartStream = do xmppRestartStream = do
@ -98,29 +101,30 @@ xmppRestartStream = do
-- appropriate. -- appropriate.
-- TODO: from. -- TODO: from.
xmppStream :: Maybe Jid -> StreamSink ( LangTag xmppStream :: Maybe Jid -> StreamSink ( LangTag
, Maybe Text , Maybe Jid
, Maybe Text , Maybe Text
, ServerFeatures) , ServerFeatures)
xmppStream expectedTo = do xmppStream expectedTo = do
(langTag, from, id) <- xmppStreamHeader (from, to, id, langTag) <- xmppStreamHeader
features <- xmppStreamFeatures features <- xmppStreamFeatures
return (langTag, from, id, features) return (langTag, from, id, features)
where where
xmppStreamHeader :: StreamSink (LangTag, Maybe Text, Maybe Text) xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag)
xmppStreamHeader = do xmppStreamHeader = do
lift throwOutJunk lift throwOutJunk
-- Get the stream:stream element (or whatever it is) from the server, -- Get the stream:stream element (or whatever it is) from the server,
-- and validate what we get. -- and validate what we get.
((Name lname ns prefix), (from, id, to, ver, lang), ()) el <- openElementFromEvents
<- streamUnpickleElem pickleInStream =<< openElementFromEvents case unpickleElem xpStream el of
unless (lname == "stream") $ throwError $ StreamNotStreamElement lname Left _ -> throwError $ findStreamErrors el
unless (ns == Just "http://etherx.jabber.org/streams") $ throwError $ StreamInvalidStreamNamespace ns Right r -> validateData r
unless (prefix == Just "stream") $ throwError $ StreamInvalidStreamPrefix prefix
unless (isNothing to || (fromText $ fromJust to) == expectedTo) $ throwError $ StreamWrongTo to validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing
unless (ver == Just "1.0") $ throwError $ StreamWrongVersion ver validateData (ver, from, to, i, Just lang)
let lang_ = maybe Nothing langTag lang | ver /= "1.0" = throwError $ StreamWrongVersion (Just ver)
when (isNothing lang_) $ throwError $ StreamWrongLangTag lang | to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to)
return (fromJust lang_, from, id) -- | lang /= expectedLang = throwError $ StreamWrongLangTag lang
| otherwise = return (from, to, i, lang)
xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = do xmppStreamFeatures = do
e <- lift $ elements =$ CL.head e <- lift $ elements =$ CL.head
@ -128,52 +132,18 @@ xmppStream expectedTo = do
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamConnectionError
Just r -> streamUnpickleElem xpStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r
-- Pickler for the stream element to be sent to the server. We follow what RFC
-- 6120 calls the "prefix-free canonicalization style".)
pickleOutStream :: PU [Node] ( Maybe Jid -- from
, Maybe Text -- to
, Maybe LangTag -- xml:lang
)
pickleOutStream = xpWrap
(\(from, to, _ver, lang) -> (from, to, lang))
(\(from, to, lang) ->
(from, to, "1.0", lang)
)
(xpElemAttrs
(Name
"stream"
(Just "http://etherx.jabber.org/streams")
(Just "stream")
)
(xp4Tuple
(xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpId)
(xpAttr "version" xpId)
xpLangTag
)
)
-- Unpickler for the stream element to be received from the server. As this
-- function puts no restrictions on the element received, the data need to be xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-- validated externally. xpStream = xpElemAttrs
pickleInStream :: PU [Node] ( Name (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
, ( Maybe Text -- from
, Maybe Text -- id
, Maybe Text -- to
, Maybe Text -- version
, Maybe Text -- xml:lang
)
, ()
)
pickleInStream = xpElemWithName
(xp5Tuple (xp5Tuple
(xpAttrImplied "from" xpId) (xpAttr "version" xpId)
(xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim)
(xpAttrImplied "id" xpId) (xpAttrImplied "id" xpId)
(xpAttrImplied "to" xpId) xpLangTag
(xpAttrImplied "version" xpId)
(xpAttrImplied (Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")) xpId)
) )
xpUnit
-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
xpStreamFeatures :: PU [Node] ServerFeatures xpStreamFeatures :: PU [Node] ServerFeatures

4
source/Network/Xmpp/Types.hs
Unescape View File

@ -617,6 +617,8 @@ data XmppStreamError = XmppStreamError
} deriving (Show, Eq) } deriving (Show, Eq)
data StreamError = StreamError XmppStreamError data StreamError = StreamError XmppStreamError
| StreamUnknownError -- Something has gone wrong, but we don't
-- know what
| StreamNotStreamElement Text | StreamNotStreamElement Text
| StreamInvalidStreamNamespace (Maybe Text) | StreamInvalidStreamNamespace (Maybe Text)
| StreamInvalidStreamPrefix (Maybe Text) | StreamInvalidStreamPrefix (Maybe Text)
@ -757,7 +759,7 @@ data XmppConnection = XmppConnection
-- also below. -- also below.
, sJidWhenPlain :: Bool -- Whether or not to also include the , sJidWhenPlain :: Bool -- Whether or not to also include the
-- Jid when the connection is plain. -- Jid when the connection is plain.
, sFrom :: Maybe Text -- From as specified by the , sFrom :: Maybe Jid -- From as specified by the
-- server in the stream -- server in the stream
-- element's `from' attribute. -- element's `from' attribute.
} }

Write Preview
Loading…
Cancel
Save