{-# LANGUAGE FlexibleContexts, UnicodeSyntax #-}
module Villefort.Daily (dailyCheck ) where
import Villefort.Definitions (VConfig(..)
, Weekly(..))
import Villefort.Database (execQuery, makeQuery, addDaily)
import Control.Monad.Reader (MonadIO,MonadReader,runReaderT,forever,liftIO)
import Control.Concurrent (threadDelay)
import Villefort.Util (D
,unpackStringToDate
,getDay
,day
,month
,year
,getDate
,getDateD)
writeDate :: (MonadReader VConfig m, MonadIO m) => m ()
writeDate = do
date <- liftIO $ show <$> getDate
execQuery ("update dates set date = ? where type = 'date';") [date]
readDate :: (MonadReader VConfig m, MonadIO m) => m D
readDate = do
rawDate <- makeQuery "select date from dates where type = 'date';"
return $ unpackStringToDate $ head $ head $ rawDate
writeDay :: (MonadReader VConfig m, MonadIO m) => m ()
writeDay = do
newDay <- liftIO $ show <$> getDay
execQuery ("update dates set date = ? where type = 'day';") [newDay]
readDay :: (MonadReader VConfig m, MonadIO m) => m Int
readDay = do
rawDay <- makeQuery "select date from dates where type = 'day';"
let int = read (head $ head $ rawDay) :: Int
return int
runCheck ∷ Eq x ⇒ VConfig → D → D → (VConfig → [IO [String]]) → (D → x) → String → IO ()
runCheck vconf oldDate currentDate extract extractInt addText =
if notrun then
return ()
else do
putStrLn addText
todo ← sequence (extract vconf)
mapM_ add todo
where add = (\x → if null x then return () else runReaderT (addDaily x) vconf)
notrun = (extractInt oldDate == extractInt currentDate)
runWeekly :: VConfig -> Int -> Int -> IO ()
runWeekly conf old current = do
if old /= current
then do
let stmt = selector conf (current-1)
stmts <- sequence stmt
mapM_ add stmts
else putStrLn "didn't run weekly"
where add = (\x -> if Prelude.null x then return () else runReaderT ( addDaily x) conf)
selector :: (Num a, Eq a) => VConfig -> a -> [IO [String]]
selector conf x
| x == 0 = monday lookconf
| x == 1 = tuesday lookconf
| x == 2 = wednesday lookconf
| x == 3 = thursday lookconf
| x == 4 = friday lookconf
| x == 5 = saturday lookconf
| otherwise = sunday lookconf
where lookconf = weekly conf
dailyCheck :: VConfig -> IO ()
dailyCheck conf = forever $ do
currentDate <- getDateD
currentDay <- getDay
oldDate <- runReaderT readDate conf
oldDay <- runReaderT readDay conf
let checkFunc = runCheck conf oldDate currentDate
checkFunc daily day "added daily tasks"
checkFunc monthly month "added monthly tasks"
checkFunc yearly year "added yearly tasks"
runWeekly conf oldDay currentDay
runReaderT writeDate conf
runReaderT writeDay conf
threadDelay 18000000