To whom it may concern: fr33domlover and I know this doesn't compile.. it was submitted for discussion.
Now, on with the discussing:
On Tue, Jul 11, 2017 at 03:57:31AM +0300, fr33domlover wrote:
> 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))
> +
I had lots of pain trying to use (or avoid using) the type signatures
around my mock stripe functions. I have a suspicion that this one, in
particular, is not something we want or need.
> -- | 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
We definitely don't want this. At best, we may want a better name than
'runStripe'. It is intended to be a default StripeI runner that
actually uses the real 'stripe'.
StripeI is already the abstraction -- abstracting over its runner
shouldn't be necessary. (See more comments below, at the definition of
'snowstripe'.)
> 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
I will agree this looks a little nicer, but I'm not sure it's worth fighting
GHC over.
> }
>
> -- 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
Ahhh. Now I remember why the crowdmatch API methods weren't restricted
to SqlPersistT. It was so that 'snowstripe' could be used directly
where '(runStripe conf)' is used in Handlers right now! However, I
think there's an easy fix... I think you can 'lift' a Handler action
to a DB action.
Also, regarding my earlier statement. Snowdrift-the-website just needs
some sort of runner for StripeI actions. It chooses to use 'runStripe'
because it wants to use the real stripe.
Snowdrift's tests use a different runner, dummyStripe. Because it
operates on StripeI directly, it only has to handle the instructions
we actually use (i.e. the data constructors of StripeI). If the tests
used your new runStripeWith, it would either have to be partial, or
handle every upstream Stripe command!
I'm just sort of rambling right now. If you aren't following what I'm
saying, don't worry.. I'll show the code when I get the chance.
>
> -- | The form element that can be inserted to handle a delete.
> deleteFromPost
> --
> 1.9.1
signature.asc
Description: Digital signature
_______________________________________________ Dev mailing list Dev@lists.snowdrift.coop https://lists.snowdrift.coop/mailman/listinfo/dev
