A seemingly reasonable initial test suite for redemption api

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 ]
 

test/Driver.hs

-{-# 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

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