From 8c24464a4bd0a486cd0ddf846d3b5a323a7aaa9a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 4 Oct 2015 20:48:32 +0200 Subject: Using incomes to compute a fair computation to designate the payer --- src/server/Model/Database.hs | 1 + src/server/Model/Income.hs | 9 +++++++ src/server/Model/Json/Income.hs | 18 +++++++++++++ src/server/Model/Json/Payer.hs | 22 +++++++++++++++ src/server/Model/Json/TotalPayment.hs | 19 ------------- src/server/Model/Message/Translations.hs | 7 +++-- src/server/Model/Payer.hs | 46 ++++++++++++++++++++++++++++++++ src/server/Model/Payer/Income.hs | 22 +++++++++++++++ src/server/Model/Payer/Payment.hs | 40 +++++++++++++++++++++++++++ src/server/Model/Payment.hs | 20 -------------- 10 files changed, 161 insertions(+), 43 deletions(-) create mode 100644 src/server/Model/Json/Income.hs create mode 100644 src/server/Model/Json/Payer.hs delete mode 100644 src/server/Model/Json/TotalPayment.hs create mode 100644 src/server/Model/Payer.hs create mode 100644 src/server/Model/Payer/Income.hs create mode 100644 src/server/Model/Payer/Payment.hs (limited to 'src/server/Model') 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 <$> -- cgit v1.2.3