From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- server/src/Job/WeeklyReport.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 server/src/Job/WeeklyReport.hs (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..5737c75 --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,28 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Conf (Conf) +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import qualified Model.User as User +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + case mbLastExecution of + Nothing -> return () + Just lastExecution -> do + (payments, incomes, users) <- Query.run $ + (,,) <$> + Payment.modifiedDuring lastExecution now <*> + Income.modifiedDuring lastExecution now <*> + User.list + _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + return () + return now -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- server/src/Job/WeeklyReport.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 5737c75..74180df 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,13 +2,13 @@ module Job.WeeklyReport ( weeklyReport ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User +import Conf (Conf) +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import qualified Model.User as User import qualified SendMail import qualified View.Mail.WeeklyReport as WeeklyReport -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- server/src/Job/WeeklyReport.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 74180df..38d88b5 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,10 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- server/src/Job/WeeklyReport.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 38d88b5..203c4e8 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -5,10 +5,10 @@ module Job.WeeklyReport import Data.Time.Clock (UTCTime, getCurrentTime) import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment import qualified Model.Query as Query -import qualified Model.User as User +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified SendMail import qualified View.Mail.WeeklyReport as WeeklyReport @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now -- cgit v1.2.3 From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:28:42 +0100 Subject: Show income header --- server/src/Job/WeeklyReport.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 203c4e8..1a478dc 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now -- cgit v1.2.3 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 --- server/src/Job/WeeklyReport.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 1a478dc..34bbd3a 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do now <- getCurrentTime + case mbLastExecution of - Nothing -> return () + Nothing -> + return () + Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list - _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) + (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + return () + return now -- cgit v1.2.3 From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- server/src/Job/WeeklyReport.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 34bbd3a..16be396 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,8 +2,11 @@ module Job.WeeklyReport ( weeklyReport ) where +import qualified Data.Map as M import Data.Time.Clock (UTCTime, getCurrentTime) +import Common.Model (User (..)) + import Conf (Conf) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence @@ -21,19 +24,27 @@ weeklyReport conf mbLastExecution = do return () Just lastExecution -> do - (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do users <- UserPersistence.list paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty weekPayments <- PaymentPersistence.listModifiedSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) _ <- SendMail.sendMail conf - (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) return () -- cgit v1.2.3 From 1dfb85d3fd56d163fc854a8b3cf659d0ac39f639 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 17:25:29 +0100 Subject: Search payments by cost too --- server/src/Job/WeeklyReport.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src/Job/WeeklyReport.hs') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 16be396..ff80ddf 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -35,7 +35,7 @@ weeklyReport conf mbLastExecution = do _ -> return M.empty - weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users -- cgit v1.2.3