From 4e39e60247a73f2475e52d13e4d284526c29aa10 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Wed, 9 May 2012 14:17:37 +0200 Subject: [PATCH] minor formatting and documentation additions --- src/Network/XMPP/Stream.hs | 158 +++++++++++++++++++------------------ 1 file changed, 83 insertions(+), 75 deletions(-) diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index ef96fb0..62c5fb6 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Network.XMPP.Stream where @@ -24,98 +24,106 @@ import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +-- Unpickles and returns a stream element. Throws a StreamXMLError on failure. streamUnpickleElem :: PU [Node] a -> Element -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do - case unpickleElem p x of - Left l -> throwError $ StreamXMLError l - Right r -> return r + case unpickleElem p x of + Left l -> throwError $ StreamXMLError l + Right r -> return r -type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a +-- This is the conduit sink that handles the stream XML events. We extend it +-- with ErrorT capabilities. +type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a +-- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do - next <- CL.peek - case next of - Nothing -> return () - Just (EventBeginElement _ _) -> return () - _ -> CL.drop 1 >> throwOutJunk + next <- CL.peek + case next of + Nothing -> return () -- This will only happen if the stream is closed. + Just (EventBeginElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk +-- Returns an (empty) Element from a stream of XML events. openElementFromEvents :: StreamSink Element openElementFromEvents = do - lift throwOutJunk - hd <- lift CL.head - case hd of - Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamConnectionError + lift throwOutJunk + hd <- lift CL.head + case hd of + Just (EventBeginElement name attrs) -> return $ Element name attrs [] + _ -> throwError $ StreamConnectionError +-- Sends the initial stream:stream element and pulls the server features. xmppStartStream :: XMPPConMonad (Either StreamError ()) xmppStartStream = runErrorT $ do - hostname' <- gets sHostname - case hostname' of - Nothing -> throwError StreamConnectionError - Just hostname -> lift . pushOpen $ - pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pullSink $ runErrorT xmppStream - modify (\s -> s {sFeatures = features}) - return () - + hostname' <- gets sHostname + case hostname' of + Nothing -> throwError StreamConnectionError + Just hostname -> lift . pushOpen $ + pickleElem pickleStream ("1.0", Nothing, Just hostname) + features <- ErrorT . pullSink $ runErrorT xmppStream + modify (\s -> s {sFeatures = features}) + return () + +-- Creates a new connection source (of Events) using the raw source (of bytes) +-- and calls xmppStartStream. xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do - raw <- gets sRawSrc - newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def - modify (\s -> s{sConSrc = newsrc}) - xmppStartStream - + raw <- gets sRawSrc + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream +-- Reads the (partial) stream:stream and the server features from the stream. xmppStream :: StreamSink ServerFeatures xmppStream = do - xmppStreamHeader - xmppStreamFeatures - -xmppStreamHeader :: StreamSink () -xmppStreamHeader = do - lift $ throwOutJunk - (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents - unless (ver == "1.0") . throwError $ StreamWrongVersion ver - return() - - -xmppStreamFeatures :: StreamSink ServerFeatures -xmppStreamFeatures = do - e <- lift $ elements =$ CL.head - case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError - Just r -> streamUnpickleElem pickleStreamFeatures r - --- Pickling - + xmppStreamHeader + xmppStreamFeatures + where + xmppStreamHeader :: StreamSink () + xmppStreamHeader = do + lift $ throwOutJunk + (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents + unless (ver == "1.0") . throwError $ StreamWrongVersion ver + return () + xmppStreamFeatures :: StreamSink ServerFeatures + xmppStreamFeatures = do + e <- lift $ elements =$ CL.head + case e of + Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Just r -> streamUnpickleElem pickleStreamFeatures r + +-- Pickler/Unpickler for the stream, with the version, from and to attributes. pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) -pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - (xpTriple - (xpAttr "version" xpId) - (xpOption $ xpAttr "from" xpId) - (xpOption $ xpAttr "to" xpId) - ) - -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) ) - +pickleStream = xpElemAttrs + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xpTriple + (xpAttr "version" xpId) + (xpOption $ xpAttr "from" xpId) + (xpOption $ xpAttr "to" xpId) + ) + +-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. pickleStreamFeatures :: PU [Node] ServerFeatures -pickleStreamFeatures = 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) - ) - +pickleStreamFeatures = 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)) \ No newline at end of file