Skeleton.hs 2.11 KB
Newer Older
1 2
{-# LANGUAGE TypeFamilies #-}

3 4 5 6 7 8 9 10 11 12 13
-- | This is the closet, where we keep the skeletons.
--
-- Esqueleto produces the most wicked type errors when things go awry.
-- Spooky! But given the alternatives of using rawSql (and thus losing the
-- best of type safety when building sql), or using plain ol' persistent
-- and doing all the relational logic in Haskell (how depressing), I will
-- reluctantly stick with Esqueleto. Its use will merely be sequestered
-- in this module (alternate name: Model.Sequestro!)
module Crowdmatch.Skeleton where

import Control.Error hiding (isNothing)
Bryan Richter's avatar
Bryan Richter committed
14
import Control.Lens ((%~), _1, _2)
Bryan Richter's avatar
Bryan Richter committed
15
import Control.Monad.IO.Class (MonadIO)
16 17 18 19 20 21
import Database.Esqueleto

import Crowdmatch.Model

{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-}

22
-- | Retrieve the history of donations to the project
23
projectDonationHistory :: MonadIO m => SqlPersistT m [(HistoryTime, Int)]
24 25 26 27 28 29 30 31 32 33
projectDonationHistory =
    fmap (map ((_1 %~ unValue) . (_2 %~ fromMaybe 0 . unValue))) $
    select $
    from $ \dh -> do
        groupBy (time dh)
        orderBy [asc (time dh)]
        pure (time dh, total dh)
  where
    time = (^. DonationHistoryTime)
    total = sum_ . (^. DonationHistoryAmount)
34 35 36 37 38 39 40 41

-- | Patrons actively pledged to Snowdrift
activePatrons :: MonadIO m => SqlPersistT m [Entity Patron]
activePatrons =
    select $
    from $ \p -> do
        where_ (activePatron p)
        return p
Bryan Richter's avatar
Bryan Richter committed
42 43
  where
    activePatron = not_ . isNothing . (^. PatronPledgeSince)
Bryan Richter's avatar
Bryan Richter committed
44 45 46

-- | Patrons with outstanding donation balances.
patronsReceivable :: MonadIO m => DonationUnits -> SqlPersistT m [Entity Patron]
Bryan Richter's avatar
Bryan Richter committed
47
patronsReceivable minBal =
Bryan Richter's avatar
Bryan Richter committed
48 49 50
    select $
    from $ \p -> do
        where_ (not_ (isNothing (p ^. PatronPaymentToken))
Bryan Richter's avatar
Bryan Richter committed
51
            &&. (p ^. PatronDonationPayable >=. val minBal))
Bryan Richter's avatar
Bryan Richter committed
52
        return p
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

sumField
  :: ( PersistEntityBackend val ~ SqlBackend
     , PersistEntity val
     , PersistField a
     , Num a
     , MonadIO m
     )
     => EntityField val a
     -> SqlPersistT m a
sumField f = do
    [row] <-
        select $
        from $ \entity ->
            return $ coalesceDefault [sum_ (entity ^. f)] $ val 0
    return $ unValue row