Merge f22d715b8e into 546de7273f

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

@@ -0,0 +1,19 @@
+module Const where
+
+query :: String
+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"
+
+darkModeScript :: String
+darkModeScript = "dark.sh"

app/Getters.hs

@@ -0,0 +1,7 @@
+module Getters where
+
+import Control.Exception (SomeException, try)
+import Network.HTTP.Request (Response, get)
+
+fetch :: String -> IO (Either SomeException Response)
+fetch = try . get

app/Main.hs

@@ -5,124 +5,33 @@
 
 module Main where
 
-import Data.Time (ZonedTime, getCurrentTime)
+import Pure (readLines)
-import Data.Time.Solar (Location(Location), sunrise, sunset)
+import Cache (dumpCache, start)
-import Data.Time.RFC3339 (formatTimeRFC3339)
+import Const (query)
-import Data.Time.LocalTime (getTimeZone, utcToZonedTime, zonedTimeToUTC)
+import Sugar (continue, destruct)
-import Data.List.Extra ((!?))
+import Types (ResponseCode(..), ResponseMsg(..), genericErr, toResponseMsg)
+import Getters (fetch)
+import Workers (backupRunner, prepareScripts)
+
 import Data.ByteString.Char8 (unpack)
-import System.Exit (ExitCode(ExitFailure), exitWith)
+import Network.HTTP.Request (Response(responseBody, responseStatus))
-import System.Process (readProcess)
-import System.FilePath ((</>), takeDirectory)
-import System.Directory (XdgDirectory(XdgCache, XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
-import Control.Exception (SomeException, catch, try)
-import Network.HTTP.Request (Response(responseBody, responseStatus), get)
 
 -- 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!
 
-class Status s where
-    ok :: s -> Bool
-    ok = const False
-
-    disp :: s -> String
-    disp = const "encountered bad response (expected OK)"
-
-newtype ResponseCode = ResponseCode Int
-instance Status ResponseCode where
-    ok (ResponseCode code) = code == 200
-    disp (ResponseCode code) =
-        "encountered bad response code: "
-        ++ show code
-        ++ " (expected 200 'OK')"
-
-newtype ResponseMsg = ResponseMsg String
-instance Status ResponseMsg where
-    ok (ResponseMsg msg) = msg == "success"
-    disp (ResponseMsg msg) =
-        "encountered bad response message: "
-        ++ msg
-        ++ " (expected 'success')"
-
-toResponseMsg :: SomeException -> ResponseMsg
-toResponseMsg = ResponseMsg . show
-
-query :: String
-query = "http://ip-api.com/line/?fields=status,lat,lon,timezone"
-
-genericErr :: ResponseMsg
-genericErr = ResponseMsg "encountered unknown error"
-
-prog :: String
-prog = "suntheme"
-
-lightModeScript :: String
-lightModeScript = "light.sh"
-
-darkModeScript :: String
-darkModeScript = "dark.sh"
-
-now :: IO ZonedTime
-now = do
-    utcTime <- getCurrentTime
-    timeZone <- getTimeZone utcTime
-    return (utcToZonedTime timeZone utcTime)
-
-sunriseNow :: Double -> Double -> IO ZonedTime
-sunriseNow lat lon = do
-    time <- now
-    return (sunrise time here)
-    where here = Location lat lon
-
-sunsetNow :: Double -> Double -> IO ZonedTime
-sunsetNow lat lon = do
-    time <- now
-    return (sunset time here)
-    where here = Location lat lon
-
-pathToCache :: String -> IO String
-pathToCache str = do
-    dir <- getXdgDirectory XdgCache prog
-    return (dir </> str)
-
-pathToConfig :: String -> IO String
-pathToConfig str = do
-    dir <- getXdgDirectory XdgConfig prog
-    return (dir </> str)
-
-fetch :: String -> IO (Either SomeException Response)
-fetch = try . get
-
-cont :: (Status s) => s -> IO () -> IO ()
-cont e err = (putStrLn . disp) e >> err
-
-destruct :: (Status s) => s -> IO () -> IO () -> IO ()
-destruct status success failure
-    | ok status = success
-    | otherwise = cont status failure
-
-ping :: (Response -> IO ()) -> IO () -> IO ()
-ping run err = do
-    res <- fetch query
-    case res of
-        Left e -> cont (toResponseMsg e) err
-        Right r ->
-            let status = (ResponseCode . responseStatus) r
-                runner = run r
-            in destruct status runner err
-
-readLines :: [String] -> Maybe (String, Double, Double, String)
-readLines [msg, latStr, lonStr, tz] = Just (msg, read latStr, read lonStr, tz)
-readLines _ = Nothing
-
 process :: Response -> (Double -> Double -> String -> IO ()) -> IO () -> IO ()
 process r run err =
     case info of
-        Nothing -> cont genericErr err
+        Nothing -> continue genericErr err
         Just (msg, lat, lon, tz) ->
             let status = ResponseMsg msg
                 runner = run lat lon tz
@@ -132,114 +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
 
-crash :: IO ()
+ping :: (Response -> IO ()) -> IO () -> IO ()
-crash = exitWith (ExitFailure 1)
+ping run err = do
-
+    res <- fetch query
-backupRunner :: IO ()
+    case res of
-backupRunner = do
+        Left e -> continue (toResponseMsg e) err
-    contents <- readCache
+        Right r ->
-    case contents of
+            let status = (ResponseCode . responseStatus) r
-        Nothing -> do
+                runner = run r
-            putStrLn "Failed to read cache after IP location failed"
+            in destruct status runner err
-            crash
-        Just (lat, lon, _) -> prepareScripts lat lon
-
-exec :: String -> (SomeException -> IO String) -> IO String
-exec cmd err = do catch (readProcess "bash" ["-c", cmd] "") err
-
-kill :: String -> String
-kill = (++) "atrm "
-
-killall :: [String] -> IO ()
-killall = foldr ((>>) . dispatch . kill) (return ())
-    where
-        dispatch cmd = exec cmd failure
-        failure :: SomeException -> IO String
-        failure e = print e >> return []
-
-start :: IO () -> IO ()
-start act = do
-    logFile <- pathToCache "log.txt"
-    existsLog <- doesFileExist logFile
-    if existsLog then do
-        contents <- readFile logFile
-        let entries = lines contents
-        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 ()
-
-after :: (Eq a) => a -> [a] -> [a]
-after c = drop 1 . dropWhile (/= c)
-
-formatTime :: ZonedTime -> String
-formatTime = take 5 . after 'T' . formatTimeRFC3339
-
-buildCmd :: String -> ZonedTime -> String
-buildCmd script time = "echo \"" ++ script ++ "\" | at " ++ formatTime time
-
-activateOnSunrise :: ZonedTime -> ZonedTime -> IO Bool
-activateOnSunrise sunriseTime sunsetTime = do
-    timeNow <- now
-    let utcTimeNow = zonedTimeToUTC timeNow
-        utcSunrise = zonedTimeToUTC sunriseTime
-        utcSunset = zonedTimeToUTC sunsetTime
-    if utcTimeNow < utcSunrise || utcTimeNow > utcSunset then return True
-    else return False
-
-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/Pure.hs

@@ -0,0 +1,28 @@
+module Pure where
+
+import Data.Time (ZonedTime)
+import Data.Time.RFC3339 (formatTimeRFC3339)
+import Data.Time.LocalTime (zonedTimeToUTC)
+
+readLines :: [String] -> Maybe (String, Double, Double, String)
+readLines [msg, latStr, lonStr, tz] = Just (msg, read latStr, read lonStr, tz)
+readLines _ = Nothing
+
+kill :: String -> String
+kill = (++) "atrm "
+
+after :: (Eq a) => a -> [a] -> [a]
+after c = drop 1 . dropWhile (/= c)
+
+formatTime :: ZonedTime -> String
+formatTime = take 5 . after 'T' . formatTimeRFC3339
+
+buildCmd :: String -> ZonedTime -> String
+buildCmd script time = "echo \"" ++ script ++ "\" | at " ++ formatTime time
+
+sunriseNext :: ZonedTime -> ZonedTime -> ZonedTime -> Bool
+sunriseNext sunriseTime sunsetTime time = 
+    let utcTimeNow = zonedTimeToUTC time
+        utcSunrise = zonedTimeToUTC sunriseTime
+        utcSunset = zonedTimeToUTC sunsetTime 
+    in utcTimeNow < utcSunrise || utcTimeNow > utcSunset

app/Sugar.hs

@@ -0,0 +1,31 @@
+module Sugar where
+
+import Pure (kill)
+import Types (Status(..))
+
+import System.Exit (ExitCode(ExitFailure), exitWith)
+import System.Process (readProcess)
+import Control.Exception (SomeException, catch)
+
+throw :: (Monoid m) => SomeException -> IO m
+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 unsuccessful
+    | ok status = success
+    | otherwise = continue status unsuccessful
+
+crash :: IO ()
+crash = (exitWith . ExitFailure) 1
+
+exec :: String -> (SomeException -> IO String) -> IO String
+exec cmd = catch (readProcess "bash" ["-c", cmd] "")
+
+killall :: [String] -> [IO String]
+killall = map (dispatch . kill) where dispatch cmd = exec cmd throw

app/Time.hs

@@ -0,0 +1,44 @@
+module Time where
+
+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)
+import Data.Time.LocalTime (getTimeZone, utcToZonedTime)
+
+now :: IO ZonedTime
+now = do
+    utcTime <- getCurrentTime
+    timeZone <- getTimeZone utcTime
+    return (utcToZonedTime timeZone utcTime)
+
+sunriseNow :: Double -> Double -> IO ZonedTime
+sunriseNow lat lon = do
+    time <- now
+    return (sunrise time here)
+    where here = Location lat lon
+
+sunsetNow :: Double -> Double -> IO ZonedTime
+sunsetNow lat lon = do
+    time <- now
+    return (sunset time here)
+    where here = Location lat lon
+
+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/Types.hs

@@ -0,0 +1,32 @@
+module Types where
+
+import Control.Exception (SomeException)
+
+class Status s where
+    ok :: s -> Bool
+    ok = const False
+
+    disp :: s -> String
+    disp = const "encountered bad response (expected OK)"
+
+newtype ResponseCode = ResponseCode Int
+instance Status ResponseCode where
+    ok (ResponseCode code) = code == 200
+    disp (ResponseCode code) =
+        "encountered bad response code: "
+        ++ show code
+        ++ " (expected 200 'OK')"
+
+newtype ResponseMsg = ResponseMsg String
+instance Status ResponseMsg where
+    ok (ResponseMsg msg) = msg == "success"
+    disp (ResponseMsg msg) =
+        "encountered bad response message: "
+        ++ msg
+        ++ " (expected 'success')"
+
+toResponseMsg :: SomeException -> ResponseMsg
+toResponseMsg = ResponseMsg . show
+
+genericErr :: ResponseMsg
+genericErr = ResponseMsg "encountered unknown error"

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,22 +62,22 @@ executable suntheme
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    -- other-modules:
+    other-modules:    Types, Const, Pure, Time, Sugar, Getters, Cache, Workers
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
 
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.17.2.1,
-        request ^>=0.2.2.0, 
+                      request ^>=0.2.2.0, 
-        process ^>=1.6.18.0,
+                      process ^>=1.6.18.0,
-        bytestring ^>=0.11.5.3,
+                      bytestring ^>=0.11.5.3,
-        filepath ^>=1.4.2.2,
+                      filepath ^>=1.4.2.2,
-        time ^>=1.9.3,
+                      time ^>=1.9.3,
-        solar ^>=0.1.0.0,
+                      solar ^>=0.1.0.0,
-        timerep ^>=2.1.0.0,
+                      timerep ^>=2.1.0.0,
-        extra ^>=1.7.16,
+                      extra ^>=1.7.16,
-        directory ^>=1.3.8.5
+                      directory ^>=1.3.8.5
 
     -- Directories containing source files.
     hs-source-dirs:   app