diff --git a/test/SpecStuff.hs b/test/SpecStuff.hs deleted file mode 100644 index fe8f26e1ced8c4530e70da9c21c2a7e4650f63b9..0000000000000000000000000000000000000000 --- a/test/SpecStuff.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module SpecStuff where - -import Test.Tasty - ( TestTree - , testGroup - ) -import Test.Tasty.Wai - ( assertBody - , assertStatus - , assertStatus' - , get - , post - , testWai - ) -import Test.Tasty.QuickCheck - ( testProperty - ) -import PaymentServer.Persistence - ( Voucher - ) -import PaymentServer.Redemption - ( RedemptionAPI - , Result(Failed, Succeeded) - ) -import PaymentServer.Issuer - ( BlindedToken - ) -import Data.ByteString - ( ByteString - ) -import Text.Printf - ( printf - ) -import Data.Aeson - ( decode - , encode - ) -import Servant - ( Application - , Proxy(Proxy) - , serve - ) -import Test.Hspec - ( Spec - , parallel - , describe - , it - , runIO - ) -import Network.HTTP.Types - ( Header - ) -import Test.Hspec.Wai - ( ResponseMatcher(matchBody, matchHeaders) - , (<:>) - , WaiExpectation - , Body - , MatchBody(MatchBody) - , with - , shouldRespondWith - , liftIO - ) -import Test.QuickCheck - ( ioProperty - ) -import Test.Hspec.Wai.QuickCheck - ( Testable(toProperty) - , WaiProperty(unWaiProperty) - , property - ) -import Test.QuickCheck.Instances.Text () -import Util.Spec - ( wrongMethodNotAllowed - , nonJSONUnsupportedMediaType - , wrongJSONInvalidRequest - ) -import Util.WAI - ( postJSON - ) -import PaymentServer.Issuer - ( BlindedToken - , ChallengeBypass(ChallengeBypass) - , Issuer - , trivialIssue - ) -import PaymentServer.Redemption - ( RedemptionAPI - , Redeem(Redeem) - , Result(Failed, Succeeded) - , redemptionServer - ) -import PaymentServer.Persistence - ( RedeemError(NotPaid) - , Voucher - , VoucherDatabase(payForVoucher, redeemVoucher) - , memory - ) - -redemptionAPI :: Proxy RedemptionAPI -redemptionAPI = Proxy - -app :: VoucherDatabase d => Issuer -> d -> Application -app issue = serve redemptionAPI . redemptionServer issue - -path = "/" - -propertyRedeem :: ByteString -> Voucher -> [BlindedToken] -> ResponseMatcher -> WaiExpectation -propertyRedeem path voucher tokens matcher = - postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` matcher - --- | A VoucherDatabaseTestDouble has a VoucherDatabase instance which provides --- a number of different behaviors which are useful to be able to directly --- test against. -data VoucherDatabaseTestDouble - -- | A RefuseRedemption database always refuses redemption with a given error. - = RefuseRedemption RedeemError - -- | A PermitRedemption database always permits redemption. - | PermitRedemption - deriving (Show) - -instance VoucherDatabase VoucherDatabaseTestDouble where - payForVoucher _ voucher = return () - redeemVoucher (RefuseRedemption err) _ _ = return $ Left err - redeemVoucher PermitRedemption _ _ = return $ Right () - -test_foo :: TestTree -test_foo = testGroup "Foo" redemption - -redemption :: [TestTree] -redemption = - [ testProperty "fails when the voucher is not paid" $ - \(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"] - } - ] - -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