{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Test suite related to voucher redemption. module SpecRedemption where import Data.ByteString ( ByteString ) import Text.Printf ( printf ) import Data.Aeson ( decode , encode ) import Servant ( Application , Proxy(Proxy) , serve ) import Test.Tasty.Providers ( TestName , singleTest ) import Test.Tasty ( TestTree , testGroup , withResource ) import Test.Tasty.HUnit ( Assertion , testCase ) import Test.Tasty.Wai ( testWai , assertStatus' , assertBody , assertHeader , get ) import Test.Tasty.QuickCheck ( testProperty ) import Network.HTTP.Types ( status200 , status405 ) 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 () spec_redemption :: Spec spec_redemption = parallel $ do database <- runIO memory with (return $ app trivialIssue database) $ do describe (printf "error behavior of POST %s" (show path)) $ do wrongMethodNotAllowed "GET" path nonJSONUnsupportedMediaType path wrongJSONInvalidRequest path "{}" -- I would rather write these two as property tests but I don't know -- how. describe "double redemption" $ do it "succeeds with the same tokens" $ do let voucher = "abc" :: Voucher let tokens = [ "def", "ghi" ] :: [BlindedToken] liftIO $ payForVoucher database voucher propertyRedeem path voucher tokens 200 propertyRedeem path voucher tokens 200 it "fails with different tokens" $ do let voucher = "jkl" :: Voucher let firstTokens = [ "mno", "pqr" ] :: [BlindedToken] let secondTokens = [ "stu", "vwx" ] :: [BlindedToken] liftIO $ payForVoucher database voucher propertyRedeem path voucher firstTokens 200 propertyRedeem path voucher secondTokens 400 -- describe "redemption" $ do -- with (return $ app trivialIssue (RefuseRedemption NotPaid)) $ -- 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 trivialIssue PermitRedemption) $ -- it "receive a success response when redemption succeeds" $ property -- \(voucher :: Voucher) (tokens :: [BlindedToken]) -> do -- (ChallengeBypass key signatures proof) <- trivialIssue tokens -- return $ -- propertyRedeem path voucher tokens 200 -- { matchBody = matchJSONBody $ Succeeded key signatures proof -- , 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]) -> -- do -- liftIO $ payForVoucher database voucher -- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200 -- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200 -- it "receive 400 (OK) when the voucher is paid and previously redeemed with different tokens" $ -- property $ \(voucher :: Voucher) (firstTokens :: [BlindedToken]) (secondTokens :: [BlindedToken]) -> -- 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 -- testWithDatabase :: VoucherDatabase d => d -> Assertion -- testWithDatabase database = -- let -- testApp = app trivialIssue database -- in -- test_redemption :: TestTree -- test_redemption = -- let -- testApp = memory >>= (return . app trivialIssue) -- in -- withResource testApp (\x -> return ()) $ \getApp -> -- testGroup "Voucher Redemption" -- [ testWai' getApp "a non-POST receives a 405 (Method Not Allowed) response" $ -- do -- res <- get "/" -- assertStatus' status405 res -- assertBody "blub" res -- ]