diff --git a/.circleci/config.yml b/.circleci/config.yml index a51cbb601c07a94bb57b4561a89cb9df64a47795..dd2666b3265e1386ac519609de76357d4747d81c 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -93,8 +93,8 @@ jobs: # the cache was written (but usually it will have). name: "Restore Cached Dependencies" keys: - - paymentserver-v1-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }} - - paymentserver-v1-{{ checksum "stack.yaml" }} + - paymentserver-v2-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }} + - paymentserver-v2-{{ checksum "stack.yaml" }} - run: # Build just our dependencies. It's nice to have this as a separate @@ -124,7 +124,7 @@ jobs: # way we get to save the cache whether or not the test suite goes on # to succeed. name: "Cache Dependencies" - key: paymentserver-v1-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }} + key: paymentserver-v2-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }} paths: - "/root/.stack" - ".stack-work" diff --git a/PaymentServer.cabal b/PaymentServer.cabal index 6359ffb5741e451e2760100e14bb5b664da572ed..b6cd94e9b7bb2c86a72be8778c7f1c385d2ae295 100644 --- a/PaymentServer.cabal +++ b/PaymentServer.cabal @@ -25,6 +25,7 @@ library build-depends: base >= 4.7 && < 5 , optparse-applicative , aeson + , bytestring , servant , servant-server , wai @@ -32,6 +33,7 @@ library , data-default , warp , warp-tls + , stripe-haskell , stripe-core , text , containers diff --git a/nix/PaymentServer.nix b/nix/PaymentServer.nix index 22159bab9cb2dadd50423387e70bff877a56d15c..b70939de79fd499051ef4b007e3704067d81e9c1 100644 --- a/nix/PaymentServer.nix +++ b/nix/PaymentServer.nix @@ -57,6 +57,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }: "library" = { depends = [ (hsPkgs."base" or (buildDepError "base")) + (hsPkgs."bytestring" or (buildDepError "bytestring")) (hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative")) (hsPkgs."aeson" or (buildDepError "aeson")) (hsPkgs."servant" or (buildDepError "servant")) @@ -67,6 +68,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }: (hsPkgs."warp" or (buildDepError "warp")) (hsPkgs."warp-tls" or (buildDepError "warp-tls")) (hsPkgs."stripe-core" or (buildDepError "stripe-core")) + (hsPkgs."stripe-haskell" or (buildDepError "stripe-haskell")) (hsPkgs."text" or (buildDepError "text")) (hsPkgs."containers" or (buildDepError "containers")) (hsPkgs."cryptonite" or (buildDepError "cryptonite")) diff --git a/nix/pkgs.nix b/nix/pkgs.nix index 26ae4881edad1f52e936df5fe53ff4d23f3ab841..8997dd1f9c75453787358677081b314ae4262e3a 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -3,6 +3,8 @@ { packages = ({ "stripe-core" = (((hackage.stripe-core)."2.5.0").revisions).default; + "stripe-haskell" = (((hackage.stripe-haskell)."2.5.0").revisions).default; + "stripe-http-client" = (((hackage.stripe-http-client)."2.5.0").revisions).default; } // { PaymentServer = ./PaymentServer.nix; }) // {}; }; resolver = "lts-14.1"; diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs index eb988b7160e691c4db037cefbad0b0f0709a25b7..93ea9eef8a4a2d53e691ea81cef3328e0d24ad7d 100644 --- a/src/PaymentServer/Main.hs +++ b/src/PaymentServer/Main.hs @@ -47,6 +47,9 @@ import PaymentServer.Issuer import PaymentServer.Server ( paymentServerApp ) +import PaymentServer.Processors.Stripe + ( StripeSecretKey + ) import Options.Applicative ( Parser @@ -90,6 +93,7 @@ data ServerConfig = ServerConfig , database :: Database , databasePath :: Maybe Text , endpoint :: Endpoint + , stripeKey :: StripeSecretKey } deriving (Show, Eq) @@ -159,7 +163,9 @@ sample = ServerConfig <> help "Path to on-disk database (sqlite3 only)" <> showDefault ) ) <*> (http <|> https) - + <*> option str + ( long "stripe-key" + <> help "Stripe Secret key" ) opts :: ParserInfo ServerConfig opts = info (sample <**> helper) @@ -221,6 +227,7 @@ getApp config = exitFailure Right getDB -> do db <- getDB - let app = paymentServerApp issuer db + let key = stripeKey config + let app = paymentServerApp 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 3aa84a6eea156bc01e442cacaf67170f8a46da0a..36cc53519cdda3ad4b1b08717efedad7a1f66811 100644 --- a/src/PaymentServer/Processors/Stripe.hs +++ b/src/PaymentServer/Processors/Stripe.hs @@ -6,30 +6,49 @@ module PaymentServer.Processors.Stripe ( StripeAPI , stripeServer , getVoucher + , StripeSecretKey ) where import Control.Monad.IO.Class ( liftIO ) -import Text.Printf - ( printf +import Control.Monad + ( mzero + ) +import Data.ByteString + ( ByteString + ) +import Data.Text + ( Text + , unpack + ) +import Text.Read + ( readMaybe ) import Data.Aeson ( ToJSON(toJSON) + , FromJSON(parseJSON) + , Value(Object) , object + , (.:) ) import Servant ( Server , Handler + , err400 + , err500 + , ServerError(errBody) + , throwError ) import Servant.API ( ReqBody , JSON , Post , (:>) + , (:<|>)((:<|>)) ) import Web.Stripe.Event - ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest) + ( Event(Event, eventId, eventType, eventData) , EventId(EventId) , EventType(ChargeSucceededEvent) , EventData(ChargeEvent) @@ -37,19 +56,40 @@ import Web.Stripe.Event import Web.Stripe.Types ( Charge(Charge, chargeMetaData) , MetaData(MetaData) + , Currency + ) +import Web.Stripe.Error + ( StripeError(StripeError) + ) +import Web.Stripe.Charge + ( createCharge + , Amount(Amount) + , TokenId(TokenId) + ) +import Web.Stripe.Client + ( StripeConfig(StripeConfig) + , StripeKey(StripeKey) + ) +import Web.Stripe + ( stripe + , (-&-) ) import PaymentServer.Persistence ( Voucher , VoucherDatabase(payForVoucher) ) +type StripeSecretKey = ByteString data Acknowledgement = Ok instance ToJSON Acknowledgement where toJSON Ok = object [] -type StripeAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement +type StripeAPI = WebhookAPI + :<|> ChargesAPI + +type WebhookAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement -- | getVoucher finds the metadata item with the key `"Voucher"` and returns -- the corresponding value, or Nothing. @@ -58,12 +98,12 @@ getVoucher (MetaData []) = Nothing getVoucher (MetaData (("Voucher", value):xs)) = Just value getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs) -stripeServer :: VoucherDatabase d => d -> Server StripeAPI -stripeServer = webhook +stripeServer :: VoucherDatabase d => StripeSecretKey -> d -> Server StripeAPI +stripeServer key d = webhook d + :<|> charge d key +-- | Process charge succeeded events webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement - --- Process charge succeeded events webhook d Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, eventData=(ChargeEvent charge)} = case getVoucher $ chargeMetaData charge of Nothing -> @@ -83,3 +123,58 @@ webhook d Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, webhook d _ = -- TODO: Record the eventId somewhere. return Ok + + +-- | 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 + +data Charges = Charges + { token :: Text -- ^ The text of a Stripe tokenized payment method. + , voucher :: Voucher -- ^ The voucher for which this charge will pay. + , amount :: Int -- ^ The amount of the charge in the minimum + -- currency unit of the target currency (eg for + -- USD, cents). + , currency :: Text -- ^ The currency in which the charge will be made. + } deriving (Show, Eq) + +instance FromJSON Charges where + parseJSON (Object v) = Charges <$> + v .: "token" <*> + v .: "voucher" <*> + v .: "amount" <*> + v .: "currency" + parseJSON _ = mzero + +-- | call the stripe Charge API (with token, voucher in metadata, amount, currency etc +-- and if the Charge is okay, then set the voucher as "paid" in the database. +charge :: VoucherDatabase d => d -> StripeSecretKey -> Charges -> Handler Acknowledgement +charge d key (Charges token voucher amount currency) = do + let config = StripeConfig (StripeKey key) Nothing + tokenId = TokenId token + currency' <- getCurrency currency + result <- liftIO $ stripe config $ + createCharge (Amount amount) currency' + -&- tokenId + -&- MetaData [("Voucher", voucher)] + case result of + Right Charge { chargeMetaData = metadata } -> + -- verify that we are getting the same metadata that we sent. + case metadata of + MetaData [("Voucher", v)] -> + if v == voucher + then + do + liftIO $ payForVoucher d voucher + return Ok + else + throwError err500 { errBody = "Voucher code mismatch" } + _ -> throwError err400 { errBody = "Voucher code not found" } + Left StripeError {} -> throwError err400 { errBody = "Stripe charge didn't succeed" } + where + getCurrency :: Text -> Handler Currency + getCurrency maybeCurrency = do + case readMaybe (unpack currency) of + Just currency' -> return currency' + Nothing -> throwError err400 { errBody = "Invalid currency specified" } diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs index 973ef126d9d005873016d075dedff5276796e8b9..1dd455723151a5b922edd42c286721e469f9ae27 100644 --- a/src/PaymentServer/Server.hs +++ b/src/PaymentServer/Server.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module exposes a Servant-based Network.Wai server for payment -- interactions. @@ -17,6 +18,7 @@ import Servant ) import PaymentServer.Processors.Stripe ( StripeAPI + , StripeSecretKey , stripeServer ) import PaymentServer.Redemption @@ -36,9 +38,9 @@ type PaymentServerAPI :<|> "v1" :> "redeem" :> RedemptionAPI -- | Create a server which uses the given database. -paymentServer :: VoucherDatabase d => Issuer -> d -> Server PaymentServerAPI -paymentServer issuer database = - stripeServer database +paymentServer :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Server PaymentServerAPI +paymentServer key issuer database = + stripeServer key database :<|> redemptionServer issuer database paymentServerAPI :: Proxy PaymentServerAPI @@ -46,5 +48,5 @@ paymentServerAPI = Proxy -- | Create a Servant Application which serves the payment server API using -- the given database. -paymentServerApp :: VoucherDatabase d => Issuer -> d -> Application -paymentServerApp issuer = serve paymentServerAPI . paymentServer issuer +paymentServerApp :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Application +paymentServerApp key issuer = serve paymentServerAPI . paymentServer key issuer diff --git a/stack.yaml b/stack.yaml index c4bc68654c595b44ea24ca113b1b2973e7a3ade7..0af84a35031953cbffd353476578ffa00b37b01f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,6 +39,8 @@ packages: # (e.g., acme-missiles-0.3) extra-deps: - "stripe-core-2.5.0" + - "stripe-haskell-2.5.0" + - "stripe-http-client-2.5.0" # Override default flag values for local packages and extra-deps # flags: {}