From 5e3fdb826ac3b371a43bbef3356f78f767b0c6e7 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic-http@autogeree.net>
Date: Mon, 11 Mar 2019 13:32:51 +0000
Subject: [PATCH] Improve ServerResponse

---
 Symantic/HTTP/API.hs               |   1 +
 Symantic/HTTP/Client.hs            |   4 +-
 Symantic/HTTP/Client/Connection.hs |   8 +-
 Symantic/HTTP/MIME.hs              |   2 +-
 Symantic/HTTP/Server.hs            | 120 +++++++++++++++++++----------
 test/Hspec/API.hs                  |  71 ++++++++---------
 test/Hspec/Client.hs               |  62 ++++++++-------
 test/Hspec/Server/Error.hs         |   8 +-
 8 files changed, 157 insertions(+), 119 deletions(-)

diff --git a/Symantic/HTTP/API.hs b/Symantic/HTTP/API.hs
index 8473697..aa2fc13 100644
--- a/Symantic/HTTP/API.hs
+++ b/Symantic/HTTP/API.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE StrictData #-}
diff --git a/Symantic/HTTP/Client.hs b/Symantic/HTTP/Client.hs
index 497d6f2..9f50212 100644
--- a/Symantic/HTTP/Client.hs
+++ b/Symantic/HTTP/Client.hs
@@ -113,8 +113,8 @@ instance HTTP_Body Client where
 		 }
 instance HTTP_Response Client where
 	type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
-	type ResponseArgs       Client a ts = Proxy ts -> Proxy a -> ClientRequest
-	type Response           Client      = ClientRequest
+	type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
+	type Response Client = ClientRequest
 	response ::
 	 forall a ts repr.
 	 ResponseConstraint repr a ts =>
diff --git a/Symantic/HTTP/Client/Connection.hs b/Symantic/HTTP/Client/Connection.hs
index 0603b93..6ffd265 100644
--- a/Symantic/HTTP/Client/Connection.hs
+++ b/Symantic/HTTP/Client/Connection.hs
@@ -86,8 +86,12 @@ clientConnection req = do
 runClientConnection :: ClientEnv -> ClientConnection a -> IO (Either ClientError a)
 runClientConnection env (ClientConnection c) = E.runExceptT $ R.runReaderT c env
 
-runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
-runClientRequest env = runClientConnection env . doClientRequest
+runClient ::
+ MimeTypes ts (MimeDecodable a) =>
+ ClientEnv ->
+ (Proxy ts -> Proxy a -> ClientRequest) ->
+ IO (Either ClientError a)
+runClient env = runClientConnection env . clientConnection
 
 -- ** Type 'ClientEnv'
 data ClientEnv
diff --git a/Symantic/HTTP/MIME.hs b/Symantic/HTTP/MIME.hs
index e90a1c4..4e0529f 100644
--- a/Symantic/HTTP/MIME.hs
+++ b/Symantic/HTTP/MIME.hs
@@ -84,7 +84,7 @@ instance MediaTypeFor PlainText where
 -- * Type 'MimeType'
 -- | Existentially wraps a type-level type 't'
 -- with a proof it respects 'Constraint' 'c'.
--- Usally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@.
+-- Usyally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@.
 data MimeType c where
 	MimeType :: (c t, MediaTypeFor t) => Proxy t -> MimeType c
 mimeType :: forall t c. MediaTypeFor t => c t => MimeType c
diff --git a/Symantic/HTTP/Server.hs b/Symantic/HTTP/Server.hs
index c369097..c6dccdf 100644
--- a/Symantic/HTTP/Server.hs
+++ b/Symantic/HTTP/Server.hs
@@ -4,19 +4,23 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Symantic.HTTP.Server where
 
 import Control.Arrow (first)
-import Control.Monad (Monad(..), unless, sequence, guard)
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), unless, sequence, guard, (=<<))
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
 import Data.Bool
 import Data.Either (Either(..))
 import Data.Eq (Eq(..))
 import Data.Function (($), (.), id)
-import Data.Functor (Functor, (<$>))
+import Data.Functor (Functor(..), (<$>))
 import Data.Int (Int)
 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String, IsString(..))
 import Data.Text (Text)
@@ -24,7 +28,10 @@ import Prelude ((+))
 import System.IO (IO)
 import Text.Show (Show(..))
 import qualified Control.Monad.Classes as MC
-import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.Cont as C
+import qualified Control.Monad.Trans.Reader as R
+import qualified Control.Monad.Trans.State.Strict as S
+import qualified Control.Monad.Trans.Writer.Strict as W
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as BS64
 import qualified Data.ByteString.Lazy as BSL
@@ -58,7 +65,7 @@ newtype Server f k = Server { unServer ::
 	 (ServerCheckT [ServerErrorQuery]       -- 6th check, 400 error
 	 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
 	 (ServerCheckT [ServerErrorAccept]      -- 4th check, 406 error
-	 (ServerCheckT [ServerErrorBasicAuth]   -- 3rd check, 401 error
+	 (ServerCheckT [ServerErrorBasicAuth]   -- 3rd check, 401 or 403 error
 	 (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error
 	 (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error
 	 IO))))))))
@@ -68,7 +75,7 @@ newtype Server f k = Server { unServer ::
 -- | @'server' api handlers@ returns a 'Wai.Application'
 -- ready to be given to @Warp.run 80@.
 server ::
- Server handlers ServerResponse ->
+ Server handlers (Response Server) ->
  handlers ->
  Wai.Application
 server (Server api) handlers rq re = do
@@ -107,9 +114,8 @@ server (Server api) handlers rq re = do
 							 Right lrBody ->
 								case lrBody of
 								 Left err -> respondError status400 [] err
-								 Right (a2k, _st) ->
-									let ServerResponse app = a2k handlers in
-									app rq re
+								 Right (app, _st) ->
+									app handlers rq re
 	where
 	respondError ::
 	 Show err =>
@@ -186,7 +192,7 @@ instance Cat Server where
 	-- would do the right thing. But to my mind,
 	-- with the very few priorities of checks currently needed,
 	-- this is not worth the cognitive pain to design it.
-	-- A copy/paste/adapt will do for now.
+	-- Some copying/pasting/adapting will do for now.
 	Server x <.> Server y = Server $
 		S.StateT $ \st -> do
 			xPath <- liftIO $ runServerChecks x st
@@ -643,27 +649,46 @@ instance HTTP_Body Server where
 					 Left err -> Left $ Fail st [ServerErrorBody err]
 					 Right a -> Right ($ ServerBodyArg a)
 
--- ** Type 'ServerResponse'
-newtype ServerResponse = ServerResponse
- ( -- the request made to the server
-   Wai.Request ->
-   -- the continuation for the server to respond
-   (Wai.Response -> IO Wai.ResponseReceived) ->
-   IO Wai.ResponseReceived
- )
-instance Show ServerResponse where
-	show _ = "ServerResponse"
+-- * Type 'ServerResponse'
+-- | A continuation for |server|'s users to respond.
+--
+-- This newtype has two uses :
+-- * Carrying the 'ts' type variable to 'server'.
+-- * Providing a 'return' for the simple response case
+--   of 'status200' and no extra headers.
+newtype ServerResponse (ts::[*]) m a
+ =      ServerResponse
+ {    unServerResponse ::
+	R.ReaderT Wai.Request
+	(W.WriterT HTTP.ResponseHeaders
+	(W.WriterT HTTP.Status
+	(C.ContT Wai.Response m))) a
+ }
+ deriving (Functor, Applicative, Monad)
+instance MonadTrans (ServerResponse ts) where
+	lift = ServerResponse . lift . lift . lift . lift
+type instance MC.CanDo (ServerResponse ts m) (MC.EffReader Wai.Request) = 'True
+type instance MC.CanDo (ServerResponse ts m) (MC.EffWriter HTTP.ResponseHeaders) = 'True
+type instance MC.CanDo (ServerResponse ts m) (MC.EffWriter HTTP.Status) = 'True
+type instance MC.CanDo (ServerResponse ts IO) (MC.EffExec IO) = 'True
 
--- *** Type 'ServerRespond'
-newtype ServerRespond a (ts::[*]) = ServerRespond
-  (HTTP.Status ->
-   HTTP.ResponseHeaders ->
-   a -> Wai.Response)
+instance MC.MonadReaderN 'MC.Zero Wai.Request (ServerResponse ts m) where
+	askN px = ServerResponse $ MC.askN px
+instance MC.MonadWriterN 'MC.Zero HTTP.ResponseHeaders (ServerResponse ts m) where
+	tellN px = ServerResponse . lift . MC.tellN px
+instance MC.MonadWriterN 'MC.Zero HTTP.Status (ServerResponse ts m) where
+	tellN px = ServerResponse . lift . lift . MC.tellN px
+instance MC.MonadExecN 'MC.Zero IO (ServerResponse ts IO) where
+	execN _px = ServerResponse . lift . lift . lift . lift
 
 instance HTTP_Response Server where
 	type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
-	type ResponseArgs       Server a ts = ServerRespond a ts -> ServerResponse
-	type Response           Server      = ServerResponse
+	type ResponseArgs       Server a ts = ServerResponse ts IO a
+	-- | The continuation for 'response' to respond.
+	type Response Server =
+	 Wai.Request ->
+	 (Wai.Response -> IO Wai.ResponseReceived) ->
+	 IO Wai.ResponseReceived
 	response ::
 	 forall a ts repr.
 	 ResponseConstraint repr a ts =>
@@ -698,23 +723,15 @@ instance HTTP_Response Server where
 				case matchAccept @ts @(MimeEncodable a) h of
 				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
 				 Just mt -> return mt
-				{-
-				case Media.parseAccept h of
-				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaType expAccept) (Just (Left h))]
-				 Just gotAccept
-				  | mediaType expAccept`Media.matches`gotAccept -> return expAccept
-					-- FIXME: return gotAccept, maybe with GADTs
-				  | otherwise -> MC.throw $ Fail st
-					 [ServerErrorAccept (mediaType expAccept) (Just (Right gotAccept))]
-				-}
 		
-		-- Respond
-		return ($ ServerRespond $ \s hs a ->
-			Wai.responseLBS s
-			 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
-			 (if reqMethod == HTTP.methodHead
-				then ""
-				else mimeEncode reqAccept a))
+		return $ \(ServerResponse k) rq re -> re =<< do
+			C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
+				return $ -- IO
+					Wai.responseLBS sta
+					 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
+					 (if reqMethod == HTTP.methodHead
+						then ""
+						else mimeEncode reqAccept a)
 
 -- * Status
 status200 :: HTTP.Status
@@ -735,3 +752,22 @@ status415 :: HTTP.Status
 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
 status500 :: HTTP.Status
 status500 = HTTP.mkStatus 500 "Server Error"
+
+-- | Return worse 'HTTP.Status'.
+instance Semigroup HTTP.Status where
+	x <> y =
+		if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
+		then x
+		else y
+		where
+		rank :: Int -> Int
+		rank 404 = 0 -- Not Found
+		rank 405 = 1 -- Method Not Allowed
+		rank 401 = 2 -- Unauthorized
+		rank 415 = 3 -- Unsupported Media Type
+		rank 406 = 4 -- Not Acceptable
+		rank 400 = 5 -- Bad Request
+		rank _   = 6
+instance Monoid HTTP.Status where
+	mempty  = status200
+	mappend = (<>)
diff --git a/test/Hspec/API.hs b/test/Hspec/API.hs
index 0837294..762928e 100644
--- a/test/Hspec/API.hs
+++ b/test/Hspec/API.hs
@@ -6,6 +6,7 @@ module Hspec.API where
 
 import Control.Applicative (Applicative(..))
 import Control.Monad (Monad(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
 import Data.Bool
 import Data.Either (Either(..))
 import Data.Function (($), (.))
@@ -19,6 +20,7 @@ import Prelude (error, (+), (*))
 import System.IO (IO)
 import Text.Read (readMaybe)
 import Text.Show (Show(..))
+import qualified Control.Monad.Trans.Cont as C
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -29,15 +31,18 @@ import qualified Network.HTTP.Client as Client
 import qualified Network.HTTP.Media as Media
 import qualified Network.HTTP.Types as HTTP
 import qualified Network.URI as URI
+import qualified Network.Wai as Wai
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Test.Hspec.Wai as Wai
 import qualified Web.HttpApiData as Web
+import qualified Control.Monad.Classes as MC
 
 import Test.Hspec
 import Test.Tasty
 import Test.Tasty.Hspec
 
 import Symantic.HTTP
+import Symantic.HTTP.Utils (liftIO)
 
 -- * Type 'API0'
 data API0
@@ -75,7 +80,7 @@ api1
  <!> "succ" </> capture @Int "n"
             <.> get @Int @'[PlainText]
  
- <!> "info" </> (  head @TL.Text @'[PlainText]
+ <!> "info" </> (  post @TL.Text @'[PlainText]
                <!> get  @TL.Text @'[PlainText]
                 )
 
@@ -104,35 +109,30 @@ srv1 = server api1 $
 	route_succ :!:
 	route_info
 	where
-	route_time tz (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
-			res $ respond status200 [] $
-				TL.pack $ show time <> "\n"
+	route_time tz = do
+		i <- route_succ 0
+		time <- liftIO $ Time.utcToZonedTime tz <$> Time.getCurrentTime
+		return $ TL.pack $ show (i, time) <> "\n"
 	
-	route_date (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			date <- Time.utctDay <$> Time.getCurrentTime
-			res $ respond status200 [] $
-				TL.pack $ show date <> "\n"
+	route_date = do
+		date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
+		-- C.shiftT $ \k -> return $ Wai.responseLBS status400 [] ""
+		MC.tell status200
+		return $ TL.pack $ show date <> "\n"
 	
-	route_echo path (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] $ TL.pack $ show path <> "\n"
+	route_echo path = return $ TL.pack $ show path <> "\n"
 	
-	route_succ n (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] $ n+1
+	route_succ n = return $ n+1
 	
-	route_info = route_head :!: route_get
+	route_info = route_post :!: route_get
 		where
-		route_head (ServerRespond respond) =
-			ServerResponse $ \req res -> do
-				res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
+		route_post = do
+			req :: Wai.Request <- MC.ask
+			return $ TL.pack $ show req <> "\n"
 		
-		route_get (ServerRespond respond) =
-			ServerResponse $ \req res -> do
-				res $ respond status200 [] $ TL.pack $ show req <> "\n"
+		route_get = do
+			req :: Wai.Request <- MC.ask
+			return $ TL.pack $ show req <> "\n"
 
 warp1 :: IO ()
 warp1 = Warp.run 8080 srv1
@@ -153,22 +153,17 @@ srv2 = server api2 $
 	:!: route_auth
 	:!: route_date
 	where
-	route_time (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			time <- Time.getCurrentTime
-			res $ respond status200 [] $
-				TL.pack $ show time <> "\n"
+	route_time = do
+		date <- route_date
+		time <- liftIO $ Time.getCurrentTime
+		return $ TL.pack $ show date <> "\n" <> show time <> "\n"
 	
-	route_date (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			date <- Time.utctDay <$> Time.getCurrentTime
-			res $ respond status200 [] $
-				TL.pack $ show date <> "\n"
+	route_date = do
+		date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
+		return $ TL.pack $ show date <> "\n"
 	
-	route_auth User (ServerRespond respond) =
-			ServerResponse $ \_req res -> do
-				res $ respond status200 [] $
-					TL.pack $ show User <> "\n"
+	route_auth User = do
+		return $ TL.pack $ show User <> "\n"
 
 warp2 :: IO ()
 warp2 = Warp.run 8080 srv2
diff --git a/test/Hspec/Client.hs b/test/Hspec/Client.hs
index 8f3e439..1dd89f3 100644
--- a/test/Hspec/Client.hs
+++ b/test/Hspec/Client.hs
@@ -14,6 +14,7 @@ import Data.Functor ((<$>))
 import Data.Int (Int)
 import Data.Map.Strict (Map)
 import Data.Maybe (Maybe(..), fromJust)
+import Data.Proxy (Proxy(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String)
 import Data.Text (Text)
@@ -51,26 +52,23 @@ srv = server api $
 	     route_auth
 	 :!: route_body
 	where
-	route_auth User{} (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] ()
-	route_body (ServerBodyArg a) (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] ()
+	route_auth User{} = return ()
+	route_body (ServerBodyArg a) = return ()
 
 cli_auth
  :!: cli_body
  = client api
 
-alice, carol :: User
-alice = User "Alice" "pass" 19
-carol = User "Carol" "pass" 31
+alice, bob :: User
+alice = User "Alice" "pass" True 19
+bob   = User "Bob" "pass" False 31
 
 -- * Type "User"
 data User
  =   User
  {   user_name :: Text
  ,   user_pass :: Text
+ ,   user_auth :: Bool
  ,   user_age  :: Int
  } deriving (Eq, Show)
 instance ServerBasicAuth User where
@@ -79,7 +77,10 @@ instance ServerBasicAuth User where
 			case Map.lookup user users of
 			 Nothing -> BasicAuth_NoSuchUser
 			 Just u@User{..}
-			  | user_pass == pass -> BasicAuth_Authorized u
+			  | user_pass == pass ->
+				if user_auth
+				then BasicAuth_Authorized u
+				else BasicAuth_Unauthorized
 			  | otherwise -> BasicAuth_BadPassword
 
 users :: Map Text User
@@ -87,7 +88,7 @@ users =
 	Map.fromList $
 	(\u -> (user_name u, u)) <$>
 	[ alice
-	, carol
+	, bob
 	]
 
 {-
@@ -105,16 +106,21 @@ hspec = testSpecs $ describe "Client" $
 	beforeAll (runTestServer srv) $
 	afterAll killTestServer $ do
 		describe "BasicAuth" $ do
-			it "can authenticate" $ \TestServer{..} -> do
-				runClient (clientConnection $
-				 cli_auth (user_name alice) (user_pass alice))
+			it "can allow user (200)" $ \TestServer{..} -> do
+				runClient env (cli_auth (user_name alice) (user_pass alice))
 				 `shouldReturn` Right ()
-			{-
-			it "can deny access" $ \(_,baseURI) -> do
-				Left (ClientError_FailureResponse _ r) <-
-					runClient (clientConnection $ client api "user" "pass")
-				responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
-			-}
+			it "can deny user (401)" $ \TestServer{..} -> do
+				Left (ClientError_FailureResponse r) <-
+					runClient env $ cli_auth "no-user" (user_pass alice)
+				clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
+			it "can deny pass (401)" $ \TestServer{..} -> do
+				Left (ClientError_FailureResponse r) <-
+					runClient env $ cli_auth (user_name alice) "no-pass"
+				clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
+			it "can deny auth (403)" $ \TestServer{..} -> do
+				Left (ClientError_FailureResponse r) <-
+					runClient env $ cli_auth (user_name bob) (user_pass bob)
+				clientResStatus r `shouldBe` HTTP.Status 403 "Forbidden"
 
 {-
 import           Control.Arrow (left)
@@ -172,8 +178,8 @@ instance Arbitrary Person where
 alice :: Person
 alice = Person "Alice" 42
 
-carol :: Person
-carol = Person "Carol" 17
+bob :: Person
+bob = Person "Carol" 17
 
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
@@ -239,7 +245,7 @@ getRoot
 
 server :: Application
 server = serve api (
-       return carol
+       return bob
   :<|> return alice
   :<|> return NoContent
   :<|> (\ name -> return $ Person name 0)
@@ -329,7 +335,7 @@ runClient x baseUrl' = runClientM x $ mkClientEnv manager' baseUrl'
 sucessSpec :: Spec
 sucessSpec = beforeAll (runTestServer server) $ afterAll killTestServer $ do
     it "Servant.API.Get root" $ \(_, baseUrl) -> do
-      left show <$> runClient getRoot baseUrl  `shouldReturn` Right carol
+      left show <$> runClient getRoot baseUrl  `shouldReturn` Right bob
 
     it "Servant.API.Get" $ \(_, baseUrl) -> do
       left show <$> runClient getGet baseUrl  `shouldReturn` Right alice
@@ -558,9 +564,9 @@ pathGen = fmap NonEmpty path
 
 -- * Type 'TestServer'
 data TestServer = TestServer
- { thread    :: ThreadId
- , socket    :: Net.Socket
- , runClient :: forall a. ClientConnection a -> IO (Either ClientError a)
+ { thread :: ThreadId
+ , socket :: Net.Socket
+ , env    :: ClientEnv
  }
 
 runTestServer :: Wai.Application -> IO TestServer
@@ -573,7 +579,7 @@ runTestServer waiApp = do
 		 socket waiApp
 	manager <- Client.newManager Client.defaultManagerSettings
 	return $ TestServer
-	 { runClient=runClientConnection $ clientEnv manager baseURI
+	 { env = clientEnv manager baseURI
 	 , .. }
 
 killTestServer :: TestServer -> IO ()
diff --git a/test/Hspec/Server/Error.hs b/test/Hspec/Server/Error.hs
index fd164ec..10a21b6 100644
--- a/test/Hspec/Server/Error.hs
+++ b/test/Hspec/Server/Error.hs
@@ -59,12 +59,8 @@ instance ServerBasicAuth UnauthorizedUser where
 
 srv = server api $ route_good :!: route_unauthorized
 	where
-	route_good i params User (ServerBodyArg b) (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] (i+b)
-	route_unauthorized UnauthorizedUser (ServerRespond respond) =
-		ServerResponse $ \_req res -> do
-			res $ respond status200 [] 0
+	route_good i params User (ServerBodyArg b) = return (i+b)
+	route_unauthorized UnauthorizedUser = return 0
 
 warp :: IO ()
 warp = Warp.run 8080 srv
-- 
2.47.2