diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 4bba8eea5a2d1bc944ac946fb030c539a3bc978e..56d7c013c6bb0ec8b54d3506d5d9e0c64ddb7347 100644
--- a/PaymentServer.cabal
+++ b/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
@@ -30,12 +31,14 @@ library
, stripe-core
, text
, containers
+ , cryptonite
default-language: Haskell2010
+ ghc-options: -Wmissing-import-lists -Wunused-imports
executable PaymentServer-exe
hs-source-dirs: app
main-is: Main.hs
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
build-depends: base
, PaymentServer
default-language: Haskell2010
@@ -46,9 +49,11 @@ test-suite PaymentServer-test
main-is: Driver.hs
other-modules: SpecStripe
, SpecPersistence
+ , SpecRedemption
, Util.WAI
, Util.Gen
, Util.JSON
+ , Util.Spec
build-depends: base
, PaymentServer
, hspec
@@ -74,7 +79,7 @@ test-suite PaymentServer-test
, containers
, unordered-containers
, ilist
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
default-language: Haskell2010
source-repository head
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index adbc78b7754d89481363380c483f17064f42c9fe..7d9ee2a744eb96d4f977e728298e21da1385742a 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -10,13 +10,10 @@ import Network.Wai.Handler.Warp
( run
)
import Network.Wai.Middleware.RequestLogger
- ( OutputFormat(Detailed, CustomOutputFormatWithDetails)
+ ( OutputFormat(Detailed)
, outputFormat
, mkRequestLogger
)
-import Network.Wai.Middleware.RequestLogger.JSON
- ( formatAsJSON
- )
import PaymentServer.Persistence
( memory
)
diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs
index eea14b43cf92b45c2977e1e6801306aa4dd194db..d08f12a67a393c8f4dea16b02a7a3ece162eb4f4 100644
--- a/src/PaymentServer/Persistence.hs
+++ b/src/PaymentServer/Persistence.hs
@@ -3,6 +3,7 @@ module PaymentServer.Persistence
, Fingerprint
, RedeemError(NotPaid, AlreadyRedeemed)
, VoucherDatabase(payForVoucher, redeemVoucher)
+ , MemoryVoucherDatabase
, memory
) where
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
new file mode 100644
index 0000000000000000000000000000000000000000..23dfbc849b6699f61d1be229d85e3f7ae3535766
--- /dev/null
+++ b/src/PaymentServer/Redemption.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+-- | This module implements the exposed interface for redeeming a voucher for
+-- signatures.
+module PaymentServer.Redemption
+ ( RedemptionAPI
+ , BlindedToken
+ , Redeem(Redeem)
+ , Result(Failed, Succeeded)
+ , redemptionServer
+ ) where
+
+import GHC.Generics
+ ( Generic
+ )
+import Control.Monad.IO.Class
+ ( liftIO
+ )
+import Data.Text
+ ( Text
+ , pack
+ )
+import Data.Text.Encoding
+ ( encodeUtf8
+ )
+import Data.Aeson
+ ( ToJSON(toJSON, toEncoding)
+ , FromJSON(parseJSON)
+ , withObject
+ , (.:)
+ , genericToEncoding
+ , defaultOptions
+ , encode
+ , object
+ , (.=)
+ )
+import Servant
+ ( Server
+ , Handler
+ , ServerError(errBody, errHeaders)
+ , err400
+ , throwError
+ )
+import Servant.API
+ ( JSON
+ , Post
+ , ReqBody
+ , (:>)
+ )
+import Crypto.Hash
+ ( SHA3_512(SHA3_512)
+ , hashWith
+ )
+import PaymentServer.Persistence
+ ( VoucherDatabase(redeemVoucher)
+ , Fingerprint
+ , Voucher
+ )
+
+-- | A cryptographic signature of a blinded token created using our private
+-- key.
+type Signature = Text
+
+-- | A public key corresponding to our private key.
+type PublicKey = Text
+
+-- | A zero-knowledge proof that signatures were created of the corresponding
+-- blinded tokens using the corresponding public key's private key.
+type Proof = Text
+
+data Result
+ = Failed
+ | Succeeded PublicKey [Signature] Proof
+ 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
+
+-- | A complete redemption attempt which can be presented at the redemption
+-- endpoint.
+data Redeem
+ = Redeem
+ { redeemVoucher :: Voucher -- ^ The voucher being redeemed.
+ , redeemTokens :: [BlindedToken] -- ^ Tokens to be signed as part of this redemption.
+ } deriving (Show, Eq, Generic)
+
+instance FromJSON Redeem
+
+instance ToJSON Redeem where
+ toEncoding = genericToEncoding defaultOptions
+
+instance ToJSON Result where
+ toJSON Failed = object [ "success" .= False ]
+ toJSON (Succeeded key signatures proof) = object
+ [ "success" .= True
+ , "public-key" .= key
+ , "signatures" .= signatures
+ , "proof" .= proof
+ ]
+
+instance FromJSON Result where
+ parseJSON = withObject "Result" $ \v ->
+ v .: "success" >>= \success ->
+ if success then
+ Succeeded
+ <$> v .: "public-key"
+ <*> v .: "signatures"
+ <*> v .: "proof"
+ else
+ return Failed
+
+type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
+
+jsonErr400 = err400
+ { errBody = encode Failed
+ , errHeaders = [ ("Content-Type", "application/json;charset=utf-8") ]
+ }
+
+redemptionServer :: VoucherDatabase d => d -> Server RedemptionAPI
+redemptionServer = redeem
+
+-- | Handler for redemption requests. Use the database to try to redeem the
+-- voucher and return signatures. Return a failure if this is not possible
+-- (eg because the voucher was already redeemed).
+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 -> throwError jsonErr400
+ Right () -> return $ Succeeded "" [] ""
+
+-- | Compute a cryptographic hash (fingerprint) of a list of tokens which can
+-- be used as an identifier for this exact sequence of tokens.
+fingerprintFromTokens :: [BlindedToken] -> Fingerprint
+fingerprintFromTokens =
+ let
+ hash = pack . show . hashWith SHA3_512 . encodeUtf8
+ in
+ foldl (\b a -> hash $ a `mappend` b) "" . map hash
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index f4ecaf3eb1f62a307e9a8dbc9651b05b6447855e..f55b779b99f7a3395a02aca78a0f636e358f2542 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
@@ -14,21 +13,30 @@ import Servant
, Application
, serve
, (:>)
+ , (:<|>)((:<|>))
)
import PaymentServer.Processors.Stripe
( StripeAPI
, stripeServer
)
+import PaymentServer.Redemption
+ ( RedemptionAPI
+ , redemptionServer
+ )
import PaymentServer.Persistence
( VoucherDatabase
)
-- | This is the complete type of the server API.
-type PaymentServerAPI = "v1" :> "stripe" :> StripeAPI
+type PaymentServerAPI
+ = "v1" :> "stripe" :> StripeAPI
+ :<|> "v1" :> "redeem" :> RedemptionAPI
-- | Create a server which uses the given database.
paymentServer :: VoucherDatabase d => d -> Server PaymentServerAPI
-paymentServer = stripeServer
+paymentServer d =
+ stripeServer d
+ :<|> redemptionServer d
paymentServerAPI :: Proxy PaymentServerAPI
paymentServerAPI = Proxy
@@ -36,4 +44,4 @@ paymentServerAPI = Proxy
-- | Create a Servant Application which serves the payment server API using
-- the given database.
paymentServerApp :: VoucherDatabase d => d -> Application
-paymentServerApp = (serve paymentServerAPI) . paymentServer
+paymentServerApp = serve paymentServerAPI . paymentServer
diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e9c05108d596bfc232cb7cf749026960587212db
--- /dev/null
+++ b/test/SpecRedemption.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Test suite related to voucher redemption.
+
+module SpecRedemption where
+
+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.Hspec.Wai.QuickCheck
+ ( property
+ )
+import Test.QuickCheck.Instances.Text ()
+import Util.Spec
+ ( wrongMethodNotAllowed
+ , nonJSONUnsupportedMediaType
+ , wrongJSONInvalidRequest
+ )
+import Util.WAI
+ ( postJSON
+ )
+import PaymentServer.Redemption
+ ( RedemptionAPI
+ , BlindedToken
+ , Redeem(Redeem)
+ , Result(Failed, Succeeded)
+ , redemptionServer
+ )
+import PaymentServer.Persistence
+ ( RedeemError(NotPaid)
+ , Voucher
+ , VoucherDatabase(payForVoucher, redeemVoucher)
+ , memory
+ )
+
+redemptionAPI :: Proxy RedemptionAPI
+redemptionAPI = Proxy
+
+app :: VoucherDatabase d => d -> Application
+app = serve redemptionAPI . redemptionServer
+
+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 ()
+
+spec_redemption :: Spec
+spec_redemption = parallel $ do
+ database <- runIO memory
+ with (return . app $ database) $
+ do
+ describe (printf "error behavior of POST %s" (show path)) $
+ do
+ wrongMethodNotAllowed "GET" path
+ nonJSONUnsupportedMediaType path
+ wrongJSONInvalidRequest path "{}"
+
+ -- I would rather write these two as property tests but I don't know
+ -- how.
+ describe "double redemption" $ do
+ it "succeeds with the same tokens" $ do
+ let voucher = "abc" :: Voucher
+ let tokens = [ "def", "ghi" ] :: [BlindedToken]
+ liftIO $ payForVoucher database voucher
+ propertyRedeem path voucher tokens 200
+ propertyRedeem path voucher tokens 200
+
+ it "fails with different tokens" $ do
+ let voucher = "jkl" :: Voucher
+ let firstTokens = [ "mno", "pqr" ] :: [BlindedToken]
+ let secondTokens = [ "stu", "vwx" ] :: [BlindedToken]
+ liftIO $ payForVoucher database voucher
+ propertyRedeem path voucher firstTokens 200
+ propertyRedeem path voucher secondTokens 400
+
+
+ describe "redemption" $ do
+ with (return . app $ RefuseRedemption NotPaid) $
+ it "receives a failure response when the voucher is not paid" $ property $
+ \(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"]
+ }
+
+ with (return $ app PermitRedemption) $
+ it "receive a success response when redemption succeeds" $ property $
+ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ propertyRedeem path voucher tokens 200
+ -- TODO: Get some real crypto involved to be able to replace these
+ -- dummy values.
+ { matchBody = matchJSONBody $ Succeeded "" [] ""
+ , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
+ }
+
+ -- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
+ -- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ -- do
+ -- 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
+
+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
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
index 23ad2932d4368416880b5383a23f9d947017eea8..d2a281b1f5eadef91c4fee31e2f73b387f11e17a 100644
--- a/test/SpecStripe.hs
+++ b/test/SpecStripe.hs
@@ -14,6 +14,7 @@ import Data.Aeson
)
import Test.Hspec
( Spec
+ , parallel
, describe
, it
)
@@ -72,6 +73,11 @@ import PaymentServer.Persistence
( Voucher
, memory
)
+import Util.Spec
+ ( wrongMethodNotAllowed
+ , nonJSONUnsupportedMediaType
+ , wrongJSONInvalidRequest
+ )
stripeAPI :: Proxy StripeAPI
stripeAPI = Proxy
@@ -80,13 +86,11 @@ app :: IO Application
app = serve stripeAPI . stripeServer <$> memory
spec_webhook :: Spec
-spec_webhook = with app $ do
+spec_webhook = with app $ parallel $ do
describe "error behavior of POST /webhook" $ do
- it "responds to non-JSON Content-Type with 415 (Unsupported Media Type)" $
- post "/webhook" "xxx" `shouldRespondWith` 415
-
- it "responds to JSON non-Event body with 400 (Invalid Request)" $
- postJSON "/webhook" "{}" `shouldRespondWith` 400
+ wrongMethodNotAllowed "GET" "/webhook"
+ nonJSONUnsupportedMediaType "/webhook"
+ wrongJSONInvalidRequest "/webhook" "{}"
-- I would like to make most or all of these into property tests. *This*
-- test shows how you can do it. Yay. The main thing (for me, anyway) to
@@ -109,7 +113,6 @@ spec_webhook = with app $ do
property xtest_postWithEventBody
-
bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
bodyMatcher _ "{}" = Nothing
bodyMatcher _ body = Just $ show body
diff --git a/test/Util/Spec.hs b/test/Util/Spec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9ce6f8de4f85163cc5e050c03511d95aac801083
--- /dev/null
+++ b/test/Util/Spec.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.Spec
+ ( wrongMethodNotAllowed
+ , nonJSONUnsupportedMediaType
+ , wrongJSONInvalidRequest
+ ) where
+
+import Test.Hspec
+ ( it
+ )
+import Test.Hspec.Wai
+ ( post
+ , request
+ , shouldRespondWith
+ )
+
+import Util.WAI
+ ( postJSON
+ )
+
+wrongMethodNotAllowed method path =
+ it "responds to an unsupported method with 405 (Method Not Allowed)" $
+ request method path [] "" `shouldRespondWith` 405
+
+nonJSONUnsupportedMediaType path =
+ it "responds to non-JSON Content-Type with 415 (Unsupported Media Type)" $
+ post path "xxx" `shouldRespondWith` 415
+
+wrongJSONInvalidRequest path json =
+ it "responds to JSON body representing the wrong data with 400 (Invalid Request)" $
+ postJSON path json `shouldRespondWith` 400