pursue this elsewhere

test/SpecStuff.hs

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