Using incomes to compute a fair computation to designate the payer

2 files changed, 62 insertions, 0 deletions

diff --git a/src/server/Model/Payer/Income.hs b/src/server/Model/Payer/Income.hs
new file mode 100644
index 0000000..f4bc9fd
--- /dev/null
+++ b/src/server/Model/Payer/Income.hs
@@ -0,0 +1,22 @@
+module Model.Payer.Income
+  ( incomeDefinedForAll
+  ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.List (sort)
+import Data.Maybe
+
+import Database.Persist
+
+import Model.Database
+import Model.User (getUsers)
+import Model.Income (getFirstIncome)
+
+incomeDefinedForAll :: Persist (Maybe UTCTime)
+incomeDefinedForAll = do
+  userIds <- map entityKey <$> getUsers
+  firstIncomes <- mapM getFirstIncome userIds
+  return $
+    if all isJust firstIncomes
+      then listToMaybe . reverse . sort . map incomeCreation . catMaybes $ firstIncomes
+      else Nothing
diff --git a/src/server/Model/Payer/Payment.hs b/src/server/Model/Payer/Payment.hs
new file mode 100644
index 0000000..6efc38d
--- /dev/null
+++ b/src/server/Model/Payer/Payment.hs
@@ -0,0 +1,40 @@
+module Model.Payer.Payment
+  ( getTotalPaymentsBefore
+  , getTotalPaymentsAfter
+  ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.Maybe (catMaybes)
+
+import Database.Persist
+import Database.Esqueleto
+import qualified Database.Esqueleto as E
+
+import Model.Database
+import Model.Frequency
+
+getTotalPaymentsBefore :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsBefore time =
+  getTotalPayments (\p -> p ^. PaymentCreation E.<. val time)
+
+getTotalPaymentsAfter :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsAfter time =
+  getTotalPayments (\p -> p ^. PaymentCreation E.>=. val time)
+
+getTotalPayments :: (SqlExpr (Entity Payment) -> SqlExpr (Value Bool)) -> Persist [(UserId, Int)]
+getTotalPayments paymentWhere = do
+  values <- select $
+            from $ \payment -> do
+              where_ (isNothing (payment ^. PaymentDeletedAt))
+              where_ (payment ^. PaymentFrequency E.==. val Punctual)
+              where_ (paymentWhere payment)
+              groupBy (payment ^. PaymentUserId)
+              return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
+  return $ catMaybes . map (unMaybe . unValueTuple) $ values
+
+unValueTuple :: (Value a, Value b) -> (a, b)
+unValueTuple (Value a, Value b) = (a, b)
+
+unMaybe :: (a, Maybe b) -> Maybe (a, b)
+unMaybe (a, Just b) = Just (a, b)
+unMaybe _ = Nothing