diff --git a/app/Main.hs b/app/Main.hs index 2be7bac..3c43d4c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,15 +5,14 @@ module Main where -import Pure (buildCmd, kill, readLines) +import Pure (buildCmd, readLines) import Time (activateOnSunrise, sunriseNow, sunsetNow) import Const (darkModeScript, lightModeScript, prog, query) -import Types (ResponseMsg(..), ResponseCode(..), Status(..), genericErr, toResponseMsg) +import Sugar (continue, crash, destruct, exec, killall) +import Types (ResponseMsg(..), ResponseCode(..), genericErr, toResponseMsg) import Data.List.Extra ((!?)) 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) @@ -39,19 +38,11 @@ pathToConfig str = do 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 + Left e -> continue (toResponseMsg e) err Right r -> let status = (ResponseCode . responseStatus) r runner = run r @@ -60,7 +51,7 @@ ping run err = do 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 @@ -91,9 +82,6 @@ readCache = do processRunner :: Response -> IO () processRunner r = process r dumpCache backupRunner -crash :: IO () -crash = exitWith (ExitFailure 1) - backupRunner :: IO () backupRunner = do contents <- readCache @@ -103,16 +91,6 @@ backupRunner = do crash Just (lat, lon, _) -> prepareScripts lat lon -exec :: String -> (SomeException -> IO String) -> IO String -exec cmd err = do catch (readProcess "bash" ["-c", cmd] "") err - -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" @@ -120,7 +98,7 @@ start act = do if existsLog then do contents <- readFile logFile let entries = lines contents - killall entries + (sequence_ . killall) entries else createDirectoryIfMissing True (takeDirectory logFile) act diff --git a/app/Sugar.hs b/app/Sugar.hs new file mode 100644 index 0000000..4c6658e --- /dev/null +++ b/app/Sugar.hs @@ -0,0 +1,28 @@ +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 + +destruct :: (Status s) => s -> IO () -> IO () -> IO () +destruct status success failure + | ok status = success + | otherwise = continue status failure + +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/suntheme.cabal b/suntheme.cabal index 2f3e41c..0c421aa 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 + other-modules: Types, Const, Pure, Time, Sugar -- LANGUAGE extensions used by modules in this package. -- other-extensions: