From 7c2e8b7a0bd0435bb40f1e2a37dedc43b168d50e Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Mon, 4 Mar 2013 13:43:23 +0100
Subject: [PATCH] replace nested TMVar usage with StateT Stream

---
 source/Network/Xmpp/Stream.hs | 44 ++++++++++++++++++-----------------
 1 file changed, 23 insertions(+), 21 deletions(-)

diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs
index 0bb5098..e885d19 100644
--- a/source/Network/Xmpp/Stream.hs
+++ b/source/Network/Xmpp/Stream.hs
@@ -94,7 +94,6 @@ startStream :: StateT Stream IO (Either XmppFailure ())
 startStream = runErrorT $ do
     liftIO $ debugM "Pontarius.Xmpp" "starting stream"
     state <- lift $ get
-    stream <- liftIO $ mkStream state
     -- Set the `from' (which is also the expected to) attribute depending on the
     -- state of the stream.
     let expectedTo = case (streamState state, toJid $ streamConfiguration state) of
@@ -120,17 +119,17 @@ startStream = runErrorT $ do
       -- Successful unpickling of stream element.
       Right (Right (ver, from, to, id, lt, features))
         | (Text.unpack ver) /= "1.0" ->
-            closeStreamWithError stream StreamUnsupportedVersion Nothing
-                "Unknown stream version"
+            closeStreamWithError StreamUnsupportedVersion Nothing
+                "Unknown version"
         | lt == Nothing ->
-            closeStreamWithError stream StreamInvalidXml Nothing
+            closeStreamWithError StreamInvalidXml Nothing
                 "stream has no language tag"
         -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead?
         | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) ->
-            closeStreamWithError stream StreamInvalidFrom Nothing
+            closeStreamWithError StreamInvalidFrom Nothing
                 "stream from is invalid"
         | to /= expectedTo ->
-            closeStreamWithError stream StreamUndefinedCondition (Just $ Element "invalid-to" [] [])
+            closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] [])
                 "stream to invalid"-- TODO: Suitable?
         | otherwise -> do
             modify (\s -> s{ streamFeatures = features
@@ -142,42 +141,43 @@ startStream = runErrorT $ do
       -- Unpickling failed - we investigate the element.
       Right (Left (Element name attrs children))
         | (nameLocalName name /= "stream") ->
-            closeStreamWithError stream StreamInvalidXml Nothing
+            closeStreamWithError StreamInvalidXml Nothing
                "Root element is not stream"
         | (nameNamespace name /= Just "http://etherx.jabber.org/streams") ->
-            closeStreamWithError stream StreamInvalidNamespace Nothing
+            closeStreamWithError StreamInvalidNamespace Nothing
                "Wrong root element name space"
         | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") ->
-            closeStreamWithError stream StreamBadNamespacePrefix Nothing
+            closeStreamWithError StreamBadNamespacePrefix Nothing
                 "Root name prefix set and not stream"
-        | otherwise -> ErrorT $ checkchildren stream (flattenAttrs attrs)
+        | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs)
   where
     -- closeStreamWithError :: MonadIO m => TMVar Stream -> StreamErrorCondition ->
     --                         Maybe Element -> ErrorT XmppFailure m ()
-    closeStreamWithError stream sec el msg = do
-        liftIO $ do
-            withStream (pushElement . pickleElem xpStreamError $
-                                StreamErrorInfo sec Nothing el) stream
-            closeStreams stream
+    closeStreamWithError  :: StreamErrorCondition -> Maybe Element -> String
+                          -> ErrorT XmppFailure (StateT Stream IO) ()
+    closeStreamWithError sec el msg = do
+        lift . pushElement . pickleElem xpStreamError
+            $ StreamErrorInfo sec Nothing el
+        lift $ closeStreams'
         throwError $ XmppOtherFailure msg
-    checkchildren stream children =
+    checkchildren children =
         let to'  = lookup "to"      children
             ver' = lookup "version" children
             xl   = lookup xmlLang   children
           in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') ->
-                               runErrorT $ closeStreamWithError stream
+                               runErrorT $ closeStreamWithError
                                    StreamBadNamespacePrefix Nothing
                                    "stream to not a valid JID"
                            | Nothing == ver' ->
-                               runErrorT $ closeStreamWithError stream
+                               runErrorT $ closeStreamWithError
                                    StreamUnsupportedVersion Nothing
                                    "stream no version"
                            | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) ->
-                               runErrorT $ closeStreamWithError stream
+                               runErrorT $ closeStreamWithError
                                    StreamInvalidXml Nothing
                                    "stream no language tag"
                            | otherwise ->
-                               runErrorT $ closeStreamWithError stream
+                               runErrorT $ closeStreamWithError
                                    StreamBadFormat Nothing
                                    ""
     safeRead x = case reads $ Text.unpack x of
@@ -264,7 +264,9 @@ openStream address port hostname config = do
 -- close the connection. Any remaining elements from the server are returned.
 -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError.
 closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element])
-closeStreams = withStream $ do
+closeStreams = withStream closeStreams'
+
+closeStreams' = do
     send <- gets (streamSend . streamHandle)
     cc <- gets (streamClose . streamHandle)
     liftIO $ send "</stream:stream>"