diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs index 7d465e4ca24cce1021ed8a1d6dbb1d301bd4eacb..a488544cafab7647eebc08d6266362394d1332bd 100644 --- a/src/PaymentServer/Redemption.hs +++ b/src/PaymentServer/Redemption.hs @@ -7,6 +7,8 @@ -- signatures. module PaymentServer.Redemption ( RedemptionAPI + , BlindedToken + , Redeem(Redeem) , redemptionServer ) where @@ -18,7 +20,7 @@ import Data.Text ( Text ) import Data.Aeson - ( ToJSON(toJSON) + ( ToJSON(toJSON, toEncoding) , FromJSON , genericToEncoding , defaultOptions @@ -47,6 +49,8 @@ data Result = Failed deriving (Show, Eq) +-- | A blinded token is presented along with a voucher to be signed and the +-- signatures returned to the caller. type BlindedToken = Text data Redeem @@ -55,6 +59,9 @@ data Redeem instance FromJSON Redeem +instance ToJSON Redeem where + toEncoding = genericToEncoding defaultOptions + instance ToJSON Result where toJSON Failed = object [ "success" .= False ] diff --git a/test/Driver.hs b/test/Driver.hs index f2287e7136655bb1b55f1262258bcbd21bb32cb8..6462a8ad6be9e6deb9dc0e97b0194a01fe593a11 100644 --- a/test/Driver.hs +++ b/test/Driver.hs @@ -1,8 +1,44 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} - --- This is a module where we can hang the above preprocessor definition to --- direct tasty-discover to find our test suite spread across the rest of the --- modules rooted in this directory. --- --- See the test-suite definition in PaymentServer.cabal --- See also https://git.coop/decentral1se/tasty-discover +-- XXX +-- Generated with +-- $ rm test/Driver.hs && stack exec tasty-discover "./test/Driver.hs" . ./test/Driver.hs +-- Need to automate that somehow. +{-# LINE 1 "./test/Driver.hs" #-} +{-# LANGUAGE FlexibleInstances #-} +module Main (main, ingredients, tests) where +import Prelude +import qualified System.Environment as E +import qualified Test.Tasty as T +import qualified Test.Tasty.Ingredients as T +import qualified Test.Tasty.QuickCheck as QC + +import qualified Test.Tasty.Hspec as HS + +import qualified SpecPersistence + +import qualified SpecStripe + +import qualified SpecRedemption + + + +tests :: IO T.TestTree +tests = do + t0 <- HS.testSpec "memory" SpecPersistence.spec_memory + + t1 <- HS.testSpec "webhook" SpecStripe.spec_webhook + + t2 <- pure $ QC.testProperty "getVoucherFindsVoucher" SpecStripe.prop_getVoucherFindsVoucher + + t3 <- pure $ QC.testProperty "getVoucherWithoutVoucher" SpecStripe.prop_getVoucherWithoutVoucher + + t4 <- HS.testSpec "simple" SpecRedemption.spec_simple + + t5 <- HS.testSpec "memory db" SpecRedemption.spec_memory_db + + pure $ T.testGroup "./test/Driver.hs" [t0,t1,t2,t3,t4,t5] +ingredients :: [T.Ingredient] +ingredients = T.defaultIngredients +main :: IO () +main = do + args <- E.getArgs + E.withArgs ([] ++ args) $ tests >>= T.defaultMainWithIngredients ingredients diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs index 241be041e8242a78cbb16920fd5108348ad3e3c9..f134a8490daf44878efd4ef02535f9f1f0bd5dfd 100644 --- a/test/SpecRedemption.hs +++ b/test/SpecRedemption.hs @@ -11,6 +11,9 @@ import Text.Printf import Control.Exception ( bracket ) +import Data.Aeson + ( encode + ) import Servant ( Application , Proxy(Proxy) @@ -35,6 +38,10 @@ import Test.Hspec.Wai import Test.Hspec.Wai.QuickCheck ( property ) +import Test.QuickCheck.Monadic + ( assert + ) +import Test.QuickCheck.Instances.Text () import Util.Spec ( wrongMethodNotAllowed , nonJSONUnsupportedMediaType @@ -42,6 +49,8 @@ import Util.Spec ) import PaymentServer.Redemption ( RedemptionAPI + , BlindedToken + , Redeem(Redeem) , redemptionServer ) import PaymentServer.Persistence @@ -70,10 +79,15 @@ spec_simple = with (app <$> memory) $ parallel $ do withConnection :: VoucherDatabase d => IO d -> ((d -> IO ()) -> IO ()) withConnection getDB = bracket getDB (\db -> return ()) -spec_db :: Spec -spec_db = do - around (withConnection memory) $ do - describe "redemptionServer" $ do - it "responds to redemption of an unpaid voucher with 400 (Invalid Request)" $ - \(db :: MemoryVoucherDatabase) -> do - payForVoucher db "abcdefg" +make_spec_db :: VoucherDatabase d => IO d -> Spec +make_spec_db getDatabase = + before (getDatabase >>= return . app) $ + describe "redemptionServer" $ + it "responds to redemption of an unpaid voucher with 400 (Invalid Request)" $ + property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) -> + do + post path (encode $ Redeem voucher tokens) `shouldRespondWith` 400 + +spec_memory_db :: Spec +spec_memory_db = + make_spec_db memory