From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- common/common.cabal | 3 - common/src/Common/Message/Translation.hs | 2 +- common/src/Common/Model.hs | 3 - common/src/Common/Model/Payer.hs | 202 ----------------------------- common/src/Common/Model/Payment.hs | 2 + common/src/Common/Model/PaymentCategory.hs | 25 ---- common/src/Common/Model/PaymentPage.hs | 17 ++- common/src/Common/Model/SavedPayment.hs | 17 --- common/src/Common/Util/Text.hs | 1 + 9 files changed, 12 insertions(+), 260 deletions(-) delete mode 100644 common/src/Common/Model/Payer.hs delete mode 100644 common/src/Common/Model/PaymentCategory.hs delete mode 100644 common/src/Common/Model/SavedPayment.hs (limited to 'common') diff --git a/common/common.cabal b/common/common.cabal index 75d6cc8..17a0ee1 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -35,7 +35,6 @@ Library Common.Model.CreatePaymentForm Common.Model.Email Common.Model.Payment - Common.Model.SavedPayment Common.Model.SignInForm Common.Model.User Common.Msg @@ -66,7 +65,5 @@ Library Common.Model.IncomePage Common.Model.Init Common.Model.InitResult - Common.Model.Payer - Common.Model.PaymentCategory Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 25e9f4b..a86a371 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -702,7 +702,7 @@ m l WeeklyReport_Title = m l NotFound_Message = case l of English -> "There is nothing here!" - French -> "Vous vous êtes perdu." + French -> "Il n’y a rien à voir ici." m l NotFound_LinkMessage = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index fdeac36..00d30f6 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -17,11 +17,8 @@ import Common.Model.IncomeHeader as X import Common.Model.IncomePage as X import Common.Model.Init as X import Common.Model.InitResult as X -import Common.Model.Payer as X import Common.Model.Payment as X -import Common.Model.PaymentCategory as X import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X -import Common.Model.SavedPayment as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs deleted file mode 100644 index 39a5788..0000000 --- a/common/src/Common/Model/Payer.hs +++ /dev/null @@ -1,202 +0,0 @@ -module Common.Model.Payer - ( getExceedingPayers - , useIncomesFrom - , cumulativeIncomesSince - ) where - -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time -import Data.Time.Calendar (Day) - -import Common.Model.ExceedingPayer (ExceedingPayer (..)) -import Common.Model.Income (Income (..)) -import Common.Model.Payment (Payment (..)) -import Common.Model.User (User (..), UserId) - -data Payer = Payer - { _payer_userId :: UserId - , _payer_preIncomePayments :: Int - , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _postPaymentPayer_userId :: UserId - , _postPaymentPayer_preIncomePayments :: Int - , _postPaymentPayer_cumulativeIncome :: Int - , _postPaymentPayer_ratio :: Float - } - -getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] -getExceedingPayers currentTime users incomes payments = - let userIds = map _user_id users - payers = getPayers userIds incomes payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - firstPayment = safeHead . List.sort . map _payment_date $ payments - mbSince = useIncomesFrom userIds incomes firstPayment - in case mbSince of - Just since -> - let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day -useIncomesFrom userIds incomes firstPayment = - case (firstPayment, incomeDefinedForAll userIds incomes) of - (Just d1, Just d2) -> Just (max d1 d2) - _ -> Nothing - -dayUTCTime :: Day -> UTCTime -dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) - -getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer] -getPayers userIds incomes payments = - let incomesDefined = incomeDefinedForAll userIds incomes - in flip map userIds (\userId -> Payer - { _payer_userId = userId - , _payer_preIncomePayments = - totalPayments - (\p -> - case incomesDefined of - Just d -> - _payment_date p < d - - Nothing -> - True - ) - userId - payments - , _payer_postIncomePayments = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> _payment_date p >= t - ) - userId - payments - , _payer_incomes = filter ((==) userId . _income_userId) incomes - } - ) - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> _exceedingPayer_amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _exceedingPayer_userId = fst userAmount - , _exceedingPayer_amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _postPaymentPayer_userId = _payer_userId payer - , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) - in postIncomeDiff + _postPaymentPayer_preIncomePayments payer - -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: Day -> [Income] -> [Income] -getOrderedIncomesSince since incomes = - let mbStarterIncome = getIncomeAt since incomes - orderedIncomesSince = filter (\income -> _income_date income >= since) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: Day -> [Income] -> Maybe Income -getIncomeAt day incomes = - case incomes of - [x] -> - if _income_date x < day - then Just $ x { _income_date = day } - else Nothing - x1 : x2 : xs -> - if _income_date x1 < day && _income_date x2 >= day - then Just $ x1 { _income_date = day } - else getIncomeAt day (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = dayUTCTime . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 37a090d..c232fc7 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -10,6 +10,7 @@ import Data.Time (UTCTime) import Data.Time.Calendar (Day) import GHC.Generics (Generic) +import Common.Model.Category (CategoryId) import Common.Model.Frequency import Common.Model.User (UserId) @@ -21,6 +22,7 @@ data Payment = Payment , _payment_name :: Text , _payment_cost :: Int , _payment_date :: Day + , _payment_category :: CategoryId , _payment_frequency :: Frequency , _payment_createdAt :: UTCTime , _payment_editedAt :: Maybe UTCTime diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs deleted file mode 100644 index 2a559ce..0000000 --- a/common/src/Common/Model/PaymentCategory.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 76c7511..3b18bb6 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -2,18 +2,17 @@ module Common.Model.PaymentPage ( PaymentPage(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.PaymentHeader (PaymentHeader) +import Common.Model.Payment (Payment) +import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage - { _paymentPage_header :: PaymentHeader - , _paymentPage_payments :: [Payment] - , _paymentPage_paymentCategories :: [PaymentCategory] - , _paymentPage_totalCount :: Int + { _paymentPage_page :: Int + , _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] + , _paymentPage_totalCount :: Int } deriving (Show, Generic) instance FromJSON PaymentPage diff --git a/common/src/Common/Model/SavedPayment.hs b/common/src/Common/Model/SavedPayment.hs deleted file mode 100644 index f45c479..0000000 --- a/common/src/Common/Model/SavedPayment.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.SavedPayment - ( SavedPayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) - -data SavedPayment = SavedPayment - { _savedPayment_payment :: Payment - , _savedPayment_paymentCategory :: PaymentCategory - } deriving (Show, Generic) - -instance FromJSON SavedPayment -instance ToJSON SavedPayment diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index d7f1db4..0f9c187 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,6 +1,7 @@ module Common.Util.Text ( search , formatSearch + , unaccent ) where import Data.Text (Text) -- cgit v1.2.3