refactor: complete modularization

introduce Workers, Cache modules and shuffle around some existing functions
This commit is contained in:
q9i 2024-08-01 20:15:32 -07:00
parent 76973ba364
commit f22d715b8e
8 changed files with 131 additions and 105 deletions

51
app/Cache.hs Normal file
View file

@ -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

View file

@ -6,6 +6,12 @@ query = "http://ip-api.com/line/?fields=status,lat,lon,timezone"
prog :: String prog :: String
prog = "suntheme" prog = "suntheme"
cacheFile :: String
cacheFile = "data.txt"
logFile :: String
logFile = "log.txt"
lightModeScript :: String lightModeScript :: String
lightModeScript = "light.sh" lightModeScript = "light.sh"

View file

@ -1,17 +1,7 @@
module Getters where module Getters where
import Const (prog)
import System.FilePath ((</>))
import System.Directory (XdgDirectory(XdgCache, XdgConfig), getXdgDirectory)
import Control.Exception (SomeException, try) import Control.Exception (SomeException, try)
import Network.HTTP.Request (Response, get) 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 :: String -> IO (Either SomeException Response)
fetch = try . get fetch = try . get

View file

@ -5,37 +5,29 @@
module Main where module Main where
import Pure (buildCmd, readLines) import Pure (readLines)
import Time (activateOnSunrise, sunriseNow, sunsetNow) import Cache (dumpCache, start)
import Const (darkModeScript, lightModeScript, query) import Const (query)
import Sugar (continue, crash, destruct, exec, killall) import Sugar (continue, destruct)
import Types (ResponseCode(..), ResponseMsg(..), genericErr, toResponseMsg) 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 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)) import Network.HTTP.Request (Response(responseBody, responseStatus))
-- error handling -- error handling
-- refactor into modules -- clean up jank (
-- clean up jank (reduce lines in functions, more atomic/functional, etc) -- create types,
-- more pure functions,
-- reduce lines in functions,
-- more atomic/functional,
-- etc
-- )
-- eliminate as many do blocks as possible -- eliminate as many do blocks as possible
-- introduce liquid types and checking -- introduce liquid types and checking
-- whitepaper! -- 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 :: Response -> (Double -> Double -> String -> IO ()) -> IO () -> IO ()
process r run err = process r run err =
case info of case info of
@ -49,80 +41,22 @@ process r run err =
parts = (lines . unpack) body parts = (lines . unpack) body
info = (readLines . take 4) parts 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 :: 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 () ping :: (Response -> IO ()) -> IO () -> IO ()
backupRunner = do ping run err = do
contents <- readCache res <- fetch query
case contents of case res of
Nothing -> do Left e -> continue (toResponseMsg e) err
putStrLn "Failed to read cache after IP location failed" Right r ->
crash let status = (ResponseCode . responseStatus) r
Just (lat, lon, _) -> prepareScripts lat lon runner = run r
in destruct status runner err
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 ""
routine :: IO () routine :: IO ()
routine = ping processRunner backupRunner routine = ping processRunner backupRunner
main :: IO () main :: IO ()
main = start routine main = start >> routine

View file

@ -13,10 +13,13 @@ throw e = print e >> return mempty
continue :: (Status s) => s -> IO () -> IO () continue :: (Status s) => s -> IO () -> IO ()
continue e err = (putStrLn . disp) e >> err continue e err = (putStrLn . disp) e >> err
failure :: SomeException -> IO ()
failure = print
destruct :: (Status s) => s -> IO () -> IO () -> IO () destruct :: (Status s) => s -> IO () -> IO () -> IO ()
destruct status success failure destruct status success unsuccessful
| ok status = success | ok status = success
| otherwise = continue status failure | otherwise = continue status unsuccessful
crash :: IO () crash :: IO ()
crash = (exitWith . ExitFailure) 1 crash = (exitWith . ExitFailure) 1

View file

@ -1,6 +1,9 @@
module Time where 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 (ZonedTime, getCurrentTime)
import Data.Time.Solar (Location(Location), sunrise, sunset) import Data.Time.Solar (Location(Location), sunrise, sunset)
@ -26,3 +29,16 @@ sunsetNow lat lon = do
activateOnSunrise :: ZonedTime -> ZonedTime -> IO Bool activateOnSunrise :: ZonedTime -> ZonedTime -> IO Bool
activateOnSunrise sunriseTime sunsetTime = sunriseNext sunriseTime sunsetTime <$> now 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

26
app/Workers.hs Normal file
View file

@ -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)

View file

@ -62,7 +62,7 @@ executable suntheme
main-is: Main.hs main-is: Main.hs
-- Modules included in this executable, other than Main. -- 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. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions: