[wip] try writing a test for redemption behavior

PaymentServer.cabal

@@ -17,6 +17,7 @@ library
   hs-source-dirs:      src
   exposed-modules:     PaymentServer.Processors.Stripe
                      , PaymentServer.Persistence
+                     , PaymentServer.Redemption
                      , PaymentServer.Server
                      , PaymentServer.Main
   build-depends:       base >= 4.7 && < 5
@@ -46,6 +47,7 @@ test-suite PaymentServer-test
   main-is:             Driver.hs
   other-modules:       SpecStripe
                      , SpecPersistence
+                     , SpecRedemption
                      , Util.WAI
                      , Util.Gen
                      , Util.JSON

src/PaymentServer/Persistence.hs

@@ -3,6 +3,7 @@ module PaymentServer.Persistence
   , Fingerprint
   , RedeemError(NotPaid, AlreadyRedeemed)
   , VoucherDatabase(payForVoucher, redeemVoucher)
+  , MemoryVoucherDatabase
   , memory
   ) where
 

src/PaymentServer/Redemption.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+-- | This module implements the exposed interface for redeeming a voucher for
+-- signatures.
+module PaymentServer.Redemption
+  ( RedemptionAPI
+  , redemptionServer
+  ) where
+
+import GHC.Generics
+  ( Generic
+  )
+
+import Data.Text
+  ( Text
+  )
+import Data.Aeson
+  ( ToJSON(toJSON)
+  , FromJSON
+  , genericToEncoding
+  , defaultOptions
+  , encode
+  , object
+  , (.=)
+  )
+import Servant
+  ( Server
+  , ServerError(errBody, errHeaders)
+  , err400
+  , throwError
+  )
+import Servant.API
+  ( JSON
+  , Post
+  , ReqBody
+  , (:>)
+  )
+import PaymentServer.Persistence
+  ( VoucherDatabase
+  , Voucher
+  )
+
+data Result
+  = Failed
+  deriving (Show, Eq)
+
+type BlindedToken = Text
+
+data Redeem
+  = Redeem { redeemVoucher :: Voucher, redeemTokens :: [BlindedToken] }
+  deriving (Show, Eq, Generic)
+
+instance FromJSON Redeem
+
+instance ToJSON Result where
+  toJSON Failed = object [ "success" .= False ]
+
+type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
+
+jsonErr400 = err400
+  { errBody = encode Failed
+  , errHeaders = [ ("Content-Type", "application/json") ]
+  }
+
+redemptionServer :: VoucherDatabase d => d -> Server RedemptionAPI
+redemptionServer _ = redeem
+
+redeem request = return Failed -- throwError jsonErr400

src/PaymentServer/Server.hs

@@ -24,7 +24,9 @@ import PaymentServer.Persistence
   )
 
 -- | This is the complete type of the server API.
-type PaymentServerAPI = "v1" :> "stripe" :> StripeAPI
+type PaymentServerAPI
+  =    "v1" :> "stripe" :> StripeAPI
+  -- :<|> "v1" :> "redeem" :> RedeemAPI
 
 -- | Create a server which uses the given database.
 paymentServer :: VoucherDatabase d => d -> Server PaymentServerAPI

test/SpecRedemption.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Test suite related to voucher redemption.
+
+module SpecRedemption where
+
+import Text.Printf
+  ( printf
+  )
+import Control.Exception
+  ( bracket
+  )
+import Servant
+  ( Application
+  , Proxy(Proxy)
+  , serve
+  )
+import Test.Hspec
+  ( Spec
+  , parallel
+  , describe
+  , it
+  , before
+  , around
+  , shouldReturn
+  , shouldBe
+  )
+import Test.Hspec.Wai
+  ( with
+  , post
+  , shouldRespondWith
+  , liftIO
+  )
+import Test.Hspec.Wai.QuickCheck
+  ( property
+  )
+import Util.Spec
+  ( wrongMethodNotAllowed
+  , nonJSONUnsupportedMediaType
+  , wrongJSONInvalidRequest
+  )
+import PaymentServer.Redemption
+  ( RedemptionAPI
+  , redemptionServer
+  )
+import PaymentServer.Persistence
+  ( Voucher
+  , Fingerprint
+  , VoucherDatabase(payForVoucher, redeemVoucher)
+  , MemoryVoucherDatabase
+  , memory
+  )
+
+redemptionAPI :: Proxy RedemptionAPI
+redemptionAPI = Proxy
+
+app :: VoucherDatabase d => d -> Application
+app = serve redemptionAPI . redemptionServer
+
+path = "/"
+
+spec_simple :: Spec
+spec_simple = with (app <$> memory) $ parallel $ do
+  describe (printf "error behavior of POST %s" (show path)) $ do
+    wrongMethodNotAllowed "GET" path
+    nonJSONUnsupportedMediaType path
+    wrongJSONInvalidRequest path "{}"
+
+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"