From 53afb9c96904ab226ccee754419569da16c59871 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Sep 2015 23:25:44 +0200
Subject: Setting up the monthly job

---
 src/server/MonthlyPaymentJob.hs | 49 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)
 create mode 100644 src/server/MonthlyPaymentJob.hs

(limited to 'src/server/MonthlyPaymentJob.hs')

diff --git a/src/server/MonthlyPaymentJob.hs b/src/server/MonthlyPaymentJob.hs
new file mode 100644
index 0000000..a3be375
--- /dev/null
+++ b/src/server/MonthlyPaymentJob.hs
@@ -0,0 +1,49 @@
+module MonthlyPaymentJob
+  ( monthlyPaymentJobListener
+  ) where
+
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+
+import Control.Concurrent (threadDelay)
+
+import Model.Database
+import Model.Payment (createPayment, getMonthlyPayments)
+import Model.JobKind
+import Model.Job
+import Model.Json.Payment as P
+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 ()
+  sleepOneDay
+  monthlyPaymentJobListener
+
+monthlyJob :: Persist ()
+monthlyJob = do
+  monthlyPayments <- getMonthlyPayments
+  _ <- sequence $ map (\p -> createPayment (P.userId p) (P.name p) (P.cost p) Punctual) monthlyPayments
+  return ()
+
+belongToCurrentMonth :: UTCTime -> IO Bool
+belongToCurrentMonth time = do
+  month <- getLocalMonth time
+  actualMonth <- getCurrentTime >>= getLocalMonth
+  return (month == actualMonth)
+
+getLocalMonth :: UTCTime -> IO Int
+getLocalMonth time = do
+  timeZone <- getCurrentTimeZone
+  let (_, month, _) = toGregorian . localDay $ utcToLocalTime timeZone time
+  return month
+
+sleepOneDay :: IO ()
+sleepOneDay = threadDelay (1000000 * 60 * 60 * 24)
-- 
cgit v1.2.3