Merge branch 'with-ghcjs' into 'master'

Use Haskell on the frontend

See merge request guyonvarch/shared-cost!2

6 files changed, 199 insertions, 0 deletions

diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs
new file mode 100644
index 0000000..d8cd522
--- /dev/null
+++ b/server/src/Job/Daemon.hs
@@ -0,0 +1,37 @@
+module Job.Daemon
+  ( runDaemons
+  ) where
+
+import           Control.Concurrent (ThreadId, forkIO, threadDelay)
+import           Control.Monad      (forever)
+import           Data.Time.Clock    (UTCTime)
+
+import           Conf               (Conf)
+import           Job.Frequency      (Frequency (..), microSeconds)
+import           Job.Kind           (Kind (..))
+import           Job.Model          (actualizeLastCheck, actualizeLastExecution,
+                                     getLastExecution)
+import           Job.MonthlyPayment (monthlyPayment)
+import           Job.WeeklyReport   (weeklyReport)
+import qualified Model.Query        as Query
+import           Util.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..c5bef42
--- /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..17997f7
--- /dev/null
+++ b/server/src/Job/Kind.hs
@@ -0,0 +1,23 @@
+module Job.Kind
+  ( Kind(..)
+  ) where
+
+import qualified Data.Text                        as T
+import           Database.SQLite.Simple           (SQLData (SQLText))
+import           Database.SQLite.Simple.FromField (FromField (fromField),
+                                                   fieldData)
+import           Database.SQLite.Simple.Ok        (Ok (Errors, Ok))
+import           Database.SQLite.Simple.ToField   (ToField (toField))
+
+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..1dd6c63
--- /dev/null
+++ b/server/src/Job/Model.hs
@@ -0,0 +1,49 @@
+module Job.Model
+  ( Job(..)
+  , getLastExecution
+  , actualizeLastExecution
+  , actualizeLastCheck
+  ) where
+
+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
+    result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime]
+    return $ case result of
+      [Only time] -> Just time
+      _           -> Nothing
+  )
+
+actualizeLastExecution :: Kind -> UTCTime -> Query ()
+actualizeLastExecution jobKind time =
+  Query (\conn -> do
+    result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int]
+    let hasJob = case result of
+         [Only _] -> True
+         _        -> False
+    if hasJob
+      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..dfbe8b4
--- /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 Common.Util.Time    as Time
+
+import qualified Model.Query         as Query
+import qualified Persistence.Payment as PaymentPersistence
+
+monthlyPayment :: Maybe UTCTime -> IO UTCTime
+monthlyPayment _ = do
+  monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName
+  now <- getCurrentTime
+  actualDay <- Time.timeToDay now
+  let punctualPayments = map
+        (\p -> p
+          { _payment_frequency = Punctual
+          , _payment_date = actualDay
+          , _payment_createdAt = now
+          })
+        monthlyPayments
+  _ <- Query.run (PaymentPersistence.createMany punctualPayments)
+  return now
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
new file mode 100644
index 0000000..ff80ddf
--- /dev/null
+++ b/server/src/Job/WeeklyReport.hs
@@ -0,0 +1,51 @@
+module Job.WeeklyReport
+  ( weeklyReport
+  ) where
+
+import qualified Data.Map               as M
+import           Data.Time.Clock        (UTCTime, getCurrentTime)
+
+import           Common.Model           (User (..))
+
+import           Conf                   (Conf)
+import qualified Model.Query            as Query
+import qualified Persistence.Income     as IncomePersistence
+import qualified Persistence.Payment    as PaymentPersistence
+import qualified Persistence.User       as UserPersistence
+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
+      (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do
+        users <- UserPersistence.list
+        paymentRange <- PaymentPersistence.getRange
+        incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
+        cumulativeIncome <-
+          case (incomeDefinedForAll, paymentRange) of
+            (Just incomeStart, Just (paymentStart, paymentEnd))  ->
+              IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd
+
+            _ ->
+              return M.empty
+        weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution
+        weekIncomes <- IncomePersistence.listModifiedSince lastExecution
+        (preIncomeRepartition, postIncomeRepartition) <-
+          PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
+        return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
+
+      _ <-
+        SendMail.sendMail
+          conf
+          (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now)
+
+      return ()
+
+  return now