Using incomes to compute a fair computation to designate the payer

1 files changed, 46 insertions, 0 deletions

diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs
new file mode 100644
index 0000000..3893765
--- /dev/null
+++ b/src/server/Model/Payer.hs
@@ -0,0 +1,46 @@
+module Model.Payer
+  ( getPayers
+  )
+  where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (getCurrentTime)
+import Data.List (find)
+import Data.Maybe (fromMaybe, fromMaybe)
+
+import Database.Persist
+
+import Model.Database
+import Model.Payer.Payment (getTotalPaymentsBefore, getTotalPaymentsAfter)
+import Model.Payer.Income (incomeDefinedForAll)
+import Model.User (getUsers)
+import Model.Income (getIncomes)
+
+import qualified Model.Json.Payer as Json
+import qualified Model.Json.Income as Json
+
+getPayers :: Persist [Json.Payer]
+getPayers = do
+  userIds <- map entityKey <$> getUsers
+  incomes <- getIncomes
+  now <- liftIO getCurrentTime
+  incomeIsDefined <- fromMaybe now <$> incomeDefinedForAll
+  preIncomePaymentSums <- getTotalPaymentsBefore incomeIsDefined
+  postIncomePaymentSums <- getTotalPaymentsAfter incomeIsDefined
+  return $ map (getPayer incomes preIncomePaymentSums postIncomePaymentSums) userIds
+
+getPayer :: [Income] -> [(UserId, Int)] -> [(UserId, Int)] -> UserId -> Json.Payer
+getPayer incomes preIncomePaymentSums postIncomePaymentSums userId =
+  Json.Payer
+    { Json.userId = userId
+    , Json.preIncomePaymentSum = findOrDefault userId 0 preIncomePaymentSums
+    , Json.postIncomePaymentSum = findOrDefault userId 0 postIncomePaymentSums
+    , Json.incomes =
+        map (\income -> Json.Income (incomeCreation income) (incomeAmount income))
+        . filter ((==) userId . incomeUserId)
+        $ incomes
+    }
+
+findOrDefault :: (Eq a) => a -> b -> [(a, b)] -> b
+findOrDefault a b = fromMaybe b . fmap snd . find ((==) a . fst)