diff --git a/app/Cache.hs b/app/Cache.hs new file mode 100644 index 0000000..ef0ebef --- /dev/null +++ b/app/Cache.hs @@ -0,0 +1,51 @@ +module Cache where + +import Const (cacheFile, logFile, prog) +import Sugar (killall, failure) + +import Data.List.Extra ((!?)) +import System.FilePath ((), takeDirectory) +import System.Directory ( + XdgDirectory(XdgCache, XdgConfig), + createDirectoryIfMissing, doesFileExist, getXdgDirectory + ) +import Control.Exception (catch) + +pathToCache :: String -> IO String +pathToCache str = ( str) <$> getXdgDirectory XdgCache prog + +pathToConfig :: String -> IO String +pathToConfig str = ( str) <$> getXdgDirectory XdgConfig prog + +readCache :: IO (Maybe (Double, Double, String)) +readCache = do + cache <- pathToCache cacheFile + contents <- readFile cache + let entries = lines contents + case (entries !? 0, entries !? 1, entries !? 2) of + (Just lat, Just lon, Just tz) -> return (Just (read lat, read lon, tz)) + _ -> return Nothing + +dumpCache :: Double -> Double -> String -> IO (Double, Double) +dumpCache lat lon tz = do + cache <- pathToCache cacheFile + catch (writer cache) failure + return (lat, lon) + where writer dir = writeFile dir (show lat ++ "\n" ++ show lon ++ "\n" ++ tz) + +start :: IO () +start = do + logs <- pathToCache logFile + existsLog <- doesFileExist logs + if existsLog then do + contents <- readFile logs + (sequence_ . killall . lines) contents + else createDirectoryIfMissing True (takeDirectory logs) + +finish :: String -> IO () +finish queue = do + cache <- pathToCache logFile + catch (writeFile cache num) failure + where + getId = head . words . last . lines + num = getId queue diff --git a/app/Const.hs b/app/Const.hs index 607aa9c..3af5223 100644 --- a/app/Const.hs +++ b/app/Const.hs @@ -6,6 +6,12 @@ query = "http://ip-api.com/line/?fields=status,lat,lon,timezone" prog :: String prog = "suntheme" +cacheFile :: String +cacheFile = "data.txt" + +logFile :: String +logFile = "log.txt" + lightModeScript :: String lightModeScript = "light.sh" diff --git a/app/Getters.hs b/app/Getters.hs index 96087d9..6239d4d 100644 --- a/app/Getters.hs +++ b/app/Getters.hs @@ -1,17 +1,7 @@ module Getters where -import Const (prog) - -import System.FilePath (()) -import System.Directory (XdgDirectory(XdgCache, XdgConfig), getXdgDirectory) import Control.Exception (SomeException, try) import Network.HTTP.Request (Response, get) -pathToCache :: String -> IO String -pathToCache str = ( str) <$> getXdgDirectory XdgCache prog - -pathToConfig :: String -> IO String -pathToConfig str = ( str) <$> getXdgDirectory XdgConfig prog - fetch :: String -> IO (Either SomeException Response) fetch = try . get diff --git a/app/Main.hs b/app/Main.hs index 1a1f823..9d4ac6b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,37 +5,29 @@ module Main where -import Pure (buildCmd, readLines) -import Time (activateOnSunrise, sunriseNow, sunsetNow) -import Const (darkModeScript, lightModeScript, query) -import Sugar (continue, crash, destruct, exec, killall) +import Pure (readLines) +import Cache (dumpCache, start) +import Const (query) +import Sugar (continue, destruct) import Types (ResponseCode(..), ResponseMsg(..), genericErr, toResponseMsg) -import Getters (fetch, pathToCache, pathToConfig) +import Getters (fetch) +import Workers (backupRunner, prepareScripts) -import Data.List.Extra ((!?)) import Data.ByteString.Char8 (unpack) -import System.FilePath (takeDirectory) -import System.Directory (createDirectoryIfMissing, doesFileExist) -import Control.Exception (SomeException, catch) import Network.HTTP.Request (Response(responseBody, responseStatus)) -- error handling --- refactor into modules --- clean up jank (reduce lines in functions, more atomic/functional, etc) +-- clean up jank ( +-- create types, +-- more pure functions, +-- reduce lines in functions, +-- more atomic/functional, +-- etc +-- ) -- eliminate as many do blocks as possible -- introduce liquid types and checking -- whitepaper! -ping :: (Response -> IO ()) -> IO () -> IO () -ping run err = do - res <- fetch query - case res of - Left e -> continue (toResponseMsg e) err - Right r -> - let status = (ResponseCode . responseStatus) r - runner = run r - in destruct status runner err - process :: Response -> (Double -> Double -> String -> IO ()) -> IO () -> IO () process r run err = case info of @@ -49,80 +41,22 @@ process r run err = parts = (lines . unpack) body info = (readLines . take 4) parts -dumpCache :: Double -> Double -> String -> IO () -dumpCache lat lon tz = do - cache <- pathToCache "data.txt" - catch (writer cache) failure - prepareScripts lat lon - where - writer dir = writeFile dir (show lat ++ "\n" ++ show lon ++ "\n" ++ tz) - failure = print :: SomeException -> IO () - -readCache :: IO (Maybe (Double, Double, String)) -readCache = do - cache <- pathToCache "data.txt" - contents <- readFile cache - let entries = lines contents - case (entries !? 0, entries !? 1, entries !? 2) of - (Just lat, Just lon, Just tz) -> return (Just (read lat, read lon, tz)) - _ -> return Nothing - processRunner :: Response -> IO () -processRunner r = process r dumpCache backupRunner +processRunner r = process r run backupRunner + where run lat lon tz = dumpCache lat lon tz >>= prepareScripts -backupRunner :: IO () -backupRunner = do - contents <- readCache - case contents of - Nothing -> do - putStrLn "Failed to read cache after IP location failed" - crash - Just (lat, lon, _) -> prepareScripts lat lon - -start :: IO () -> IO () -start act = do - logFile <- pathToCache "log.txt" - existsLog <- doesFileExist logFile - if existsLog then do - contents <- readFile logFile - let entries = lines contents - (sequence_ . killall) entries - else createDirectoryIfMissing True (takeDirectory logFile) - act - -finish :: String -> IO () -finish queue = do - cache <- pathToCache "log.txt" - catch (writeFile cache num) failure - where - num = getId queue - getId = head . words . last . lines - failure = print :: SomeException -> IO () - -prepareScripts :: Double -> Double -> IO () -prepareScripts lat lon = do - sunriseTime <- sunriseNow lat lon - sunsetTime <- sunsetNow lat lon - lightMode <- activateOnSunrise sunriseTime sunsetTime - _ <- if lightMode then do - putStr "Light mode activation script scheduled for " - print sunriseTime - script <- pathToConfig lightModeScript - exec (buildCmd script sunriseTime) terminate - else do - putStrLn "Dark mode activation script scheduled for " - print sunsetTime - script <- pathToConfig darkModeScript - exec (buildCmd script sunsetTime) terminate - queue <- exec "atq" noQueue - finish queue - where - terminate _ = print "Scheduling process failed" >> return "" - noQueueMsg = "Scheduled process could not be retrieved (try rerunning if 'atq' fails)" - noQueue _ = print noQueueMsg >> return "" +ping :: (Response -> IO ()) -> IO () -> IO () +ping run err = do + res <- fetch query + case res of + Left e -> continue (toResponseMsg e) err + Right r -> + let status = (ResponseCode . responseStatus) r + runner = run r + in destruct status runner err routine :: IO () routine = ping processRunner backupRunner main :: IO () -main = start routine +main = start >> routine diff --git a/app/Sugar.hs b/app/Sugar.hs index 4c6658e..1d2213a 100644 --- a/app/Sugar.hs +++ b/app/Sugar.hs @@ -13,10 +13,13 @@ throw e = print e >> return mempty continue :: (Status s) => s -> IO () -> IO () continue e err = (putStrLn . disp) e >> err +failure :: SomeException -> IO () +failure = print + destruct :: (Status s) => s -> IO () -> IO () -> IO () -destruct status success failure +destruct status success unsuccessful | ok status = success - | otherwise = continue status failure + | otherwise = continue status unsuccessful crash :: IO () crash = (exitWith . ExitFailure) 1 diff --git a/app/Time.hs b/app/Time.hs index 2594007..93d37c8 100644 --- a/app/Time.hs +++ b/app/Time.hs @@ -1,6 +1,9 @@ module Time where -import Pure (sunriseNext) +import Pure (buildCmd, sunriseNext) +import Cache (pathToConfig) +import Const (darkModeScript, lightModeScript) +import Sugar (exec) import Data.Time (ZonedTime, getCurrentTime) import Data.Time.Solar (Location(Location), sunrise, sunset) @@ -26,3 +29,16 @@ sunsetNow lat lon = do activateOnSunrise :: ZonedTime -> ZonedTime -> IO Bool activateOnSunrise sunriseTime sunsetTime = sunriseNext sunriseTime sunsetTime <$> now + +activate :: String -> ZonedTime -> String -> IO String +activate msg time script = do + putStr msg + print time + scriptPath <- pathToConfig script + exec (buildCmd scriptPath time) terminate + where terminate _ = print "Scheduling process failed" >> return "" + +chooseActivation :: Bool -> ZonedTime -> ZonedTime -> IO String +chooseActivation lightMode sunriseTime sunsetTime + | lightMode = activate "Light mode activation script scheduled for " sunriseTime lightModeScript + | otherwise = activate "Dark mode activation script scheduled for " sunsetTime darkModeScript diff --git a/app/Workers.hs b/app/Workers.hs new file mode 100644 index 0000000..de22849 --- /dev/null +++ b/app/Workers.hs @@ -0,0 +1,26 @@ +module Workers where + +import Time (chooseActivation, activateOnSunrise, sunriseNow, sunsetNow) +import Cache (finish, readCache) +import Sugar (crash, exec) + +prepareScripts :: (Double, Double) -> IO () +prepareScripts (lat, lon) = do + sunriseTime <- sunriseNow lat lon + sunsetTime <- sunsetNow lat lon + lightMode <- activateOnSunrise sunriseTime sunsetTime + _ <- chooseActivation lightMode sunriseTime sunsetTime + queue <- exec "atq" noQueue + finish queue + where + noQueueMsg = "Scheduled process could not be retrieved (try rerunning if 'atq' fails)" + noQueue _ = print noQueueMsg >> return "" + +backupRunner :: IO () +backupRunner = do + contents <- readCache + case contents of + Nothing -> do + putStrLn "Failed to read cache after IP location failed" + crash + Just (lat, lon, _) -> prepareScripts (lat, lon) diff --git a/suntheme.cabal b/suntheme.cabal index 9499d09..e8a3179 100644 --- a/suntheme.cabal +++ b/suntheme.cabal @@ -62,7 +62,7 @@ executable suntheme main-is: Main.hs -- Modules included in this executable, other than Main. - other-modules: Types, Const, Pure, Time, Sugar, Getters + other-modules: Types, Const, Pure, Time, Sugar, Getters, Cache, Workers -- LANGUAGE extensions used by modules in this package. -- other-extensions: