aboutsummaryrefslogtreecommitdiff
path: root/server/src/Job
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Job')
-rw-r--r--server/src/Job/Daemon.hs37
-rw-r--r--server/src/Job/Frequency.hs13
-rw-r--r--server/src/Job/Kind.hs23
-rw-r--r--server/src/Job/Model.hs49
-rw-r--r--server/src/Job/MonthlyPayment.hs26
-rw-r--r--server/src/Job/WeeklyReport.hs52
6 files changed, 0 insertions, 200 deletions
diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs
deleted file mode 100644
index d8cd522..0000000
--- a/server/src/Job/Daemon.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module Job.Daemon
- ( runDaemons
- ) where
-
-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 (actualizeLastCheck, actualizeLastExecution,
- getLastExecution)
-import Job.MonthlyPayment (monthlyPayment)
-import Job.WeeklyReport (weeklyReport)
-import qualified Model.Query as Query
-import Util.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
deleted file mode 100644
index c5bef42..0000000
--- a/server/src/Job/Frequency.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-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
deleted file mode 100644
index 17997f7..0000000
--- a/server/src/Job/Kind.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Job.Kind
- ( Kind(..)
- ) where
-
-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
- | 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
deleted file mode 100644
index 1dd6c63..0000000
--- a/server/src/Job/Model.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module Job.Model
- ( Job(..)
- , getLastExecution
- , actualizeLastExecution
- , actualizeLastCheck
- ) where
-
-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
- 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
- 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)
- )
-
-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
deleted file mode 100644
index dfbe8b4..0000000
--- a/server/src/Job/MonthlyPayment.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module Job.MonthlyPayment
- ( monthlyPayment
- ) where
-
-import Data.Time.Clock (UTCTime, getCurrentTime)
-
-import Common.Model (Frequency (..), Payment (..))
-import qualified Common.Util.Time as Time
-
-import qualified Model.Query as Query
-import qualified Persistence.Payment as PaymentPersistence
-
-monthlyPayment :: Maybe UTCTime -> IO UTCTime
-monthlyPayment _ = do
- monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName
- now <- getCurrentTime
- actualDay <- Time.timeToDay now
- let punctualPayments = map
- (\p -> p
- { _payment_frequency = Punctual
- , _payment_date = actualDay
- , _payment_createdAt = now
- })
- monthlyPayments
- _ <- Query.run (PaymentPersistence.createMany punctualPayments)
- return now
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
deleted file mode 100644
index 282f2f1..0000000
--- a/server/src/Job/WeeklyReport.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module Job.WeeklyReport
- ( weeklyReport
- ) where
-
-import qualified Data.Map as M
-import qualified Data.Time.Clock as Clock
-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
-import qualified Persistence.Payment as PaymentPersistence
-import qualified Persistence.User as UserPersistence
-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
- (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, _)) ->
- IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) (Clock.utctDay now)
-
- _ ->
- return M.empty
- weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution
- weekIncomes <- IncomePersistence.listModifiedSince lastExecution
- (preIncomeRepartition, postIncomeRepartition) <-
- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
- return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
-
- _ <-
- SendMail.sendMail
- conf
- (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now)
-
- return ()
-
- return now
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-01 09:44:57 +0000