diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs index a488544cafab7647eebc08d6266362394d1332bd..8fd54ba61ff0a541d7587f444cd29ab3abc4fb4c 100644 --- a/src/PaymentServer/Redemption.hs +++ b/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" diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs index 3bf7492b80248b04a4947d114bf4c5dfff6d7e8a..0f6879bb38edb11971ac3a1b9bb1efe0c08718ab 100644 --- a/test/SpecRedemption.hs +++ b/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