From 9d9091f8e90732add462cf9acdead7dd6c4f6490 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 17 Aug 2016 14:36:24 -0300
Subject: [PATCH] Update IO content-type unrendering.

    We no longer need to use unsafeInterleaveIO.
---
 servant-server/src/Servant/Server/Internal.hs | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index bdbe9779..8ea411db 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -22,7 +22,7 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ServantErr
   ) where
 
-import           Control.Monad.Trans.Except (ExceptT, runExceptT)
+import           Control.Monad.Trans.Except (runExceptT)
 import           Control.Monad.Trans        (liftIO)
 import qualified Data.ByteString            as B
 import qualified Data.ByteString.Char8      as BC8
@@ -43,7 +43,6 @@ import           Network.Wai                (Application, Request, Response,
                                              responseLBS, vault)
 import           Prelude                    ()
 import           Prelude.Compat
-import           System.IO.Unsafe           (unsafeInterleaveIO)
 import           Web.HttpApiData            (FromHttpApiData)
 import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
@@ -445,13 +444,15 @@ instance ( AllCTUnrender list a, HasServer api context
         -- http://www.w3.org/2001/tag/2002/0129-mime
         let contentTypeH = fromMaybe "application/octet-stream"
                          $ lookup hContentType $ requestHeaders request
-        lbody <- lazyRequestBody request
-        mrqbody <- traverse (liftIO . unsafeInterleaveIO . runExceptT) $
-          handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) lbody
+        lbody <- liftIO $ lazyRequestBody request
+        let mrqbody = handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) lbody
         case mrqbody of
-          Nothing        -> delayedFailFatal err415
-          Just (Left e)  -> delayedFailFatal err400 { errBody = cs e }
-          Just (Right v) -> return v
+          Nothing   -> delayedFailFatal err415
+          Just run  -> do
+            val <- liftIO $ runExceptT run
+            case val of
+              Left e  -> delayedFailFatal err400 { errBody = cs e }
+              Right v -> return v
 
 -- | Make sure the incoming request starts with @"/path"@, strip it and
 -- pass the rest of the request path to @api@.