Most basic implementation of the redeem API

src/PaymentServer/Redemption.hs

@@ -15,7 +15,9 @@ module PaymentServer.Redemption
 import GHC.Generics
   ( Generic
   )
-
+import Control.Monad.IO.Class
+  ( liftIO
+  )
 import Data.Text
   ( Text
   )
@@ -30,6 +32,7 @@ import Data.Aeson
   )
 import Servant
   ( Server
+  , Handler
   , ServerError(errBody, errHeaders)
   , err400
   , throwError
@@ -41,12 +44,14 @@ import Servant.API
   , (:>)
   )
 import PaymentServer.Persistence
-  ( VoucherDatabase
+  ( VoucherDatabase(redeemVoucher)
+  , Fingerprint
   , Voucher
   )
 
 data Result
   = Failed
+  | Succeeded
   deriving (Show, Eq)
 
 -- | A blinded token is presented along with a voucher to be signed and the
@@ -64,6 +69,7 @@ instance ToJSON Redeem where
 
 instance ToJSON Result where
   toJSON Failed = object [ "success" .= False ]
+  toJSON Succeeded = object [ "success" .= True ]
 
 type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
 
@@ -73,6 +79,15 @@ jsonErr400 = err400
   }
 
 redemptionServer :: VoucherDatabase d => d -> Server RedemptionAPI
-redemptionServer _ = redeem
+redemptionServer = redeem
+
+redeem :: VoucherDatabase d => d -> Redeem -> Handler Result
+redeem database (Redeem voucher tokens) = do
+  let fingerprint = fingerprintFromTokens tokens
+  result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint
+  case result of
+    Left err -> return Failed
+    Right () -> return Succeeded
 
-redeem request = return Failed -- throwError jsonErr400
+fingerprintFromTokens :: [BlindedToken] -> Fingerprint
+fingerprintFromTokens _ = "fingerprint"

test/SpecRedemption.hs

@@ -28,18 +28,21 @@ import Test.Hspec
   , around
   , shouldReturn
   , shouldBe
+  , runIO
   )
 import Test.Hspec.Wai
   ( with
-  , post
   , shouldRespondWith
   , liftIO
   )
 import Test.Hspec.Wai.QuickCheck
   ( property
   )
+import Test.QuickCheck
+  ( (==>)
+  )
 import Test.QuickCheck.Monadic
-  ( assert
+  ( pre
   )
 import Test.QuickCheck.Instances.Text ()
 import Util.Spec
@@ -47,6 +50,9 @@ import Util.Spec
   , nonJSONUnsupportedMediaType
   , wrongJSONInvalidRequest
   )
+import Util.WAI
+  ( postJSON
+  )
 import PaymentServer.Redemption
   ( RedemptionAPI
   , BlindedToken
@@ -80,19 +86,37 @@ withConnection :: VoucherDatabase d => IO d -> ((d -> IO ()) -> IO ())
 withConnection getDB = bracket getDB (\db -> return ())
 
 make_spec_db :: VoucherDatabase d => IO d -> Spec
-make_spec_db getDatabase =
-  before (getDatabase >>= return . app) $
-  describe "redemptionServer" $
-  do
-    it "responds to redemption of an unpaid voucher with 400 (Invalid Request)" $
+make_spec_db getDatabase = do
+  -- Create the database so we can interact with it directly in the tests
+  -- below.
+  database <- runIO getDatabase
+  before (return $ app database) $
+    describe "redemption attempts on the server" $ do
+    it "receive 400 (Invalid Request) when the voucher is unpaid" $
       property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
-      post path (encode $ Redeem voucher tokens) `shouldRespondWith` 400
+      postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 400
+
+    it "receive 200 (OK) when the voucher is paid" $
+      property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+      do
+        liftIO $ payForVoucher database voucher
+        postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
 
-    it "responds to redemption of a paid voucher with 200 (OK)" $
+    it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
       property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
       do
-        payForVoucher database voucher
-        post path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
+        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
+
+
 
 
 spec_memory_db :: Spec