From 0b191f5c48edffc9da3e38c284e9640fd82e7cb1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Jun 2017 18:02:13 +0200 Subject: Replace persistent by sqlite-simple --- src/server/Job/Daemon.hs | 16 ++++------ src/server/Job/Kind.hs | 16 +++++++--- src/server/Job/Model.hs | 64 ++++++++++++++++++++++++---------------- src/server/Job/MonthlyPayment.hs | 21 +++++-------- src/server/Job/WeeklyReport.hs | 17 +++++------ 5 files changed, 72 insertions(+), 62 deletions(-) (limited to 'src/server/Job') diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs index 8259b18..0bc6f6e 100644 --- a/src/server/Job/Daemon.hs +++ b/src/server/Job/Daemon.hs @@ -2,21 +2,17 @@ module Job.Daemon ( runDaemons ) where -import Data.Time.Clock (UTCTime) - import Control.Concurrent (threadDelay, forkIO, ThreadId) import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Model.Database - -import Job.Kind (Kind(..)) +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 Conf (Conf) - +import qualified Model.Query as Query import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () @@ -28,13 +24,13 @@ runDaemons conf = do runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId runDaemon kind frequency isLastExecutionTooOld runJob = forkIO . forever $ do - mbLastExecution <- runDb $ 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 >>= (runDb . actualizeLastExecution kind) + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () threadDelay . microSeconds $ frequency diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs index 473b7c4..af5d4f8 100644 --- a/src/server/Job/Kind.hs +++ b/src/server/Job/Kind.hs @@ -1,14 +1,22 @@ -{-# LANGUAGE TemplateHaskell #-} - module Job.Kind ( Kind(..) ) where -import Database.Persist.TH +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) -derivePersistField "Kind" +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/src/server/Job/Model.hs b/src/server/Job/Model.hs index cd7297a..e1a3c77 100644 --- a/src/server/Job/Model.hs +++ b/src/server/Job/Model.hs @@ -1,33 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + module Job.Model - ( getLastExecution + ( Job(..) + , 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 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 - -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] +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/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index bac7062..8c11ccf 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -2,23 +2,18 @@ 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 qualified Model.Payment as Payment import Utils.Time (timeToDay) +import qualified Model.Query as Query 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 +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/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs index 5cde3e9..5737c75 100644 --- a/src/server/Job/WeeklyReport.hs +++ b/src/server/Job/WeeklyReport.hs @@ -4,16 +4,13 @@ module Job.WeeklyReport import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Database (runDb) -import qualified Model.Payment as Payment +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 SendMail - -import Conf (Conf) - -import View.Mail.WeeklyReport (mail) +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do @@ -21,11 +18,11 @@ weeklyReport conf mbLastExecution = do case mbLastExecution of Nothing -> return () Just lastExecution -> do - (payments, incomes, users) <- runDb $ + (payments, incomes, users) <- Query.run $ (,,) <$> Payment.modifiedDuring lastExecution now <*> Income.modifiedDuring lastExecution now <*> User.list - _ <- sendMail (mail conf users payments incomes lastExecution now) + _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now -- cgit v1.2.3