wip: Allow to test applications through a real TCP port

hspec-wai.cabal

@@ -38,17 +38,24 @@ library
     , text
     , transformers
     , case-insensitive
+    , http-client
     , http-types
+    , network
     , wai >= 3
     , wai-extra >= 3
+    , warp
     , hspec-core == 2.*
     , hspec-expectations
     , QuickCheck
+    , data-default-class
+    , blaze-builder
   exposed-modules:
       Test.Hspec.Wai
-      Test.Hspec.Wai.QuickCheck
       Test.Hspec.Wai.Internal
+      Test.Hspec.Wai.QuickCheck
+      Test.Hspec.Wai.Server
   other-modules:
+      Test.Hspec.Wai.Http
       Test.Hspec.Wai.Matcher
       Test.Hspec.Wai.Util
   default-language: Haskell2010
@@ -67,21 +74,31 @@ test-suite spec
     , text
     , transformers
     , case-insensitive
+    , http-client
     , http-types
+    , network
     , wai >= 3
     , wai-extra >= 3
+    , warp
     , hspec-core == 2.*
     , hspec-expectations
     , QuickCheck
+    , data-default-class
+    , blaze-builder
     , hspec
     , QuickCheck
+    , process
+    , silently
   other-modules:
       Test.Hspec.Wai
+      Test.Hspec.Wai.Http
       Test.Hspec.Wai.Internal
       Test.Hspec.Wai.Matcher
       Test.Hspec.Wai.QuickCheck
+      Test.Hspec.Wai.Server
       Test.Hspec.Wai.Util
       Test.Hspec.Wai.MatcherSpec
+      Test.Hspec.Wai.ServerSpec
       Test.Hspec.Wai.UtilSpec
       Test.Hspec.WaiSpec
   default-language: Haskell2010

package.yaml

@@ -29,18 +29,24 @@ dependencies:
   - text
   - transformers
   - case-insensitive
+  - http-client
   - http-types
+  - network
   - wai >= 3
   - wai-extra >= 3
+  - warp
   - hspec-core == 2.*
   - hspec-expectations
   - QuickCheck
+  - data-default-class
+  - blaze-builder
 
 library:
   exposed-modules:
     - Test.Hspec.Wai
-    - Test.Hspec.Wai.QuickCheck
     - Test.Hspec.Wai.Internal
+    - Test.Hspec.Wai.QuickCheck
+    - Test.Hspec.Wai.Server
 
 tests:
   spec:
@@ -49,3 +55,5 @@ tests:
     dependencies:
       - hspec
       - QuickCheck
+      - process
+      - silently

src/Test/Hspec/Wai.hs

@@ -31,11 +31,12 @@ module Test.Hspec.Wai (
 , pendingWith
 ) where
 
+import           Control.Monad.Trans.Reader
 import           Data.Foldable
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LB
 import           Control.Monad.IO.Class
-import           Network.Wai (Request(..))
+import           Network.Wai (Application, Request(..))
 import           Network.HTTP.Types
 import           Network.Wai.Test hiding (request)
 import qualified Network.Wai.Test as Wai
@@ -49,9 +50,14 @@ import           Test.Hspec.Wai.Util
 import           Test.Hspec.Wai.Internal
 import           Test.Hspec.Wai.Matcher
 
--- | An alias for `before`.
-with :: IO a -> SpecWith a -> Spec
-with = before
+with :: IO Application -> SpecWith RequestAction -> Spec
+with action = around $ \e -> do
+  app <- action
+  let r :: RequestAction
+      r method path headers body = runSession (Wai.srequest $ SRequest req body) app
+        where
+          req = setPath defaultRequest {requestMethod = method, requestHeaders = headers} path
+  e r
 
 -- | A lifted version of `Core.pending`.
 pending :: WaiSession ()
@@ -127,9 +133,9 @@ delete path = request methodDelete path [] ""
 -- | Perform a request to the application under test, with specified HTTP
 -- method, request path, headers and body.
 request :: Method -> ByteString -> [Header] -> LB.ByteString -> WaiSession SResponse
-request method path headers body = getApp >>= liftIO . runSession (Wai.srequest $ SRequest req body)
-  where
-    req = setPath defaultRequest {requestMethod = method, requestHeaders = headers} path
+request method path headers body = WaiSession $ do
+  r <- ask
+  liftIO $ r method path headers body
 
 -- | Perform a @POST@ request to the application under test.
 --

src/Test/Hspec/Wai/Http.hs

@@ -0,0 +1,48 @@
+module Test.Hspec.Wai.Http where
+
+import           Network.Wai (Application)
+import           Network.HTTP.Types
+
+import           Test.Hspec.Core.Spec hiding (pending, pendingWith)
+import           Test.Hspec.Core.Hooks
+
+import           Test.Hspec.Wai.Internal
+import           Test.Hspec.Wai.Server
+
+import           Network.HTTP.Client
+
+import qualified Blaze.ByteString.Builder as B
+
+import           Data.Default.Class (def)
+
+import           Network.Wai.Test (SResponse(..))
+
+withServer :: IO Application -> SpecWith RequestAction -> Spec
+withServer app = around $ \e -> do
+  withApplication app $ \port_ -> do
+    let r :: RequestAction
+        r method_ path_ headers_ body_ = foo
+          where
+            (segments, query_) = decodePath path_
+
+            foo :: IO SResponse
+            foo = do
+              manager <- newManager defaultManagerSettings
+              let request = def {
+                    port = port_
+                  , requestHeaders = headers_
+                  , path = B.toByteString (encodePathSegments segments)
+                  , queryString = renderQuery True query_
+                  , method = method_
+                  , redirectCount = 0
+                  , responseTimeout = Nothing
+                  , checkStatus = \_ _ _ -> Nothing
+                  , requestBody = RequestBodyLBS body_
+                  }
+              response <- httpLbs request manager
+              return $ SResponse {
+                  simpleStatus = responseStatus response
+                , simpleHeaders = responseHeaders response
+                , simpleBody = responseBody response
+                }
+    e r

src/Test/Hspec/Wai/Internal.hs

@@ -5,9 +5,8 @@
 module Test.Hspec.Wai.Internal (
   WaiExpectation
 , WaiSession(..)
+, RequestAction
 , runWaiSession
-, withApplication
-, getApp
 , formatHeader
 ) where
 
@@ -16,7 +15,9 @@ import           Prelude.Compat
 
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Reader
-import           Network.Wai (Application)
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import           Network.HTTP.Types
 import           Network.Wai.Test hiding (request)
 import           Test.Hspec.Core.Spec
 import           Test.Hspec.Wai.Util (formatHeader)
@@ -28,18 +29,14 @@ type WaiExpectation = WaiSession ()
 
 -- | A <http://www.yesodweb.com/book/web-application-interface WAI> test
 -- session that carries the `Application` under test an some client state.
-newtype WaiSession a = WaiSession {unWaiSession :: Session a}
+newtype WaiSession a = WaiSession {unWaiSession :: ReaderT RequestAction IO a}
   deriving (Functor, Applicative, Monad, MonadIO)
 
-runWaiSession :: WaiSession a -> Application -> IO a
-runWaiSession = runSession . unWaiSession
+type RequestAction = Method -> ByteString -> [Header] -> LB.ByteString -> IO SResponse
 
-withApplication :: Application -> WaiSession a -> IO a
-withApplication = flip runWaiSession
+runWaiSession :: WaiSession a -> RequestAction -> IO a
+runWaiSession = runReaderT . unWaiSession
 
 instance Example WaiExpectation where
-  type Arg WaiExpectation = Application
+  type Arg WaiExpectation = RequestAction
   evaluateExample e p action = evaluateExample (action $ runWaiSession e) p ($ ())
-
-getApp :: WaiSession Application
-getApp = WaiSession ask

src/Test/Hspec/Wai/Server.hs

@@ -0,0 +1,83 @@
+
+module Test.Hspec.Wai.Server (
+  withApplication,
+  openFreePort,
+) where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Network.Socket
+import           Network.Wai
+import           Network.Wai.Handler.Warp
+
+data App
+  = App {
+    appThread :: ThreadId,
+    appWaitForKilled :: IO (),
+    appExceptionMVar :: MVar (Maybe SomeException),
+    appPort :: Int
+  }
+
+-- | Allows to test 'Application's over a real network port.
+--
+-- Runs the given 'Application' on a free port. Passes the free port to the
+-- given operation and executes it.
+withApplication :: IO Application -> (Port -> IO a) -> IO a
+withApplication mkApp action = do
+  app <- mkApp
+  bracket (acquire app) free (\ runningApp -> action (appPort runningApp))
+  where
+    acquire :: Application -> IO App
+    acquire app = do
+      start <- mkWaiter
+      killed <- mkWaiter
+      exceptionMVar_ <- newMVar Nothing
+      thread <- forkIO $ do
+        (port, sock) <- openFreePort
+        let settings =
+              setBeforeMainLoop (notify start port)
+              defaultSettings
+        runSettingsSocket settings sock (handleApp exceptionMVar_ app)
+          `finally` notify killed ()
+      port <- waitFor start
+      return $ App thread (waitFor killed) exceptionMVar_ port
+
+    free :: App -> IO ()
+    free runningApp = do
+      killThread $ appThread runningApp
+      appWaitForKilled runningApp
+      exception <- readMVar (appExceptionMVar runningApp)
+      case exception of
+        Nothing -> return ()
+        Just e -> throwIO e
+
+handleApp :: MVar (Maybe SomeException) -> Application -> Application
+handleApp mvar app request respond = do
+  catch (app request respond) $ \ e -> do
+    modifyMVar_ mvar $ \ _ ->
+      return (Just e)
+    throwIO e
+
+data Waiter a
+  = Waiter {
+    notify :: a -> IO (),
+    waitFor :: IO a
+  }
+
+mkWaiter :: IO (Waiter a)
+mkWaiter = do
+  mvar <- newEmptyMVar
+  return $ Waiter {
+    notify = putMVar mvar,
+    waitFor = readMVar mvar
+  }
+
+-- | Opens a socket on a free port returns both port and socket.
+openFreePort :: IO (Port, Socket)
+openFreePort = do
+  s <- socket AF_INET Stream defaultProtocol
+  localhost <- inet_addr "127.0.0.1"
+  bind s (SockAddrInet aNY_PORT localhost)
+  listen s 1
+  port <- socketPort s
+  return (fromIntegral port, s)

test/Test/Hspec/Wai/ServerSpec.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Hspec.Wai.ServerSpec where
+
+import           Control.Exception
+import           Network.HTTP.Types
+import           Network.Wai
+import           System.IO.Silently
+import           System.Process
+import           Test.Hspec
+
+import           Test.Hspec.Wai.Server
+
+spec :: Spec
+spec = do
+  describe "withApplication" $ do
+    it "runs a wai Application while executing the given action" $ do
+      let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"
+      withApplication mkApp $ \ port -> do
+        output <- silence $ readProcess "curl" ["localhost:" ++ show port] ""
+        output `shouldBe` "foo"
+
+    it "propagates exceptions from the server to the executing thread" $ do
+      let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
+      (withApplication mkApp $ \ port -> do
+          silence $ readProcess "curl" ["localhost:" ++ show port] "")
+        `shouldThrow` (== ErrorCall "foo")