From: fr33domlover <fr33domlo...@riseup.net>
This is a new version of the patch, it uses runStripe in appStripe. It
avoids the StripeClient mess but still has a type error due to
StripeRunner being having the 'forall io' thing. The errors can be fixed
using type annotations probably, but using those in every single place
'snowstripe' is used would be ridiculous.
Honestly idk much about Rank N types. I read about it and did some web
search. And I still don't understand how to properly fix this type error
thing. I think the error is simpler now but idk how to *elegantly* fix it.
---
crowdmatch/crowdmatch.cabal | 3 ++-
crowdmatch/src/Crowdmatch.hs | 7 +++++++
website/src/AppDataTypes.hs | 8 ++++----
website/src/Application.hs | 7 ++-----
website/src/Handler/PaymentInfo.hs | 11 ++---------
website/src/Handler/Util.hs | 9 +++++----
6 files changed, 22 insertions(+), 23 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..a857c2a 100644
--- a/crowdmatch/src/Crowdmatch.hs
+++ b/crowdmatch/src/Crowdmatch.hs
@@ -58,10 +58,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 +75,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 +90,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.
diff --git a/website/src/AppDataTypes.hs b/website/src/AppDataTypes.hs
index 39ea400..50d2526 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,9 @@ 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 :: StripeConfig
+ -> forall a. StripeI a
+ -> HandlerT App IO (Either StripeError a)
}
-- This function generates the route types, and also generates the
diff --git a/website/src/Application.hs b/website/src/Application.hs
index 761d3f8..b6b20db 100644
--- a/website/src/Application.hs
+++ b/website/src/Application.hs
@@ -33,6 +33,7 @@ import Web.Stripe
import Web.Stripe.Error
import qualified Yesod.GitRev as G
+import Crowdmatch
import Handler
import Handler.Dashboard
import Handler.Discourse
@@ -61,11 +62,7 @@ makeFoundation appSettings = do
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
- let appStripe :: (Typeable (StripeReturn a), FromJSON (StripeReturn a))
- => StripeConfig
- -> StripeRequest a
- -> IO (Either StripeError (StripeReturn a))
- appStripe = stripe
+ let appStripe = runStripe
let appAuth = AuthSite
-- We need a log function to create a connection pool. We need a connection
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..11de8aa 100644
--- a/website/src/Handler/Util.hs
+++ b/website/src/Handler/Util.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
module Handler.Util
( snowdriftTitle
, snowdriftDashTitle
@@ -25,10 +27,9 @@ snowdriftDashTitle x y = snowdriftTitle $ x `mappend` " — "
`mappend` y
snowstripe :: StripeI a -> Handler (Either StripeError a)
snowstripe req = do
- conf <- fmap
- (StripeConfig . appStripeSecretKey . appSettings)
- getYesod
- liftIO (runStripe conf req)
+ conf <- getsYesod $ StripeConfig . appStripeSecretKey . appSettings
+ runner <- getsYesod appStripe
+ runner 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
