From 2833850606d7b2ff93c4df7bb0681f8999ad6c7e Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Wed, 4 Sep 2019 14:25:55 -0400
Subject: [PATCH] make some assertions about the response body
---
src/PaymentServer/Redemption.hs | 12 +++++--
test/SpecRedemption.hs | 56 ++++++++++++++++++++++++++-------
2 files changed, 55 insertions(+), 13 deletions(-)
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index 11acd39..35963cb 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -9,6 +9,7 @@ module PaymentServer.Redemption
( RedemptionAPI
, BlindedToken
, Redeem(Redeem)
+ , Result(Failed, Succeeded)
, redemptionServer
) where
@@ -28,7 +29,9 @@ import Data.Text.Encoding
)
import Data.Aeson
( ToJSON(toJSON, toEncoding)
- , FromJSON
+ , FromJSON(parseJSON)
+ , withObject
+ , (.:)
, genericToEncoding
, defaultOptions
, encode
@@ -80,11 +83,16 @@ instance ToJSON Result where
toJSON Failed = object [ "success" .= False ]
toJSON Succeeded = object [ "success" .= True ]
+instance FromJSON Result where
+ parseJSON = withObject "Result" $ \v ->
+ v .: "success" >>= \success ->
+ return $ if success then Succeeded else Failed
+
type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
jsonErr400 = err400
{ errBody = encode Failed
- , errHeaders = [ ("Content-Type", "application/json") ]
+ , errHeaders = [ ("Content-Type", "application/json;charset=utf-8") ]
}
redemptionServer :: VoucherDatabase d => d -> Server RedemptionAPI
diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs
index 7c545b9..00b9f33 100644
--- a/test/SpecRedemption.hs
+++ b/test/SpecRedemption.hs
@@ -15,7 +15,9 @@ import Control.Exception
( bracket
)
import Data.Aeson
- ( encode
+ ( FromJSON
+ , decode
+ , encode
)
import Servant
( Application
@@ -33,9 +35,15 @@ import Test.Hspec
, shouldBe
, runIO
)
+import Network.HTTP.Types
+ ( Header
+ )
import Test.Hspec.Wai
- ( ResponseMatcher(ResponseMatcher)
+ ( ResponseMatcher(matchBody, matchHeaders)
+ , (<:>)
, WaiExpectation
+ , Body
+ , MatchBody(MatchBody)
, with
, shouldRespondWith
, liftIO
@@ -63,6 +71,7 @@ import PaymentServer.Redemption
( RedemptionAPI
, BlindedToken
, Redeem(Redeem)
+ , Result(Failed, Succeeded)
, redemptionServer
)
import PaymentServer.Persistence
@@ -132,15 +141,24 @@ spec_redemption = parallel $ do
describe "redemption" $ do
- with (return . app $ RefuseRedemption NotPaid) $
- it "receives 400 (Invalid Request) when the voucher is not paid" $ property $
- \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- propertyRedeem path voucher tokens 400
-
- with (return $ app PermitRedemption) $
- it "receive 200 (OK) when redemption succeeds" $ property $
- \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- propertyRedeem path voucher tokens 200
+ with (return . app $ RefuseRedemption NotPaid) $ do
+ it "receives a failure response when the voucher is not paid" $ property $
+ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ propertyRedeem path voucher tokens 400
+ { matchBody = matchJSONBody Failed
+ -- major/minor, fine. charset=utf-8... okay. but really this is
+ -- overspecified by encoding the exact byte sequence. I'd rather
+ -- assert semantic equality.
+ , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
+ }
+
+ with (return $ app PermitRedemption) $ do
+ it "receive a success response when redemption succeeds" $ property $
+ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ propertyRedeem path voucher tokens 200
+ { matchBody = matchJSONBody Succeeded
+ , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
+ }
-- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
-- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
@@ -155,3 +173,19 @@ spec_redemption = parallel $ do
-- liftIO $ payForVoucher database voucher
-- postJSON path (encode $ Redeem voucher firstTokens) `shouldRespondWith` 200
-- postJSON path (encode $ Redeem voucher secondTokens) `shouldRespondWith` 400
+
+matchJSONBody :: Result -> MatchBody
+matchJSONBody expected =
+ let
+ bodyMatcher :: [Header] -> Body -> Maybe String
+ bodyMatcher headers actualBody =
+ case decode actualBody of
+ Nothing ->
+ Just $ "failed to decode body as value of expected type: " ++ show actualBody
+ Just actual ->
+ if actual == expected then
+ Nothing
+ else
+ Just $ "decoded body does not equal expected value: " ++ show actual ++ show expected
+ in
+ MatchBody bodyMatcher
--
GitLab