6 files changed, 155 insertions, 0 deletions
diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs
new file mode 100644
index 0000000..8259b18
--- /dev/null
+++ b/src/server/Job/Daemon.hs
@@ -0,0 +1,40 @@
+module Job.Daemon
+  ( runDaemons
+  ) where
+
+import Data.Time.Clock (UTCTime)
+
+import Control.Concurrent (threadDelay, forkIO, ThreadId)
+import Control.Monad (forever)
+
+import Model.Database
+
+import Job.Kind (Kind(..))
+import Job.Frequency (Frequency(..), microSeconds)
+import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution)
+import Job.MonthlyPayment (monthlyPayment)
+import Job.WeeklyReport (weeklyReport)
+
+import Conf (Conf)
+
+import Utils.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 <- runDb $ do
+      actualizeLastCheck kind
+      getLastExecution kind
+    hasToRun <- case mbLastExecution of
+      Just lastExecution -> isLastExecutionTooOld lastExecution
+      Nothing -> return True
+    if hasToRun
+      then runJob mbLastExecution >>= (runDb . actualizeLastExecution kind)
+      else return ()
+    threadDelay . microSeconds $ frequency
diff --git a/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs
new file mode 100644
index 0000000..263f6e6
--- /dev/null
+++ b/src/server/Job/Frequency.hs
@@ -0,0 +1,13 @@
+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/src/server/Job/Kind.hs b/src/server/Job/Kind.hs
new file mode 100644
index 0000000..473b7c4
--- /dev/null
+++ b/src/server/Job/Kind.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Job.Kind
+  ( Kind(..)
+  ) where
+
+import Database.Persist.TH
+
+data Kind =
+  MonthlyPayment
+  | WeeklyReport
+  deriving (Eq, Show, Read)
+
+derivePersistField "Kind"
diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs
new file mode 100644
index 0000000..cd7297a
--- /dev/null
+++ b/src/server/Job/Model.hs
@@ -0,0 +1,33 @@
+module Job.Model
+  ( getLastExecution
+  , actualizeLastExecution
+  , actualizeLastCheck
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Maybe (isJust)
+
+import Database.Persist
+
+import Model.Database
+
+import Job.Kind
+
+getLastExecution :: Kind -> Persist (Maybe UTCTime)
+getLastExecution kind = do
+  mbJob <- fmap entityVal <$> selectFirst [JobKind ==. kind] []
+  return (mbJob >>= jobLastExecution)
+
+actualizeLastExecution :: Kind -> UTCTime -> Persist ()
+actualizeLastExecution kind time = do
+  jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] []
+  if jobKindDefined
+    then updateWhere [JobKind ==. kind] [JobLastExecution =. Just time]
+    else insert (Job kind (Just time) (Just time)) >> return ()
+
+actualizeLastCheck :: Kind -> Persist ()
+actualizeLastCheck kind = do
+  now <- liftIO getCurrentTime
+  updateWhere [JobKind ==. kind] [JobLastCheck =. Just now]
diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs
new file mode 100644
index 0000000..bac7062
--- /dev/null
+++ b/src/server/Job/MonthlyPayment.hs
@@ -0,0 +1,24 @@
+module Job.MonthlyPayment
+  ( monthlyPayment
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Database.Persist (entityVal, insert)
+
+import Model.Database
+import qualified Model.Payment as Payment
+import Model.Frequency
+
+import Utils.Time (timeToDay)
+
+monthlyPayment :: Maybe UTCTime -> IO UTCTime
+monthlyPayment _ = runDb $ do
+  monthlyPayments <- map entityVal <$> Payment.listMonthly
+  now <- liftIO $ getCurrentTime
+  actualDay <- liftIO $ timeToDay now
+  let punctualPayments = map (\p -> p { paymentFrequency = Punctual, paymentDate = actualDay, paymentCreatedAt = now }) monthlyPayments
+  _ <- sequence $ map insert punctualPayments
+  return now
diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs
new file mode 100644
index 0000000..0d1eb35
--- /dev/null
+++ b/src/server/Job/WeeklyReport.hs
@@ -0,0 +1,31 @@
+module Job.WeeklyReport
+  ( weeklyReport
+  ) where
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Model.Database (runDb)
+import qualified Model.Payment as Payment
+import qualified Model.Income as Income
+import Model.User (getUsers)
+
+import SendMail
+
+import Conf (Conf)
+
+import View.Mail.WeeklyReport (mail)
+
+weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime
+weeklyReport conf mbLastExecution = do
+  now <- getCurrentTime
+  case mbLastExecution of
+    Nothing -> return ()
+    Just lastExecution -> do
+      (payments, incomes, users) <- runDb $
+        (,,) <$>
+          Payment.modifiedDuring lastExecution now <*>
+          Income.modifiedDuring lastExecution now <*>
+          getUsers
+      _ <- sendMail (mail conf users payments incomes lastExecution now)
+      return ()
+  return now