Using incomes to compute a fair computation to designate the payer

10 files changed, 161 insertions, 43 deletions

diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index f38379a..8d1da25 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -57,6 +57,7 @@ Income
   userId UserId
   creation UTCTime
   amount Int
+  deriving Show
 |]
 
 type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index edf1c92..70b9149 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -1,5 +1,7 @@
 module Model.Income
   ( getIncome
+  , getFirstIncome
+  , getIncomes
   , setIncome
   ) where
 
@@ -15,6 +17,13 @@ getIncome :: UserId -> Persist (Maybe Income)
 getIncome userId =
   fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation]
 
+getIncomes :: Persist [Income]
+getIncomes = map entityVal <$> selectList [] []
+
+getFirstIncome :: UserId -> Persist (Maybe Income)
+getFirstIncome userId =
+  fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Asc IncomeCreation]
+
 setIncome :: UserId -> Int -> Persist IncomeId
 setIncome userId amount = do
   now <- liftIO getCurrentTime
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
new file mode 100644
index 0000000..4549ca5
--- /dev/null
+++ b/src/server/Model/Json/Income.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Income
+  ( Income(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Time.Clock (UTCTime)
+
+data Income = Income
+  { creation :: UTCTime
+  , amount :: Int
+  } deriving (Show, Generic)
+
+instance FromJSON Income
+instance ToJSON Income
diff --git a/src/server/Model/Json/Payer.hs b/src/server/Model/Json/Payer.hs
new file mode 100644
index 0000000..2101e40
--- /dev/null
+++ b/src/server/Model/Json/Payer.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Payer
+  ( Payer(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+
+import Model.Database (UserId)
+import Model.Json.Income
+
+data Payer = Payer
+  { userId :: UserId
+  , preIncomePaymentSum :: Int
+  , postIncomePaymentSum :: Int
+  , incomes :: [Income]
+  } deriving (Show, Generic)
+
+instance FromJSON Payer
+instance ToJSON Payer
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
deleted file mode 100644
index 2b1cd06..0000000
--- a/src/server/Model/Json/TotalPayment.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.TotalPayment
-  ( TotalPayment(..)
-  ) where
-
-import GHC.Generics
-
-import Data.Aeson
-
-import Model.Database (UserId)
-
-data TotalPayment = TotalPayment
-  { userId :: UserId
-  , totalPayment :: Int
-  } deriving (Show, Generic)
-
-instance FromJSON TotalPayment
-instance ToJSON TotalPayment
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index a5de110..f594833 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -154,7 +154,7 @@ m l September =
 m l October =
   case l of
     English -> "October"
-    French  -> "Octoble"
+    French  -> "Octobre"
 
 m l November =
   case l of
@@ -233,9 +233,8 @@ m l Monthly =
 m l SingularMonthlyCount =
   T.concat
     [ case l of
-        English -> "{1} monthly payment of {2} "
-        French  -> "{1} paiement mensuel de {2} "
-    , m l MoneySymbol
+        English -> "{1} monthly payment of {2}"
+        French  -> "{1} paiement mensuel de {2}"
     ]
 
 m l PluralMonthlyCount =
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)
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
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 25b1bb7..233cafa 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -4,13 +4,11 @@ module Model.Payment
   , getMonthlyPayments
   , createPayment
   , deleteOwnPayment
-  , getTotalPayments
   , getPaymentsCount
   ) where
 
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
-import Data.Maybe (catMaybes)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -22,7 +20,6 @@ import qualified Database.Esqueleto as E
 import Model.Database
 import Model.Frequency
 import qualified Model.Json.Payment as P
-import qualified Model.Json.TotalPayment as TP
 
 getPunctualPayments :: Int -> Int -> Persist [P.Payment]
 getPunctualPayments page perPage = do
@@ -80,23 +77,6 @@ deleteOwnPayment user paymentId = do
     Nothing ->
       return False
 
-getTotalPayments :: Persist [TP.TotalPayment]
-getTotalPayments = do
-  values <- select $
-            from $ \payment -> do
-              where_ (isNothing (payment ^. PaymentDeletedAt))
-              where_ (payment ^. PaymentFrequency E.==. val Punctual)
-              groupBy (payment ^. PaymentUserId)
-              return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
-  return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
-
-getTotalPayment :: (UserId, Maybe Int) -> Maybe TP.TotalPayment
-getTotalPayment (userId, Just cost) = Just (TP.TotalPayment userId cost)
-getTotalPayment (_, Nothing) = Nothing
-
-unValueTuple :: (Value a, Value b) -> (a, b)
-unValueTuple (Value a, Value b) = (a, b)
-
 getPaymentsCount :: Persist Int
 getPaymentsCount =
   unValue . head <$>