diff --git a/hspec-wai.cabal b/hspec-wai.cabal index 402fa1d..0677e4f 100644 --- a/hspec-wai.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index a7e3278..5324cf8 100644 --- a/package.yaml +++ b/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 diff --git a/src/Test/Hspec/Wai.hs b/src/Test/Hspec/Wai.hs index 88c2063..4eb6941 100644 --- a/src/Test/Hspec/Wai.hs +++ b/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. -- diff --git a/src/Test/Hspec/Wai/Http.hs b/src/Test/Hspec/Wai/Http.hs new file mode 100644 index 0000000..3f67e72 --- /dev/null +++ b/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 diff --git a/src/Test/Hspec/Wai/Internal.hs b/src/Test/Hspec/Wai/Internal.hs index 6972947..c6f6d7c 100644 --- a/src/Test/Hspec/Wai/Internal.hs +++ b/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 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 diff --git a/src/Test/Hspec/Wai/Server.hs b/src/Test/Hspec/Wai/Server.hs new file mode 100644 index 0000000..2302af0 --- /dev/null +++ b/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) diff --git a/test/Test/Hspec/Wai/ServerSpec.hs b/test/Test/Hspec/Wai/ServerSpec.hs new file mode 100644 index 0000000..fda8f79 --- /dev/null +++ b/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")