From: fr33domlover <fr33domlo...@riseup.net>

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 db = runMech db FetchProjectI
+    :: MonadIO env
+    => SqlPersistT env Project
+fetchProject = runMech FetchProjectI
 
 -- | Retrieve info on a particular patron.
 fetchPatron
-    :: (ToCrowdmatchPatron usr, MonadIO io, MonadIO env)
-    => SqlRunner io env -- ^
-    -> usr
-    -> env Patron
-fetchPatron db = runMech db . FetchPatronI . (^. from external)
+    :: (ToCrowdmatchPatron usr, MonadIO env)
+    => usr -- ^
+    -> SqlPersistT env Patron
+fetchPatron = runMech . FetchPatronI . (^. from external)
 
 crowdmatch
-    :: (MonadIO io, MonadIO env)
-    => SqlRunner io env -- ^
-    -> env ()
-crowdmatch db = runMech db CrowdmatchI
+    :: MonadIO env
+    => SqlPersistT env ()
+crowdmatch = runMech CrowdmatchI
 
 --
 -- ONE LEVEL DOWN
@@ -184,16 +177,14 @@ data CrowdmatchI return where
     CrowdmatchI :: CrowdmatchI ()
 
 -- | Executing the actions
-runMech
-    :: (MonadIO env, MonadIO io)
-    => SqlRunner io env -> CrowdmatchI return -> env return
+runMech :: MonadIO env => CrowdmatchI return -> SqlPersistT env return
 
 --
 -- Payment token (store/delete)
 --
 
-runMech db (StorePaymentTokenI strp pptr cardToken) = do
-    Entity pid p <- db (upsertPatron pptr [])
+runMech (StorePaymentTokenI strp pptr cardToken) = do
+    Entity pid p <- upsertPatron pptr []
     runExceptT $ do
         ret <- ExceptT $ maybe create' update' (Model.patronPaymentToken p)
         ExceptT (Right <$> updatePatron' pid ret)
@@ -203,13 +194,12 @@ runMech db (StorePaymentTokenI strp pptr cardToken) = do
     updatePatron' pid c = do
         now <- liftIO getCurrentTime
         let payToken = PaymentToken (customerId c)
-        db $ do
-            _ <- insert (PaymentTokenHistory pid (HistoryTime now) Create)
-            update pid [PatronPaymentToken =. Just payToken]
+        _ <- insert (PaymentTokenHistory pid (HistoryTime now) Create)
+        update pid [PatronPaymentToken =. Just payToken]
 
 -- FIXME: Feedback on nonexisting CustomerId.
-runMech db (DeletePaymentTokenI strp pptr) = do
-    Entity pid p <- db (upsertPatron pptr [])
+runMech (DeletePaymentTokenI strp pptr) = do
+    Entity pid p <- upsertPatron pptr []
     maybe (pure (Right ())) (deleteToken' pid) (Model.patronPaymentToken p)
   where
     deleteToken' pid (PaymentToken cust) = do
@@ -219,10 +209,9 @@ runMech db (DeletePaymentTokenI strp pptr) = do
         now <- liftIO getCurrentTime
         -- Must delete pledges if there's no payment method!
         -- Fixme: Duplication of upsert
-        runMech db (DeletePledgeI pptr)
-        db $ do
-            _ <- insert (PaymentTokenHistory pid (HistoryTime now) Delete)
-            update pid [PatronPaymentToken =. Nothing]
+        runMech (DeletePledgeI pptr)
+        _ <- insert (PaymentTokenHistory pid (HistoryTime now) Delete)
+        update pid [PatronPaymentToken =. Nothing]
 
 --
 -- Pledge (store/delete)
@@ -230,13 +219,13 @@ runMech db (DeletePaymentTokenI strp pptr) = do
 
 -- FIXME: Feedback on missing payment info
 -- FIXME: Feedback on existing pledges
-runMech db (StorePledgeI pptr) = do
-    Entity pid p <- db (upsertPatron pptr [])
+runMech (StorePledgeI pptr) = do
+    Entity pid p <- upsertPatron pptr []
     maybe noCustomer (checkpledge pid) (pure p <* Model.patronPaymentToken p)
   where
     checkpledge pid p =
         maybe (pledge' pid) existingPledge (Model.patronPledgeSince p)
-    pledge' pid = db $ do
+    pledge' pid = do
         now <- liftIO getCurrentTime
         update pid [PatronPledgeSince =. Just now]
         insert_ (PledgeHistory pid now Create)
@@ -244,7 +233,7 @@ runMech db (StorePledgeI pptr) = do
     existingPledge _ = pure ()
 
 -- FIXME: Feedback on nonexistent pledge.
-runMech db (DeletePledgeI pptr) = db $ do
+runMech (DeletePledgeI pptr) = do
     -- In the absence of triggers or other database use sophistication, we
     -- fetch/evaluate/modify here.
     Entity pid p <- upsertPatron pptr []
@@ -256,7 +245,7 @@ runMech db (DeletePledgeI pptr) = db $ do
         update pid [PatronPledgeSince =. Nothing]
         insert_ (PledgeHistory pid now Delete)
 
-runMech db FetchProjectI = db $ do
+runMech FetchProjectI = do
     numPledges <- count [PatronPledgeSince !=. Nothing]
     -- Persistent terrible SQL :|
     receivable <-
@@ -267,10 +256,9 @@ runMech db FetchProjectI = db $ do
         income = view donationCents (pledgevalue * pledgevalue)
     pure (Project numPledges income pledgevalue receivable)
 
-runMech db (FetchPatronI pptr) =
-    db $ fromModel . entityVal <$> upsertPatron pptr []
+runMech (FetchPatronI pptr) = fromModel . entityVal <$> upsertPatron pptr []
 
-runMech db CrowdmatchI = db $ do
+runMech CrowdmatchI = do
     active <- Skeleton.activePatrons
     let projectValue = fromIntegral (length active)
     today <- utctDay <$> liftIO getCurrentTime
diff --git a/crowdmatch/test/main.hs b/crowdmatch/test/main.hs
index 45f02f3..cffab33 100644
--- a/crowdmatch/test/main.hs
+++ b/crowdmatch/test/main.hs
@@ -104,10 +104,11 @@ genHistory runner = do
             , (2, storePledge' x)
             , (1, delPledge' x)
             ])
-    storeToken' x = void . storePaymentToken runner dummyStripe x <$> arbitrary
-    delToken' = pure . void . deletePaymentToken runner dummyStripe
-    storePledge' = pure . storePledge runner
-    delPledge' = pure . deletePledge runner
+    storeToken' x =
+        void . runner . storePaymentToken dummyStripe x <$> arbitrary
+    delToken' = pure . void . runner . deletePaymentToken dummyStripe
+    storePledge' = pure . runner . storePledge
+    delPledge' = pure . runner . deletePledge
 
 -- | Something to make a Patron out of
 newtype HarnessUser = HarnessUser Int
@@ -160,100 +161,115 @@ sanityTests runner = describe "sanity tests" $ do
         aelfred = HarnessUser 1
     describe "stored token" $ do
         it "is retrievable" $ do
-            _ <- storePaymentToken runner dummyStripe aelfred cardTok
-            pat <- fetchPatron runner aelfred
+            pat <- runner $ do
+                _ <- storePaymentToken dummyStripe aelfred cardTok
+                fetchPatron aelfred
             patronPaymentToken pat `shouldBe` Just payTok
         it "disappears" $ do
-            _ <- storePaymentToken runner dummyStripe aelfred cardTok
-            _ <- deletePaymentToken runner dummyStripe aelfred
-            pat <- fetchPatron runner aelfred
+            pat <- runner $ do
+                _ <- storePaymentToken dummyStripe aelfred cardTok
+                _ <- deletePaymentToken dummyStripe aelfred
+                fetchPatron aelfred
             patronPaymentToken pat `shouldBe` Nothing
         it "has history recorded" $ do
-            _ <- storePaymentToken runner dummyStripe aelfred cardTok
-            _ <- deletePaymentToken runner dummyStripe aelfred
-            ls <- runner $ map entityVal <$> selectList [] []
+            ls <- runner $ do
+                _ <- storePaymentToken dummyStripe aelfred cardTok
+                _ <- deletePaymentToken dummyStripe aelfred
+                map entityVal <$> selectList [] []
             length ls `shouldBe` 2
             Model.paymentTokenHistoryAction (head ls) `shouldBe` Create
             Model.paymentTokenHistoryAction (last ls) `shouldBe` Delete
     specify "fetchPatron always succeeds" $ do
-        p1 <- fetchPatron runner aelfred
-        p2 <- fetchPatron runner aelfred
+        (p1, p2) <-
+            runner $ (,) <$> fetchPatron aelfred <*> fetchPatron aelfred
         p1 `shouldBe` p2
     specify "stored pledge is retrievable" $ do
-        _ <- storePaymentToken runner dummyStripe aelfred cardTok
-        storePledge runner aelfred
-        pat <- fetchPatron runner aelfred
+        pat <- runner $ do
+            _ <- storePaymentToken dummyStripe aelfred cardTok
+            storePledge aelfred
+            fetchPatron aelfred
         patronPledgeSince pat `shouldNotBe` Nothing
     specify "deleted pledge is retrievable" $ do
-        _ <- storePaymentToken runner dummyStripe aelfred cardTok
-        storePledge runner aelfred
-        deletePledge runner aelfred
-        pat <- fetchPatron runner aelfred
+        pat <- runner $ do
+            _ <- storePaymentToken dummyStripe aelfred cardTok
+            storePledge aelfred
+            deletePledge aelfred
+            fetchPatron aelfred
         patronPledgeSince pat `shouldBe` Nothing
     describe "crowd size" $ do
         it "gets bumped by pledging" $ do
-            _ <- storePaymentToken runner dummyStripe aelfred cardTok
-            storePledge runner aelfred
-            p <- fetchProject runner
+            p <- runner $ do
+                _ <- storePaymentToken dummyStripe aelfred cardTok
+                storePledge aelfred
+                fetchProject
             projectCrowd p `shouldBe` 1
         it "is not affected by a bad pledge" $ do
-            -- No token!
-            storePledge runner aelfred
-            p <- fetchProject runner
+            p <- runner $ do
+                -- No token!
+                storePledge aelfred
+                fetchProject
             projectCrowd p `shouldBe` 0
         it "shrinks with removal of payment token" $ do
-            _ <- storePaymentToken runner dummyStripe aelfred cardTok
-            storePledge runner aelfred
-            p1 <- projectCrowd <$> fetchProject runner
+            p1 <- runner $ do
+                _ <- storePaymentToken dummyStripe aelfred cardTok
+                storePledge aelfred
+                projectCrowd <$> fetchProject
             p1 `shouldBe` 1
-            _ <- deletePaymentToken runner dummyStripe aelfred
-            p2 <- projectCrowd <$> fetchProject runner
+            p2 <- runner $ do
+                _ <- deletePaymentToken dummyStripe aelfred
+                projectCrowd <$> fetchProject
             p2 `shouldBe` 0
     specify "10 pledges = 1 cent" $ do
         let mkPledge i = do
-                _ <- storePaymentToken runner dummyStripe (HarnessUser i) 
cardTok
-                storePledge runner (HarnessUser i)
-        mapM_ mkPledge [1..10]
-        val <- projectPledgeValue <$> fetchProject runner
+                _ <- storePaymentToken dummyStripe (HarnessUser i) cardTok
+                storePledge (HarnessUser i)
+        val <- runner $ do
+            mapM_ mkPledge [1..10]
+            projectPledgeValue <$> fetchProject
         val `shouldBe` view (from donationCents) (Cents 1)
     specify "1000 pledges = $1000 monthly income" $ do
         let mkPledge i = do
-                _ <- storePaymentToken runner dummyStripe (HarnessUser i) 
cardTok
-                storePledge runner (HarnessUser i)
-        mapM_ mkPledge [1..1000]
-        val <- projectMonthlyIncome <$> fetchProject runner
+                _ <- storePaymentToken dummyStripe (HarnessUser i) cardTok
+                storePledge (HarnessUser i)
+        val <- runner $ do
+            mapM_ mkPledge [1..1000]
+            projectMonthlyIncome <$> fetchProject
         val `shouldBe` Cents (100 * 1000)
     describe "crowdmatch event" $ do
         let mkPatron i =
-                void (storePaymentToken runner dummyStripe (HarnessUser i) 
cardTok)
+                void (storePaymentToken dummyStripe (HarnessUser i) cardTok)
             mkPledge i = do
                 mkPatron i
-                storePledge runner (HarnessUser i)
+                storePledge (HarnessUser i)
         -- 1. Two patrons, one active -> 0.01 payable from the patron
         it "only counts active patrons" $ do
-            mkPatron 1
-            mkPledge 2
-            crowdmatch runner
-            val <- projectDonationReceivable <$> fetchProject runner
+            val <- runner $ do
+                mkPatron 1
+                mkPledge 2
+                crowdmatch
+                projectDonationReceivable <$> fetchProject
             val `shouldBe` DonationUnits 1
         it "looks quadratic; 3 patrons = 9 DUs" $ do
-            mapM_ mkPledge [1..3]
-            crowdmatch runner
-            val <- projectDonationReceivable <$> fetchProject runner
+            val <- runner $ do
+                mapM_ mkPledge [1..3]
+                crowdmatch
+                projectDonationReceivable <$> fetchProject
             val `shouldBe` DonationUnits 9
         it "sums over multiple events" $ do
-            mkPatron 1
-            mkPledge 2
-            crowdmatch runner
-            storePledge runner (HarnessUser 1)
-            -- Now 1 is also active
-            crowdmatch runner
-            val <- projectDonationReceivable <$> fetchProject runner
+            val <- runner $ do
+                mkPatron 1
+                mkPledge 2
+                crowdmatch
+                storePledge (HarnessUser 1)
+                -- Now 1 is also active
+                crowdmatch
+                projectDonationReceivable <$> fetchProject
             val `shouldBe` DonationUnits 5
         it "creates history" $ do
-            mkPledge 1
-            crowdmatch runner
-            u :: [Entity Model.CrowdmatchHistory] <- runner $ selectList [] []
+            u :: [Entity Model.CrowdmatchHistory] <- runner $ do
+                mkPledge 1
+                crowdmatch
+                selectList [] []
             length u `shouldBe` 1
 
 propTests :: Runner -> SqlPersistT IO () -> Spec
@@ -297,7 +313,7 @@ prop_randomHistory runner = do
     (creat, remov) <- run $ runner $
         partition ((== Create) . Model.pledgeHistoryAction . entityVal)
             <$> selectList [] []
-    crowd <- projectCrowd <$> fetchProject (run . runner)
+    crowd <- run $ runner $ projectCrowd <$> fetchProject
     monitor (badSize (creat, remov, crowd))
     assert (length creat - length remov == crowd)
 
diff --git a/website/src/Handler/Dashboard.hs b/website/src/Handler/Dashboard.hs
index c4d531d..44f518e 100644
--- a/website/src/Handler/Dashboard.hs
+++ b/website/src/Handler/Dashboard.hs
@@ -10,7 +10,6 @@ import MarkupInstances ()
 getDashboardR :: Handler Html
 getDashboardR = do
     Entity uid _ <- requireAuth
-    patron <- fetchPatron runDB uid
-    project <- fetchProject runDB
+    (patron, project) <- runDB $ (,) <$> fetchPatron uid <*> fetchProject
     (pledgeNoCSRF, _) <- generateFormPost (renderDivsNoLabels pledgeForm)
     $(widget "page/dashboard" "Dashboard")
diff --git a/website/src/Handler/PaymentInfo.hs 
b/website/src/Handler/PaymentInfo.hs
index 41de3b9..80c66b9 100644
--- a/website/src/Handler/PaymentInfo.hs
+++ b/website/src/Handler/PaymentInfo.hs
@@ -25,7 +25,7 @@ paymentForm formId =
 getPaymentInfoR :: Handler Html
 getPaymentInfoR = do
     Entity uid user <- requireAuth
-    patron <- fetchPatron runDB uid
+    patron <- runDB $ fetchPatron uid
     deletePaymentInfoWidget <- fst <$> generateFormPost deletePaymentInfoForm
     publishableKey <-
         fmap
@@ -67,7 +67,7 @@ postPaymentInfoR = handleDelete delFormId deletePaymentInfoR 
$ do
         runFormPost (identifyForm modFormId (paymentForm ""))
     case formResult of
         FormSuccess token -> do
-            stripeRes <- storePaymentToken runDB (runStripe conf) uid token
+            stripeRes <- runDB $ storePaymentToken (runStripe conf) uid token
             case stripeRes of
                 Left e -> stripeError e
                 Right _ -> do
@@ -81,7 +81,7 @@ deletePaymentInfoR :: Handler Html
 deletePaymentInfoR = do
     conf <- stripeConf
     Entity uid User {..} <- requireAuth
-    stripeDeletionHandler =<< deletePaymentToken runDB (runStripe conf) uid
+    stripeDeletionHandler =<< runDB (deletePaymentToken (runStripe conf) uid)
     redirect DashboardR
   where
     stripeDeletionHandler =
diff --git a/website/src/Handler/Pledge.hs b/website/src/Handler/Pledge.hs
index 9eda270..863f842 100644
--- a/website/src/Handler/Pledge.hs
+++ b/website/src/Handler/Pledge.hs
@@ -14,7 +14,7 @@ import Crowdmatch
 postPledgeSnowdriftR :: Handler Html
 postPledgeSnowdriftR = handleDelete' $ do
     Entity uid _ <- requireAuth
-    patron <- fetchPatron runDB uid
+    patron <- runDB $ fetchPatron uid
     maybe
         (do
             alertWarning "Before making a pledge, set up a payment method 
below"
@@ -30,7 +30,7 @@ postPledgeSnowdriftR = handleDelete' $ do
             Your pledge that started on #{show t} is still valid.
         |]
     pledge' uid = do
-        storePledge runDB uid
+        runDB $ storePledge uid
         alertSuccess "You are now pledged!"
     handleDelete' = handleDelete pledgeDeleteFormId deletePledgeSnowdriftR
 
@@ -49,12 +49,13 @@ pledgeForm = mempty
 deletePledgeSnowdriftR :: Handler Html
 deletePledgeSnowdriftR = do
     Entity uid _ <- requireAuth
-    patron <- fetchPatron runDB uid
-    maybe shrugItOff (unpledge' uid) (patronPledgeSince patron)
+    runDB $ do
+        patron <- fetchPatron uid
+        maybe shrugItOff (unpledge' uid) (patronPledgeSince patron)
     redirect SnowdriftProjectR
   where
     shrugItOff = alertInfo "You had no pledge to remove! Carry on. :)"
     unpledge' uid t = do
-        deletePledge runDB uid
+        deletePledge uid
         alertInfo
             [shamlet|Your pledge that started on #{show t} is now removed.|]
diff --git a/website/src/Handler/Project.hs b/website/src/Handler/Project.hs
index e250508..9763cbd 100644
--- a/website/src/Handler/Project.hs
+++ b/website/src/Handler/Project.hs
@@ -11,8 +11,8 @@ import MarkupInstances ()
 getSnowdriftProjectR :: Handler Html
 getSnowdriftProjectR = do
     muid <- fmap entityKey <$> maybeAuth
-    mpatron <- traverse (fetchPatron runDB) muid
-    project <- fetchProject runDB
+    (mpatron, project) <-
+        runDB $ (,) <$> traverse fetchPatron muid <*> fetchProject
     (pledgeNoCSRF, _) <- generateFormPost (renderDivs pledgeForm)
     deletePledgeWidget <-
         maybe (pure "") (const genDeleteWidget) (patronPledgeSince =<< mpatron)
-- 
1.9.1

_______________________________________________
Dev mailing list
Dev@lists.snowdrift.coop
https://lists.snowdrift.coop/mailman/listinfo/dev

Reply via email to