From: fr33domlover
Before this commit, crowdmatch actions run database queries separately
inside them like a black box. That means in practice many applications
of `runDB`, one per query, so a transaction per query. This is an
unnecessary waste, and doesn't gain much (or anything at all, as this
commit's changes my demonstrate).
So this commit adds `SqlPersistT` on top of the crowdmatch env monad, so
that the actual running of SQL queries is controlled from outside
crowdmatch itself, and allows a single `runDB` to handle a batch of
persistent actions.
Both Snowdrift and the crowdmatch test suite have been updated to make
use of this new capability, which also happens to make the code more
readable (e.g. much much less occurences of `runDB`).
---
crowdmatch/app/CrowdmatchMain.hs | 2 +-
crowdmatch/crowdmatch.cabal| 4 +-
crowdmatch/src/Crowdmatch.hs | 102
crowdmatch/test/main.hs| 136 +
website/src/Handler/Dashboard.hs | 3 +-
website/src/Handler/PaymentInfo.hs | 6 +-
website/src/Handler/Pledge.hs | 11 +--
website/src/Handler/Project.hs | 4 +-
8 files changed, 136 insertions(+), 132 deletions(-)
diff --git a/crowdmatch/app/CrowdmatchMain.hs b/crowdmatch/app/CrowdmatchMain.hs
index 0a48c4a..bb12530 100644
--- a/crowdmatch/app/CrowdmatchMain.hs
+++ b/crowdmatch/app/CrowdmatchMain.hs
@@ -7,4 +7,4 @@ import RunPersist
-- NB! The string passed to runPersistKeter must match the APPNAME used in
-- keter.sh to deploy the app. Must fix.
main :: IO ()
-main = crowdmatch (runPersistKeter "SnowdriftReboot")
+main = runPersistKeter "SnowdriftReboot" crowdmatch
diff --git a/crowdmatch/crowdmatch.cabal b/crowdmatch/crowdmatch.cabal
index bf93327..d9f58c5 100644
--- a/crowdmatch/crowdmatch.cabal
+++ b/crowdmatch/crowdmatch.cabal
@@ -1,5 +1,5 @@
name: crowdmatch
-version: 0.1.0.0
+version: 0.2.0.0
synopsis: Crowdmatch mechanism for Snowdrift.coop
description:
Provides an interface for managing pledges and donations. Includes
@@ -10,7 +10,7 @@ license: AGPL-3
license-file: LICENSE
author: Bryan Richter
maintainer: disc...@lists.snowdrift.coop
-copyright: Bryan Richter and Snowdrift.coop, 2016
+copyright: Bryan Richter and Snowdrift.coop, 2016, 2017
category: Database
build-type: Simple
-- extra-source-files:
diff --git a/crowdmatch/src/Crowdmatch.hs b/crowdmatch/src/Crowdmatch.hs
index b7b8a87..6894afd 100644
--- a/crowdmatch/src/Crowdmatch.hs
+++ b/crowdmatch/src/Crowdmatch.hs
@@ -100,14 +100,13 @@ data Project = Project
-- | Record a 'TokenId' for a patron.
storePaymentToken
-:: (ToCrowdmatchPatron usr, MonadIO io, MonadIO env)
-=> SqlRunner io env
--> StripeRunner
+:: (ToCrowdmatchPatron usr, MonadIO env)
+=> StripeRunner
-> usr -- ^ your model's user, an instance of ToCrowdmatchPatron
-> TokenId -- ^ you must independently get this from stripe
--> env (Either StripeError ())
-storePaymentToken db strp usr =
-runMech db . StorePaymentTokenI strp (usr ^. from external)
+-> SqlPersistT env (Either StripeError ())
+storePaymentToken strp usr =
+runMech . StorePaymentTokenI strp (usr ^. from external)
-- NB: The "-- ^" in the following methods is intentional. It forces
-- Haddocks to reformat the arguments in a pleasing way.
@@ -115,51 +114,45 @@ storePaymentToken db strp usr =
-- | Delete the 'TokenId'. This will remove any existing pledges, since a
-- a token is required for pledging.
deletePaymentToken
-:: (ToCrowdmatchPatron usr, MonadIO io, MonadIO env)
-=> SqlRunner io env -- ^
--> StripeRunner
+:: (ToCrowdmatchPatron usr, MonadIO env)
+=> StripeRunner -- ^
-> usr
--> env (Either StripeError ())
-deletePaymentToken db strp =
-runMech db . DeletePaymentTokenI strp . (^. from external)
+-> SqlPersistT env (Either StripeError ())
+deletePaymentToken strp =
+runMech . DeletePaymentTokenI strp . (^. from external)
-- | Stores a pledge, joining the crowd. Requires the patron to already
-- have a payment token available.
storePledge
-:: (ToCrowdmatchPatron usr, MonadIO io, MonadIO env)
-=> SqlRunner io env -- ^
--> usr
--> env ()
-storePledge db = runMech db . StorePledgeI . (^. from external)
+:: (ToCrowdmatchPatron usr, MonadIO env)
+=> usr -- ^
+-> SqlPersistT env ()
+storePledge = runMech . StorePledgeI . (^. from external)
-- | Delete a pledge, leaving the crowd.
deletePledge
-:: (ToCrowdmatchPatron usr, MonadIO io, MonadIO env)
-=> SqlRunner io env -- ^
--> usr
--> env ()
-deletePledge db = runMech db . DeletePledgeI . (^. from external)
+:: (ToCrowdmatchPatron usr, MonadIO env)
+=> usr -- ^
+-> SqlPersistT env ()
+deletePledge = runMech . DeletePledgeI . (^. from external)
-- | Retrieve info on the project.
fetchProject
-:: (MonadIO io, MonadIO env)
-=> SqlRunner io env -- ^
--> env Project
-fetchProject
