{-# LANGUAGE FlexibleContexts #-} module Villefort.Daily where import Villefort.Definitions import Villefort.Database import Control.Monad.Reader import Data.Time import Data.Time.Calendar.OrdinalDate import Data.List.Split as S import Control.Concurrent (threadDelay) -- | Date representation data D = D { year :: Integer, month :: Int, day :: Int} deriving (Show) fromZonedTimeToDay :: String -> Day fromZonedTimeToDay x = fromGregorian (year up) (month up ) (day up) where up = unpackStringToDate x getDate :: IO Day getDate = fromZonedTimeToDay <$> show <$> getZonedTime getDateD :: IO D getDateD = unpackStringToDate <$> show <$> getZonedTime unpackStringToDate :: [Char] -> D unpackStringToDate x = D (read (nums !! 0) :: Integer) (read (nums !! 1) :: Int) (read (nums !! 2) :: Int) where nums = S.splitOn "-" $ take 10 x getDay :: IO Int getDay = do z <- getDate return $ snd $mondayStartWeek z 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 checkDay :: D -> D ->Bool checkDay oldDate currentDate= ((day oldDate) == (day currentDate)) checkMonth :: D -> D -> Bool checkMonth oldDate currentDate = (month oldDate) == (month currentDate) checkYear :: D -> D -> Bool checkYear oldDate currentDate = (year oldDate) == (year currentDate) runDaily :: VConfig -> D -> D -> IO () runDaily vconf oldDate currentDate= if (checkDay oldDate currentDate) then return () else putStrLn "adding-daily" >> do dailies <- sequence (daily vconf) mapM_ add dailies where add = (\x -> if Prelude.null x then return () else runReaderT ( addDaily x) vconf) runMonthly :: D -> D -> IO () runMonthly oldDate currentDate = if(checkMonth oldDate currentDate) then putStrLn "same-month" else putStrLn "adding monthly" runYearly :: D -> D -> IO () runYearly oldDate currentDate = if(checkYear oldDate currentDate) then putStrLn "same-year" else putStrLn "adding yearly" 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 return () 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 man :: VConfig -> IO () man conf = do oldDate <- runReaderT readDate conf currentDate <- getDateD oldDay <- runReaderT readDay conf currentDay <- getDay runWeekly conf oldDay currentDay runDaily conf oldDate currentDate runReaderT writeDate conf runReaderT writeDay conf threadDelay 18000000 -- | Run daily check for updates dailyCheck :: VConfig -> IO b dailyCheck conf = forever$ man conf