From fff7336e06ab4c98adda3fea8a86c7d4d4b9b9bb Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 1 Oct 2015 14:10:45 +0200
Subject: Factor job listener

---
 src/server/Job.hs               | 25 +++++++++++++++++++++++++
 src/server/Model/Database.hs    |  1 +
 src/server/Model/Job.hs         |  8 +++++++-
 src/server/Model/Payment.hs     | 11 ++++++-----
 src/server/MonthlyPaymentJob.hs | 36 +++++++++++++++---------------------
 5 files changed, 54 insertions(+), 27 deletions(-)
 create mode 100644 src/server/Job.hs

(limited to 'src')

diff --git a/src/server/Job.hs b/src/server/Job.hs
new file mode 100644
index 0000000..bf8f15b
--- /dev/null
+++ b/src/server/Job.hs
@@ -0,0 +1,25 @@
+module Job
+  ( jobListener
+  ) where
+
+import Data.Time.Clock
+
+import Control.Concurrent (threadDelay)
+
+import Model.Database
+import Model.JobKind
+import Model.Job
+
+jobListener :: JobKind -> (UTCTime -> IO Bool) -> (() -> Persist ()) -> Int -> IO ()
+jobListener kind lastExecutionTooOld runJob msDelay = do
+  mbLastExecution <- runDb $ do
+    actualizeLastCheck kind
+    getLastExecution kind
+  hasToRun <- case mbLastExecution of
+    Just lastExecution -> lastExecutionTooOld lastExecution
+    Nothing -> return True
+  if hasToRun
+    then runDb (runJob () >> actualizeLastExecution kind)
+    else return ()
+  threadDelay msDelay
+  jobListener kind lastExecutionTooOld runJob msDelay
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index c88322f..f38379a 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -50,6 +50,7 @@ SignIn
 Job
   kind JobKind
   lastExecution UTCTime Maybe
+  lastCheck UTCTime Maybe
   UniqJobName kind
   deriving Show
 Income
diff --git a/src/server/Model/Job.hs b/src/server/Model/Job.hs
index 3d5df96..5b0d89d 100644
--- a/src/server/Model/Job.hs
+++ b/src/server/Model/Job.hs
@@ -1,6 +1,7 @@
 module Model.Job
   ( getLastExecution
   , actualizeLastExecution
+  , actualizeLastCheck
   ) where
 
 import Control.Monad.IO.Class (liftIO)
@@ -24,4 +25,9 @@ actualizeLastExecution kind = do
   jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] []
   if jobKindDefined
     then updateWhere [JobKind ==. kind] [JobLastExecution =. Just now]
-    else insert (Job kind (Just now)) >> return ()
+    else insert (Job kind (Just now) (Just now)) >> return ()
+
+actualizeLastCheck :: JobKind -> Persist ()
+actualizeLastCheck kind = do
+  now <- liftIO getCurrentTime
+  updateWhere [JobKind ==. kind] [JobLastCheck =. Just now]
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 469f0d3..25b1bb7 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -42,11 +42,12 @@ getUserMonthlyPayments userId =
 
 getMonthlyPayments :: Persist [Entity Payment]
 getMonthlyPayments =
-  selectList
-    [ PaymentDeletedAt P.==. Nothing
-    , PaymentFrequency P.==. Monthly
-    ]
-    [ Desc PaymentCreation ]
+  select $
+    from $ \payment -> do
+    where_ (isNothing (payment ^. PaymentDeletedAt))
+    where_ (payment ^. PaymentFrequency E.==. val Monthly)
+    orderBy [desc (lower_ (payment ^. PaymentName))]
+    return payment
 
 getJsonPayment :: Entity Payment -> P.Payment
 getJsonPayment paymentEntity =
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
-- 
cgit v1.2.3