Use a better project structure

6 files changed, 172 insertions, 0 deletions

diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs
new file mode 100644
index 0000000..0bc6f6e
--- /dev/null
+++ b/server/src/Job/Daemon.hs
@@ -0,0 +1,36 @@
+module Job.Daemon
+  ( runDaemons
+  ) where
+
+import Control.Concurrent (threadDelay, forkIO, ThreadId)
+import Control.Monad (forever)
+import Data.Time.Clock (UTCTime)
+
+import Conf (Conf)
+import Job.Frequency (Frequency(..), microSeconds)
+import Job.Kind (Kind(..))
+import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution)
+import Job.MonthlyPayment (monthlyPayment)
+import Job.WeeklyReport (weeklyReport)
+import qualified Model.Query as Query
+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 <- 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
new file mode 100644
index 0000000..263f6e6
--- /dev/null
+++ b/server/src/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/server/src/Job/Kind.hs b/server/src/Job/Kind.hs
new file mode 100644
index 0000000..af5d4f8
--- /dev/null
+++ b/server/src/Job/Kind.hs
@@ -0,0 +1,22 @@
+module Job.Kind
+  ( Kind(..)
+  ) where
+
+import Database.SQLite.Simple (SQLData(SQLText))
+import Database.SQLite.Simple.FromField (fieldData, FromField(fromField))
+import Database.SQLite.Simple.Ok (Ok(Ok, Errors))
+import Database.SQLite.Simple.ToField (ToField(toField))
+import qualified Data.Text as T
+
+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
new file mode 100644
index 0000000..e1a3c77
--- /dev/null
+++ b/server/src/Job/Model.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Job.Model
+  ( Job(..)
+  , getLastExecution
+  , actualizeLastExecution
+  , actualizeLastCheck
+  ) where
+
+import Data.Maybe (isJust)
+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
+    [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)]
+    return time
+  )
+
+actualizeLastExecution :: Kind -> UTCTime -> Query ()
+actualizeLastExecution jobKind time =
+  Query (\conn -> do
+    [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)]
+    if isJust result
+      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
new file mode 100644
index 0000000..ba24cca
--- /dev/null
+++ b/server/src/Job/MonthlyPayment.hs
@@ -0,0 +1,26 @@
+module Job.MonthlyPayment
+  ( monthlyPayment
+  ) where
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Common.Model (Frequency(..), Payment(..))
+
+import qualified Model.Payment as Payment
+import Utils.Time (timeToDay)
+import qualified Model.Query as Query
+
+monthlyPayment :: Maybe UTCTime -> IO UTCTime
+monthlyPayment _ = do
+  monthlyPayments <- Query.run Payment.listMonthly
+  now <- getCurrentTime
+  actualDay <- timeToDay now
+  let punctualPayments = map
+        (\p -> p
+          { _payment_frequency = Punctual
+          , _payment_date = actualDay
+          , _payment_createdAt = now
+          })
+        monthlyPayments
+  _ <- Query.run (Payment.createMany punctualPayments)
+  return now
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
new file mode 100644
index 0000000..5737c75
--- /dev/null
+++ b/server/src/Job/WeeklyReport.hs
@@ -0,0 +1,28 @@
+module Job.WeeklyReport
+  ( weeklyReport
+  ) where
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Conf (Conf)
+import qualified Model.Income as Income
+import qualified Model.Payment as Payment
+import qualified Model.Query as Query
+import qualified Model.User as User
+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
+      (payments, incomes, users) <- Query.run $
+        (,,) <$>
+          Payment.modifiedDuring lastExecution now <*>
+          Income.modifiedDuring lastExecution now <*>
+          User.list
+      _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now)
+      return ()
+  return now