refactor: complete modularization

introduce Workers, Cache modules and shuffle around some existing functions

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

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"
 

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

app/Main.hs

@@ -5,37 +5,29 @@
 
 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 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 (
--- 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
 -- 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 ()
+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 = ping processRunner backupRunner
 
 main :: IO ()
-main = start routine
+main = start >> routine

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

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

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)

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: