diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 941d4c245cc13a5b6f9a76aaaccf75cf2a405122..ad66ee0d9996434a36b3747aa1f1a48b5cc91e38 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -53,6 +53,7 @@ import Options.Applicative
, ParserInfo
, strOption
, option
+ , many
, auto
, str
, optional
@@ -87,12 +88,13 @@ data Database =
deriving (Show, Eq, Ord, Read)
data ServerConfig = ServerConfig
- { issuer :: Issuer
- , signingKeyPath :: Maybe FilePath
- , database :: Database
- , databasePath :: Maybe Text
- , endpoint :: Endpoint
- , stripeKeyPath :: FilePath
+ { issuer :: Issuer
+ , signingKeyPath :: Maybe FilePath
+ , database :: Database
+ , databasePath :: Maybe Text
+ , endpoint :: Endpoint
+ , stripeKeyPath :: FilePath
+ , allowedChargeOrigins :: [Text]
}
deriving (Show, Eq)
@@ -165,6 +167,13 @@ sample = ServerConfig
<*> option str
( long "stripe-key-path"
<> help "Path to Stripe Secret key" )
+ <*> many
+ ( option str
+ ( long "allow-origin"
+ <> help "For the charge endpoint, a CORS origin to allow."
+ <> showDefault
+ )
+ )
opts :: ParserInfo ServerConfig
opts = info (sample <**> helper)
@@ -230,6 +239,6 @@ getApp config =
Right getDB -> do
db <- getDB
key <- B.readFile (stripeKeyPath config)
- let app = paymentServerApp key issuer db
+ let app = paymentServerApp (allowedChargeOrigins config) key issuer db
logger <- mkRequestLogger (def { outputFormat = Detailed True})
return $ logger app
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 57137eda62fd1e9437607a15f47546f93b1cb603..004bf367d14e08ced6715dc3e25d4d835d9e6b15 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -7,6 +7,7 @@ module PaymentServer.Processors.Stripe
, stripeServer
, getVoucher
, StripeSecretKey
+ , Origin
) where
import Control.Monad.IO.Class
@@ -39,11 +40,21 @@ import Servant
, err500
, ServerError(errBody)
, throwError
+ , NoContent(NoContent)
+ , Headers
+ , Header
+ , Header'
+ , Required
+ , Strict
+ , addHeader
+ , noHeader
)
import Servant.API
( ReqBody
+ , StdMethod(OPTIONS)
, JSON
, Post
+ , Verb
, (:>)
, (:<|>)((:<|>))
)
@@ -79,6 +90,14 @@ import PaymentServer.Persistence
, VoucherDatabase(payForVoucher)
)
+-- | The type of an origin value in the context of HTTP / CORS.
+type Origin = Text
+
+-- | OPTIONS is a standard HTTP/1.1 verb and it is used by the CORS mechanism
+-- to exchange information about what cross-origin requests should be allowed.
+-- Here we define it as a verb for use later in the type of our server.
+type Options = Verb 'OPTIONS 204
+
type StripeSecretKey = ByteString
data Acknowledgement = Ok
@@ -98,9 +117,48 @@ getVoucher (MetaData []) = Nothing
getVoucher (MetaData (("Voucher", value):xs)) = Just value
getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs)
-stripeServer :: VoucherDatabase d => StripeSecretKey -> d -> Server StripeAPI
-stripeServer key d = webhook d
- :<|> charge d key
+-- | stripeServer serves responses to the Stripe portion of the API defined in
+-- this module.
+stripeServer
+ :: VoucherDatabase d
+ => [Origin] -- ^ A list of origins which are allowed to use the
+ -- charge endpoint.
+ -> StripeSecretKey
+ -> d
+ -> Server StripeAPI
+stripeServer allowedChargeOrigins key d =
+ webhook d
+ :<|> charge d key
+ :<|> cors allowedChargeOrigins
+
+-- | Respond to a CORS OPTIONS preflight request for the charge endpoint in
+-- such a way as to allow some cross-origin POSTs to that endpoint. This is a
+-- partial implementation of the CORS rules only.
+cors
+ :: [Origin] -- ^ A list of origins which are allowed to use the
+ -- charge endpoint.
+ -> Origin -- ^ The value of the Origin header in the request,
+ -- for comparison against the allowed origins.
+ -> Handler CORSResponse
+cors allowedOrigins requestOrigin =
+ let
+ addHeaders =
+ if any (== requestOrigin) allowedOrigins then
+ -- The origin is allowed. Return the rest of the information.
+ addHeader requestOrigin
+ . addHeader "OPTIONS, POST"
+ . addHeader "Content-Type"
+ . addHeader (60 * 60 * 24)
+ else
+ -- The origin is not allowed. Per
+ -- <https://www.w3.org/TR/2014/REC-cors-20140116/#resource-preflight-requests>,
+ -- section 6.2, rule 2, add no further CORS headers to the response.
+ noHeader
+ . noHeader
+ . noHeader
+ . noHeader
+ in
+ return $ addHeaders $ addHeader "Origin" NoContent
-- | Process charge succeeded events
webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement
@@ -125,10 +183,24 @@ webhook d _ =
return Ok
+-- | The type of the response to a CORS OPTIONS preflight request. It would
+-- be nice to use more expressive types than Text for some of these.
+type CORSResponse = Headers
+ '[ Header "Access-Control-Allow-Origin" Text
+ , Header "Access-Control-Allow-Methods" Text
+ , Header "Access-Control-Allow-Headers" Text
+ , Header "Access-Control-Max-Age" Int
+ , Header "Vary" Text
+ ]
+ NoContent
+
+
-- | Browser facing API that takes token, voucher and a few other information
-- and calls stripe charges API. If payment succeeds, then the voucher is stored
-- in the voucher database.
-type ChargesAPI = "charge" :> ReqBody '[JSON] Charges :> Post '[JSON] Acknowledgement
+type ChargesAPI = "charge" :> (CreateChargeAPI :<|> CORSPreflight)
+type CreateChargeAPI = ReqBody '[JSON] Charges :> Post '[JSON] Acknowledgement
+type CORSPreflight = Header' '[Required, Strict] "Origin" Text :> Options '[JSON] CORSResponse
data Charges = Charges
{ token :: Text -- ^ The text of a Stripe tokenized payment method.
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index feef0b051330a58568fa88ded64667b74719049a..e6ff9d9b21fac611e41f0e791f12766c879ea888 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -16,7 +16,8 @@ import Servant
, (:<|>)((:<|>))
)
import PaymentServer.Processors.Stripe
- ( StripeAPI
+ ( Origin
+ , StripeAPI
, StripeSecretKey
, stripeServer
)
@@ -37,9 +38,15 @@ type PaymentServerAPI
:<|> "v1" :> "redeem" :> RedemptionAPI
-- | Create a server which uses the given database.
-paymentServer :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Server PaymentServerAPI
-paymentServer key issuer database =
- stripeServer key database
+paymentServer
+ :: VoucherDatabase d
+ => [Origin]
+ -> StripeSecretKey
+ -> Issuer
+ -> d
+ -> Server PaymentServerAPI
+paymentServer allowedChargeOrigins key issuer database =
+ stripeServer allowedChargeOrigins key database
:<|> redemptionServer issuer database
paymentServerAPI :: Proxy PaymentServerAPI
@@ -47,5 +54,11 @@ paymentServerAPI = Proxy
-- | Create a Servant Application which serves the payment server API using
-- the given database.
-paymentServerApp :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Application
-paymentServerApp key issuer = serve paymentServerAPI . paymentServer key issuer
+paymentServerApp
+ :: VoucherDatabase d
+ => [Origin]
+ -> StripeSecretKey
+ -> Issuer
+ -> d
+ -> Application
+paymentServerApp allowedChargeOrigins key issuer = serve paymentServerAPI . paymentServer allowedChargeOrigins key issuer