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 new file mode 100644 index 0000000..3af5223 --- /dev/null +++ b/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" diff --git a/app/Getters.hs b/app/Getters.hs new file mode 100644 index 0000000..6239d4d --- /dev/null +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 94f69de..9d4ac6b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,124 +5,33 @@ module Main where -import Data.Time (ZonedTime, getCurrentTime) -import Data.Time.Solar (Location(Location), sunrise, sunset) -import Data.Time.RFC3339 (formatTimeRFC3339) -import Data.Time.LocalTime (getTimeZone, utcToZonedTime, zonedTimeToUTC) -import Data.List.Extra ((!?)) +import Pure (readLines) +import Cache (dumpCache, start) +import Const (query) +import Sugar (continue, destruct) +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 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) +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! -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 () -crash = exitWith (ExitFailure 1) - -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 - -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 "" +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/Pure.hs b/app/Pure.hs new file mode 100644 index 0000000..fba5ece --- /dev/null +++ b/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 diff --git a/app/Sugar.hs b/app/Sugar.hs new file mode 100644 index 0000000..1d2213a --- /dev/null +++ b/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 diff --git a/app/Time.hs b/app/Time.hs new file mode 100644 index 0000000..93d37c8 --- /dev/null +++ b/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 diff --git a/app/Types.hs b/app/Types.hs new file mode 100644 index 0000000..5601caa --- /dev/null +++ b/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" 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 fef2dfb..e8a3179 100644 --- a/suntheme.cabal +++ b/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, - process ^>=1.6.18.0, - bytestring ^>=0.11.5.3, - filepath ^>=1.4.2.2, - time ^>=1.9.3, - solar ^>=0.1.0.0, - timerep ^>=2.1.0.0, - extra ^>=1.7.16, - directory ^>=1.3.8.5 + request ^>=0.2.2.0, + process ^>=1.6.18.0, + bytestring ^>=0.11.5.3, + filepath ^>=1.4.2.2, + time ^>=1.9.3, + solar ^>=0.1.0.0, + timerep ^>=2.1.0.0, + extra ^>=1.7.16, + directory ^>=1.3.8.5 -- Directories containing source files. hs-source-dirs: app