aboutsummaryrefslogtreecommitdiff
path: root/src/server/MonthlyPaymentJob.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/MonthlyPaymentJob.hs')
-rw-r--r--src/server/MonthlyPaymentJob.hs36
1 files changed, 15 insertions, 21 deletions
diff --git a/src/server/MonthlyPaymentJob.hs b/src/server/MonthlyPaymentJob.hs
index f754b81..1b331af 100644
--- a/src/server/MonthlyPaymentJob.hs
+++ b/src/server/MonthlyPaymentJob.hs
@@ -2,37 +2,27 @@ module MonthlyPaymentJob
( monthlyPaymentJobListener
) where
+import Control.Monad.IO.Class (liftIO)
+
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
-import Control.Concurrent (threadDelay)
-
import Database.Persist (entityVal, insert)
+import Job (jobListener)
+
import Model.Database
import Model.Payment (getMonthlyPayments)
import Model.JobKind
-import Model.Job
import Model.Frequency
monthlyPaymentJobListener :: IO ()
-monthlyPaymentJobListener = do
- mbLastExecution <- runDb $ getLastExecution MonthlyPaymentJob
- runThisMonth <- case mbLastExecution of
- Just lastExecution -> belongToCurrentMonth lastExecution
- Nothing -> return False
- if not runThisMonth
- then runDb (monthlyJob >> actualizeLastExecution MonthlyPaymentJob)
- else return ()
- sleepOneHour
- monthlyPaymentJobListener
-
-monthlyJob :: Persist ()
-monthlyJob = do
- monthlyPayments <- map entityVal <$> getMonthlyPayments
- let punctualPayments = map (\p -> p { paymentFrequency = Punctual }) monthlyPayments
- sequence_ $ map insert punctualPayments
+monthlyPaymentJobListener =
+ let lastExecutionTooOld = fmap not . belongToCurrentMonth
+ runJob () = monthlyPaymentJob
+ msDelay = 1000000 * 60 * 60
+ in jobListener MonthlyPaymentJob lastExecutionTooOld runJob msDelay
belongToCurrentMonth :: UTCTime -> IO Bool
belongToCurrentMonth time = do
@@ -46,5 +36,9 @@ getLocalMonth time = do
let (_, month, _) = toGregorian . localDay $ utcToLocalTime timeZone time
return month
-sleepOneHour :: IO ()
-sleepOneHour = threadDelay (1000000 * 60 * 60)
+monthlyPaymentJob :: Persist ()
+monthlyPaymentJob = do
+ monthlyPayments <- map entityVal <$> getMonthlyPayments
+ now <- liftIO $ getCurrentTime
+ let punctualPayments = map (\p -> p { paymentFrequency = Punctual, paymentCreation = now }) monthlyPayments
+ sequence_ $ map insert punctualPayments