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/Controller/Payment.hs |  2 +-
 src/server/Main.hs               |  4 ++++
 src/server/Model/Database.hs     | 12 +++++++---
 src/server/Model/Job.hs          | 27 ++++++++++++++++++++++
 src/server/Model/JobKind.hs      | 13 +++++++++++
 src/server/Model/Payment.hs      | 10 +++++---
 src/server/MonthlyPaymentJob.hs  | 49 ++++++++++++++++++++++++++++++++++++++++
 7 files changed, 110 insertions(+), 7 deletions(-)
 create mode 100644 src/server/Model/Job.hs
 create mode 100644 src/server/Model/JobKind.hs
 create mode 100644 src/server/MonthlyPaymentJob.hs

(limited to 'src')

diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 25d3261..7cbfb37 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -37,7 +37,7 @@ getPaymentsAction page perPage =
 getMonthlyPaymentsAction :: ActionM ()
 getMonthlyPaymentsAction =
   Secure.loggedAction (\user -> do
-    (liftIO $ runDb (getMonthlyPayments (entityKey user))) >>= json
+    (liftIO $ runDb (getUserMonthlyPayments (entityKey user))) >>= json
   )
 
 createPaymentAction :: Text -> Int -> Frequency -> ActionM ()
diff --git a/src/server/Main.hs b/src/server/Main.hs
index c3d285e..1c2bc08 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -4,6 +4,9 @@ import Web.Scotty
 
 import Network.Wai.Middleware.Static
 
+import Control.Concurrent (forkIO)
+import MonthlyPaymentJob (monthlyPaymentJobListener)
+
 import Data.Text (Text)
 import qualified Data.Text.IO as TIO
 
@@ -19,6 +22,7 @@ import Config
 
 main :: IO ()
 main = do
+  _ <- forkIO monthlyPaymentJobListener
   eitherConfig <- getConfig "config.txt"
   case eitherConfig of
     Left errorMessage ->
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index d4a7d50..0bbc353 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -22,14 +22,15 @@ import Database.Persist.Sqlite
 import Database.Persist.TH
 
 import Model.Frequency
+import Model.JobKind
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 User
   creation UTCTime
   email Text
   name Text
-  UniqEmail email
-  UniqName name
+  UniqUserEmail email
+  UniqUserName name
   deriving Show
 Payment
   userId UserId
@@ -44,7 +45,12 @@ SignIn
   creation UTCTime
   email Text
   isUsed Bool
-  UniqToken token
+  UniqSignInToken token
+  deriving Show
+Job
+  kind JobKind
+  lastExecution UTCTime Maybe
+  UniqJobName kind
   deriving Show
 |]
 
diff --git a/src/server/Model/Job.hs b/src/server/Model/Job.hs
new file mode 100644
index 0000000..3d5df96
--- /dev/null
+++ b/src/server/Model/Job.hs
@@ -0,0 +1,27 @@
+module Model.Job
+  ( getLastExecution
+  , actualizeLastExecution
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Maybe (isJust)
+
+import Database.Persist
+
+import Model.Database
+import Model.JobKind
+
+getLastExecution :: JobKind -> Persist (Maybe UTCTime)
+getLastExecution kind = do
+  mbJob <- fmap entityVal <$> selectFirst [JobKind ==. kind] []
+  return (mbJob >>= jobLastExecution)
+
+actualizeLastExecution :: JobKind -> Persist ()
+actualizeLastExecution kind = do
+  now <- liftIO getCurrentTime
+  jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] []
+  if jobKindDefined
+    then updateWhere [JobKind ==. kind] [JobLastExecution =. Just now]
+    else insert (Job kind (Just now)) >> return ()
diff --git a/src/server/Model/JobKind.hs b/src/server/Model/JobKind.hs
new file mode 100644
index 0000000..bbe1d45
--- /dev/null
+++ b/src/server/Model/JobKind.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Model.JobKind
+  ( JobKind(..)
+  ) where
+
+import Database.Persist.TH
+
+data JobKind =
+  MonthlyPaymentJob
+  deriving (Eq, Show, Read)
+
+derivePersistField "JobKind"
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 381578a..f07cec4 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,5 +1,6 @@
 module Model.Payment
   ( getPunctualPayments
+  , getUserMonthlyPayments
   , getMonthlyPayments
   , createPayment
   , deleteOwnPayment
@@ -36,14 +37,17 @@ getPunctualPayments page perPage = do
           return (payment, user)
   return (map getJsonPayment xs)
 
-getMonthlyPayments :: UserId -> Persist [P.Payment]
-getMonthlyPayments userId = do
+getUserMonthlyPayments :: UserId -> Persist [P.Payment]
+getUserMonthlyPayments userId =
+  filter ((==) userId . P.userId) <$> getMonthlyPayments
+
+getMonthlyPayments :: Persist [P.Payment]
+getMonthlyPayments = do
   xs <- select $
         from $ \(payment `InnerJoin` user) -> do
           on (payment ^. PaymentUserId E.==. user ^. UserId)
           where_ (isNothing (payment ^. PaymentDeletedAt))
           where_ (payment ^. PaymentFrequency E.==. val Monthly)
-          where_ (payment ^. PaymentUserId E.==. val userId)
           orderBy [desc (payment ^. PaymentCreation)]
           return (payment, user)
   return (map getJsonPayment xs)
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