From 2322225c8c62ad7566bf3982a0efd6873baa2421 Mon Sep 17 00:00:00 2001
From: Eduard Sergeev <eduard.sergeev@gmail.com>
Date: Wed, 12 May 2021 22:58:00 +1000
Subject: [PATCH] Add 'testWithApplication'' function

Same as `testWithApplication` but accepts `Application` as a pure argument
The requirement of `testWithApplication` to pass `Application` parameter in wrapped in `IO` monad seems unnecessary strict:
Apparently the only action `testWithApplicationSettings` (the underlying implementation) does is to unwrap it with:
```haskell
testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a
testWithApplicationSettings settings mkApp action = do
  callingThread <- myThreadId
  app <- mkApp
  let wrappedApp request respond =
        app request respond `catch` \ e -> do
  [truncated]
```

into `app` which can be done outside of  `testWithApplication'` with:

```haskell
testWithApplication :: IO Application -> (Port -> IO a) -> IO a
testWithApplication mkApp action =
  mkApp >>= flip testWithApplication' action
```
---
 warp/ChangeLog.md                                |  5 +++++
 warp/Network/Wai/Handler/Warp.hs                 |  1 +
 warp/Network/Wai/Handler/Warp/WithApplication.hs | 15 +++++++++++++++
 warp/test/WithApplicationSpec.hs                 |  7 +++++++
 warp/warp.cabal                                  |  2 +-
 5 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md
index f634ff14e..6e4ac7a9a 100644
--- a/warp/ChangeLog.md
+++ b/warp/ChangeLog.md
@@ -1,3 +1,8 @@
+## 3.3.16
+
+* Add `testWithApplication'` function
+  Same as `testWithApplication` but accepts pure `Application` instead of `IO Application`
+
 ## 3.3.15
 
 * Using http2 v3.
diff --git a/warp/Network/Wai/Handler/Warp.hs b/warp/Network/Wai/Handler/Warp.hs
index ef1caf13a..245c468ad 100644
--- a/warp/Network/Wai/Handler/Warp.hs
+++ b/warp/Network/Wai/Handler/Warp.hs
@@ -103,6 +103,7 @@ module Network.Wai.Handler.Warp (
   , withApplication
   , withApplicationSettings
   , testWithApplication
+  , testWithApplication'
   , testWithApplicationSettings
   , openFreePort
     -- * Version
diff --git a/warp/Network/Wai/Handler/Warp/WithApplication.hs b/warp/Network/Wai/Handler/Warp/WithApplication.hs
index d69879081..0ee5eda2a 100644
--- a/warp/Network/Wai/Handler/Warp/WithApplication.hs
+++ b/warp/Network/Wai/Handler/Warp/WithApplication.hs
@@ -3,6 +3,7 @@ module Network.Wai.Handler.Warp.WithApplication (
   withApplication,
   withApplicationSettings,
   testWithApplication,
+  testWithApplication',
   testWithApplicationSettings,
   openFreePort,
   withFreePort,
@@ -48,6 +49,20 @@ withApplicationSettings settings' mkApp action = do
       Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"
       Right x -> return x
 
+-- | Same as 'testWithApplication'
+-- but accepts @app :: 'Application'@ as a first argument instead of @mkApp :: 'IO' 'Application'@.  
+--
+-- Except for the purity of its first argument, the behaviour of this function is identical to 'testWithApplication'.
+--
+-- 'testWithApplication' can be expressed via 'testWithApplication'' as:
+--
+-- >>> testWithApplication mkApp action = mkApp >>= flip testWithApplication' action
+--
+-- @since 3.3.16
+testWithApplication' :: Application -> (Port -> IO a) -> IO a
+testWithApplication' =
+  testWithApplication . return
+
 -- | Same as 'withApplication' but with different exception handling: If the
 -- given 'Application' throws an exception, 'testWithApplication' will re-throw
 -- the exception to the calling thread, possibly interrupting the execution of
diff --git a/warp/test/WithApplicationSpec.hs b/warp/test/WithApplicationSpec.hs
index 113e11eac..587459b4d 100644
--- a/warp/test/WithApplicationSpec.hs
+++ b/warp/test/WithApplicationSpec.hs
@@ -36,6 +36,13 @@ spec = do
           readProcess "curl" ["-s", "localhost:" ++ show port] "")
         `shouldThrow` (errorCall "foo")
 
+  describe "testWithApplication'" $ do
+    it "propagates exceptions from the server to the executing thread" $ do
+      let mkApp _request _respond = throwIO $ ErrorCall "foo"
+      (testWithApplication' mkApp $ \ port -> do
+          readProcess "curl" ["-s", "localhost:" ++ show port] "")
+        `shouldThrow` (errorCall "foo")
+
 {- The future netwrok library will not export MkSocket.
   describe "withFreePort" $ do
     it "closes the socket before exiting" $ do
diff --git a/warp/warp.cabal b/warp/warp.cabal
index d08cabad4..d59848bdc 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -1,5 +1,5 @@
 Name:                warp
-Version:             3.3.15
+Version:             3.3.16
 Synopsis:            A fast, light-weight web server for WAI applications.
 License:             MIT
 License-file:        LICENSE