From 11052951b74b9ad4b6a9412ae490086235f9154b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Jan 2021 13:40:40 +0100 Subject: Rewrite in Rust --- server/src/Job/Daemon.hs | 37 ---------------------------- server/src/Job/Frequency.hs | 13 ---------- server/src/Job/Kind.hs | 23 ------------------ server/src/Job/Model.hs | 49 ------------------------------------- server/src/Job/MonthlyPayment.hs | 26 -------------------- server/src/Job/WeeklyReport.hs | 52 ---------------------------------------- 6 files changed, 200 deletions(-) delete mode 100644 server/src/Job/Daemon.hs delete mode 100644 server/src/Job/Frequency.hs delete mode 100644 server/src/Job/Kind.hs delete mode 100644 server/src/Job/Model.hs delete mode 100644 server/src/Job/MonthlyPayment.hs delete 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 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 -- cgit v1.2.3