From: fr33domlover <fr33domlo...@riseup.net>
---
crowdmatch/crowdmatch.cabal | 3 ++-
crowdmatch/src/Crowdmatch.hs | 32 +++++++++++++++++++++++---------
website/src/AppDataTypes.hs | 6 ++----
website/src/Handler/PaymentInfo.hs | 11 ++---------
website/src/Handler/Util.hs | 14 ++++++++++----
5 files changed, 39 insertions(+), 27 deletions(-)
diff --git a/crowdmatch/crowdmatch.cabal b/crowdmatch/crowdmatch.cabal
index d378766..2c602f1 100644
--- a/crowdmatch/crowdmatch.cabal
+++ b/crowdmatch/crowdmatch.cabal
@@ -28,7 +28,8 @@ library
hs-source-dirs: src
default-language: Haskell2010
build-depends:
- base >=4.8 && <4.9
+ aeson
+ , base >=4.8 && <4.9
, bytestring >= 0.10.6.0
, errors
, lens
diff --git a/crowdmatch/src/Crowdmatch.hs b/crowdmatch/src/Crowdmatch.hs
index fe61387..ad0489c 100644
--- a/crowdmatch/src/Crowdmatch.hs
+++ b/crowdmatch/src/Crowdmatch.hs
@@ -14,7 +14,9 @@ module Crowdmatch (
, SqlRunner
-- * Interface with stripe
+ , StripeClient
, StripeRunner
+ , runStripeWith
, runStripe
-- * Store/delete payment tokens
@@ -58,10 +60,12 @@ import Control.Error (ExceptT(..), runExceptT, note)
import Control.Lens ((^.), from, view, Iso', iso)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson (FromJSON)
import Data.Function (on)
import Data.Int (Int32)
import Data.Ratio
import Data.Time (UTCTime, getCurrentTime, utctDay)
+import Data.Typeable (Typeable)
import Database.Persist
import Database.Persist.Sql (SqlPersistT)
import System.IO
@@ -73,6 +77,7 @@ import Web.Stripe.Customer
, createCustomer
, deleteCustomer)
import Web.Stripe.Error (StripeError)
+import Web.Stripe.StripeRequest (StripeRequest, StripeReturn)
import Crowdmatch.Model hiding (Patron(..))
import qualified Crowdmatch.Model as Model
@@ -87,6 +92,10 @@ import qualified Crowdmatch.Skeleton as Skeleton
-- | A method that runs 'SqlPersistT' values in your environment.
type SqlRunner io env = forall a. SqlPersistT io a -> env a
+type StripeClient = forall a.
+ (Typeable (StripeReturn a), FromJSON (StripeReturn a)) =>
+ StripeConfig -> StripeRequest a -> IO (Either StripeError (StripeReturn a))
+
-- | A method that runs 'StripeI' instructions in IO. A default that uses
-- 'stripe' is provided by 'runStripe'.
type StripeRunner = forall io.
@@ -441,20 +450,19 @@ data StripeI a where
ChargeCustomerI :: CustomerId -> Cents -> StripeI Charge
BalanceTransactionI :: TransactionId -> StripeI BalanceTransaction
--- | A default stripe runner
-runStripe
+runStripeWith
:: MonadIO io
- => StripeConfig -> StripeI a -> io (Either StripeError a)
-runStripe c = \case
+ => StripeClient -> StripeConfig -> StripeI a -> io (Either StripeError a)
+runStripeWith strp c = \case
CreateCustomerI cardToken ->
- liftIO (stripe c (createCustomer -&- cardToken))
+ liftIO (strp c (createCustomer -&- cardToken))
UpdateCustomerI cardToken cust ->
- liftIO (stripe c (updateCustomer cust -&- cardToken))
+ liftIO (strp c (updateCustomer cust -&- cardToken))
DeleteCustomerI cust ->
- void <$> liftIO (stripe c (deleteCustomer cust))
+ void <$> liftIO (strp c (deleteCustomer cust))
ChargeCustomerI cust cents ->
liftIO
- . stripe c
+ . strp c
. (-&- cust)
-- Supported upstream as of 2016-10-06, but not in our resolver yet
-- . (-&- ExpandParams ["balance_transaction"])
@@ -462,7 +470,13 @@ runStripe c = \case
. view chargeCents
$ cents
BalanceTransactionI transId ->
- liftIO (stripe c (getBalanceTransaction transId))
+ liftIO (strp c (getBalanceTransaction transId))
+
+-- | A default stripe runner
+runStripe
+ :: MonadIO io
+ => StripeConfig -> StripeI a -> io (Either StripeError a)
+runStripe = runStripeWith stripe
--
-- Making payments
diff --git a/website/src/AppDataTypes.hs b/website/src/AppDataTypes.hs
index 39ea400..62428a2 100644
--- a/website/src/AppDataTypes.hs
+++ b/website/src/AppDataTypes.hs
@@ -16,6 +16,7 @@ import Yesod.Core.Types (Logger)
import Yesod.GitRev
import AuthSite
+import Crowdmatch
import Settings
-- | The God-object available to every Handler. This is the site's
@@ -30,10 +31,7 @@ data App = App
, appAuth :: AuthSite
-- | The function for doing stripe API calls. Swapped out for a mock
-- thing in tests.
- , appStripe :: forall a. (Typeable (StripeReturn a), FromJSON
(StripeReturn a))
- => StripeConfig
- -> StripeRequest a
- -> IO (Either StripeError (StripeReturn a))
+ , appStripe :: StripeClient
}
-- This function generates the route types, and also generates the
diff --git a/website/src/Handler/PaymentInfo.hs
b/website/src/Handler/PaymentInfo.hs
index 80c66b9..f17babd 100644
--- a/website/src/Handler/PaymentInfo.hs
+++ b/website/src/Handler/PaymentInfo.hs
@@ -54,20 +54,14 @@ deletePaymentInfoForm :: Form ()
deletePaymentInfoForm =
identifyForm delFormId (renderDivsNoLabels deleteFromPost)
-stripeConf :: Handler StripeConfig
-stripeConf = fmap
- (StripeConfig . appStripeSecretKey . appSettings)
- getYesod
-
postPaymentInfoR :: Handler Html
postPaymentInfoR = handleDelete delFormId deletePaymentInfoR $ do
Entity uid User{..} <- requireAuth
- conf <- stripeConf
((formResult, _), _) <-
runFormPost (identifyForm modFormId (paymentForm ""))
case formResult of
FormSuccess token -> do
- stripeRes <- runDB $ storePaymentToken (runStripe conf) uid token
+ stripeRes <- runDB $ storePaymentToken snowstripe uid token
case stripeRes of
Left e -> stripeError e
Right _ -> do
@@ -79,9 +73,8 @@ postPaymentInfoR = handleDelete delFormId deletePaymentInfoR
$ do
deletePaymentInfoR :: Handler Html
deletePaymentInfoR = do
- conf <- stripeConf
Entity uid User {..} <- requireAuth
- stripeDeletionHandler =<< runDB (deletePaymentToken (runStripe conf) uid)
+ stripeDeletionHandler =<< runDB (deletePaymentToken snowstripe uid)
redirect DashboardR
where
stripeDeletionHandler =
diff --git a/website/src/Handler/Util.hs b/website/src/Handler/Util.hs
index ca100f9..39d0db0 100644
--- a/website/src/Handler/Util.hs
+++ b/website/src/Handler/Util.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
module Handler.Util
( snowdriftTitle
, snowdriftDashTitle
@@ -23,12 +25,16 @@ snowdriftTitle t = setTitle $
snowdriftDashTitle :: MonadWidget m => Text -> Text -> m ()
snowdriftDashTitle x y = snowdriftTitle $ x `mappend` " — " `mappend` y
+stripeConf :: Handler StripeConfig
+stripeConf = fmap
+ (StripeConfig . appStripeSecretKey . appSettings)
+ getYesod
+
snowstripe :: StripeI a -> Handler (Either StripeError a)
snowstripe req = do
- conf <- fmap
- (StripeConfig . appStripeSecretKey . appSettings)
- getYesod
- liftIO (runStripe conf req)
+ conf <- stripeConf
+ client <- getsYesod appStripe
+ liftIO $ runStripeWith client conf req
-- | The form element that can be inserted to handle a delete.
deleteFromPost
--
1.9.1
_______________________________________________
Dev mailing list
Dev@lists.snowdrift.coop
https://lists.snowdrift.coop/mailman/listinfo/dev
