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 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