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/Daemon.hs | 36 ++++++++++++++++++++++++++++++ server/src/Job/Frequency.hs | 13 +++++++++++ server/src/Job/Kind.hs | 22 +++++++++++++++++++ server/src/Job/Model.hs | 47 ++++++++++++++++++++++++++++++++++++++++ server/src/Job/MonthlyPayment.hs | 26 ++++++++++++++++++++++ server/src/Job/WeeklyReport.hs | 28 ++++++++++++++++++++++++ 6 files changed, 172 insertions(+) create mode 100644 server/src/Job/Daemon.hs create mode 100644 server/src/Job/Frequency.hs create mode 100644 server/src/Job/Kind.hs create mode 100644 server/src/Job/Model.hs create mode 100644 server/src/Job/MonthlyPayment.hs create mode 100644 server/src/Job/WeeklyReport.hs (limited to 'server/src/Job') diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs new file mode 100644 index 0000000..0bc6f6e --- /dev/null +++ b/server/src/Job/Daemon.hs @@ -0,0 +1,36 @@ +module Job.Daemon + ( runDaemons + ) where + +import Control.Concurrent (threadDelay, forkIO, ThreadId) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) + +import Conf (Conf) +import Job.Frequency (Frequency(..), microSeconds) +import Job.Kind (Kind(..)) +import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) + +runDaemons :: Conf -> IO () +runDaemons conf = do + _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment + _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) + return () + +runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId +runDaemon kind frequency isLastExecutionTooOld runJob = + forkIO . forever $ do + mbLastExecution <- Query.run $ do + actualizeLastCheck kind + getLastExecution kind + hasToRun <- case mbLastExecution of + Just lastExecution -> isLastExecutionTooOld lastExecution + Nothing -> return True + if hasToRun + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) + else return () + threadDelay . microSeconds $ frequency diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs new file mode 100644 index 0000000..263f6e6 --- /dev/null +++ b/server/src/Job/Frequency.hs @@ -0,0 +1,13 @@ +module Job.Frequency + ( Frequency(..) + , microSeconds + ) where + +data Frequency = + EveryHour + | EveryDay + deriving (Eq, Read, Show) + +microSeconds :: Frequency -> Int +microSeconds EveryHour = 1000000 * 60 * 60 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..af5d4f8 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,22 @@ +module Job.Kind + ( Kind(..) + ) where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs new file mode 100644 index 0000000..e1a3c77 --- /dev/null +++ b/server/src/Job/Model.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Job.Model + ( Job(..) + , getLastExecution + , actualizeLastExecution + , actualizeLastCheck + ) where + +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Job.Kind +import Model.Query (Query(Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] + return time + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] + if isJust result + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..ba24cca --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency(..), Payment(..)) + +import qualified Model.Payment as Payment +import Utils.Time (timeToDay) +import qualified Model.Query as Query + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run Payment.listMonthly + now <- getCurrentTime + actualDay <- timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (Payment.createMany punctualPayments) + return now 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/Daemon.hs | 25 +++++++++++++------------ server/src/Job/Frequency.hs | 2 +- server/src/Job/Kind.hs | 13 +++++++------ server/src/Job/Model.hs | 18 +++++++++--------- server/src/Job/MonthlyPayment.hs | 10 +++++----- server/src/Job/WeeklyReport.hs | 12 ++++++------ 6 files changed, 41 insertions(+), 39 deletions(-) (limited to 'server/src/Job') diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 0bc6f6e..26977d1 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -2,18 +2,19 @@ module Job.Daemon ( runDaemons ) where -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Conf (Conf) +import Job.Frequency (Frequency (..), microSeconds) +import Job.Kind (Kind (..)) +import Job.Model (actualizeLastCheck, actualizeLastExecution, + getLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do @@ -29,7 +30,7 @@ runDaemon kind frequency isLastExecutionTooOld runJob = getLastExecution kind hasToRun <- case mbLastExecution of Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True + Nothing -> return True if hasToRun then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs index 263f6e6..c5bef42 100644 --- a/server/src/Job/Frequency.hs +++ b/server/src/Job/Frequency.hs @@ -10,4 +10,4 @@ data Frequency = microSeconds :: Frequency -> Int microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs index af5d4f8..17997f7 100644 --- a/server/src/Job/Kind.hs +++ b/server/src/Job/Kind.hs @@ -2,11 +2,12 @@ module Job.Kind ( Kind(..) ) where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) data Kind = MonthlyPayment @@ -16,7 +17,7 @@ data Kind = instance FromField Kind where fromField field = case fieldData field of SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] + _ -> Errors [error "SQLText field required for job kind"] instance ToField Kind where toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index e1a3c77..b90dca0 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -7,20 +7,20 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Job.Kind -import Model.Query (Query(Query)) +import Job.Kind +import Model.Query (Query (Query)) data Job = Job - { id :: String - , kind :: Kind + { id :: String + , kind :: Kind , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime + , lastCheck :: Maybe UTCTime } deriving (Show) getLastExecution :: Kind -> Query (Maybe UTCTime) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ba24cca..8cb1c27 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,13 +2,13 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency(..), Payment(..)) +import Common.Model (Frequency (..), Payment (..)) -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import Utils.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do 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 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- server/src/Job/Daemon.hs | 2 +- server/src/Job/Model.hs | 2 -- server/src/Job/MonthlyPayment.hs | 2 +- 3 files changed, 2 insertions(+), 4 deletions(-) (limited to 'server/src/Job') diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 26977d1..d8cd522 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -14,7 +14,7 @@ import Job.Model (actualizeLastCheck, actualizeLastExecution, import Job.MonthlyPayment (monthlyPayment) import Job.WeeklyReport (weeklyReport) import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index b90dca0..a5fa62b 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Job.Model ( Job(..) , getLastExecution diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 8cb1c27..ca7e007 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -8,7 +8,7 @@ import Common.Model (Frequency (..), Payment (..)) import qualified Model.Payment as Payment import qualified Model.Query as Query -import Utils.Time (timeToDay) +import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do -- cgit v1.2.3 From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- server/src/Job/Model.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'server/src/Job') diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index a5fa62b..1dd6c63 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -5,7 +5,6 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) import Data.Time.Clock (UTCTime, getCurrentTime) import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -24,15 +23,20 @@ data Job = Job getLastExecution :: Kind -> Query (Maybe UTCTime) getLastExecution jobKind = Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing ) actualizeLastExecution :: Kind -> UTCTime -> Query () actualizeLastExecution jobKind time = Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) ) -- 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/MonthlyPayment.hs | 2 +- server/src/Job/WeeklyReport.hs | 7 ++----- 2 files changed, 3 insertions(+), 6 deletions(-) (limited to 'server/src/Job') diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ca7e007..907be2b 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -12,7 +12,7 @@ import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly + monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName now <- getCurrentTime actualDay <- timeToDay now let punctualPayments = map 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/MonthlyPayment.hs | 16 ++++++++-------- server/src/Job/WeeklyReport.hs | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'server/src/Job') diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 907be2b..dfbe8b4 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,19 +2,19 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Util.Time as Time -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import Util.Time (timeToDay) +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName + monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName now <- getCurrentTime - actualDay <- timeToDay now + actualDay <- Time.timeToDay now let punctualPayments = map (\p -> p { _payment_frequency = Punctual @@ -22,5 +22,5 @@ monthlyPayment _ = do , _payment_createdAt = now }) monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) + _ <- Query.run (PaymentPersistence.createMany punctualPayments) return now 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') 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') 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') 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') 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