Replace persistent by sqlite-simple

5 files changed, 72 insertions, 62 deletions

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