From: Cameron Ball Date: Fri, 2 Aug 2019 09:52:24 +0000 (+0800) Subject: Refactor Main to use ExceptT X-Git-Url: http://cameron1729.xyz/?p=xyz.git;a=commitdiff_plain;h=33c82c0b55b3bc95be2824675c0eeb7e37ae8b2a Refactor Main to use ExceptT --- diff --git a/app/Main.hs b/app/Main.hs index 43ce0ba..4bfd2f2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -29,121 +29,114 @@ import Data.Bool (bool) import Data.Tuple.Curry (uncurryN) import qualified Data.ByteString.Lazy as BL import Config -import Control.Exception (catch, IOException) - -main :: IO () -main = getArgs >>= parse +import Control.Monad.Trans.Maybe +import Control.Monad.Except (throwError) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Control.Error.Safe +import Data.Bifunctor +import qualified Data.ByteString.Lazy.UTF8 as BLU getGlobalProjectDir :: IO FilePath -getGlobalProjectDir = getHomeDirectory >>= return . (++ "/.xyz") +getGlobalProjectDir = (++ "/.xyz") <$> getHomeDirectory getGlobalProjectConfigPath :: IO FilePath getGlobalProjectConfigPath = getGlobalProjectDir >>= return . (++ "/xyz.json") -getGlobalProjectConfig :: IO (Maybe GlobalConfig) -getGlobalProjectConfig = getGlobalProjectConfigPath >>= (\path -> doesFileExist path >>= bool (return Nothing) (BL.readFile path >>= return . decode)) +safeReadFile :: FilePath -> ExceptT Text IO Text +safeReadFile p = (lift $ doesFileExist p) >>= bool (throwError $ pack p +++ ": File does not exist") (lift $ pack <$> readFile p) + +safeDecodeJSONFile :: FromJSON a => FilePath -> ExceptT Text IO a +safeDecodeJSONFile f = safeReadFile f >>= (tryRight . first appendFileName . eitherDecode . BLU.fromString . unpack) + where appendFileName s = pack $ f ++ ": " ++ s + +getGlobalProjectConfig :: ExceptT Text IO GlobalConfig +getGlobalProjectConfig = lift path >>= safeDecodeJSONFile + where path = (++ "/xyz.json") <$> getGlobalProjectDir -getLocalProjectConfig :: IO (Maybe LocalConfig) -getLocalProjectConfig = doesFileExist "xyz.json" >>= bool (return Nothing) (BL.readFile "xyz.json" >>= return . decode) +getLocalProjectConfig :: ExceptT Text IO LocalConfig +getLocalProjectConfig = safeDecodeJSONFile "xyz.json" -safeReadFile :: FilePath -> IO (Maybe Text) -safeReadFile p = (Just . pack <$> readFile p) `catch` handler +getEntryTemplate :: Text -> ExceptT Text IO Template +getEntryTemplate t = template <$> (lift path >>= safeReadFile) + where path = (++ "/entry-" ++ (unpack t) ++ ".txt") <$> getGlobalProjectDir + +resolveProjectConfig :: ExceptT Text IO ProjectConfig +resolveProjectConfig = getProjectConfig <$> getGlobalProjectConfig <*> getLocalProjectConfig + +init :: ExceptT Text IO LocalConfig -> ExceptT Text IO GlobalConfig -> ExceptT Text IO Text +init local global = do + l <- lift $ runExceptT local + g <- lift $ runExceptT global + case (g, l) of + (_, Right _) -> pure "Project already initialised" + (Left _, Left _) -> globalInit >> localInit + (Right _, Left _) -> localInit where - handler :: IOException -> IO (Maybe Text) - handler = const $ pure Nothing - -getEntryTemplate :: Text -> IO (Maybe Template) -getEntryTemplate t = (pure $ fmap template) <*> (safeReadFile =<< ((++ "/entry-" ++ (unpack t) ++ ".txt")) <$> getGlobalProjectDir) - -resolveProjectConfig :: IO (Either Text ProjectConfig) -resolveProjectConfig = do - l <- getLocalProjectConfig - g <- getGlobalProjectConfig - - return $ case (l, g) of - (Just l, Just g) -> Right $ getProjectConfig g l - (Just _, Nothing) -> Left "Busted global config" - (Nothing, Just _) -> Left "Busted local config" - _ -> Left "All configs are busted" - -continueIfInvalidProject :: IO () -> IO () -continueIfInvalidProject next = doesFileExist "xyz.json" >>= bool next (putStrLn "Project already initialised") - -initGlobalIfNeeded :: IO () -> IO () -initGlobalIfNeeded next = getGlobalProjectConfigPath >>= doesFileExist >>= bool globalInit (return ()) >> next - -globalInit :: IO () -globalInit = do - home <- getHomeDirectory - putStrLn "\nWelcome to xyz! Looks like this is your first time here. Let's configure a few things...\n" - editor <- editorPrompt - vcs <- vcsPrompt - let pushCmdAndRemote = case vcs of - Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)] - Nothing -> [] - - getGlobalProjectConfigPath >>= flip writeFile (toStrict . encodeToLazyText $ GlobalConfig editor (lookup "pushCommand" pushCmdAndRemote) (lookup "remote" pushCmdAndRemote)) - putStrLn "\nThanks! Now let's continue with initialising your project...\n" - -init :: IO () -init = do - home <- getHomeDirectory - themes <- allFilesIn $ home ++ "/.xyz/themes" - projectSpec <- (\[x,y,z] -> (x, y, z, Nothing, Nothing, Nothing)) <$> fmap snd <$> initPrompt (map pack themes) - let localConfig = uncurryN LocalConfig projectSpec - writeFile "xyz.json" (toStrict . encodeToLazyText $ localConfig) - config <- resolveProjectConfig - - case config of - Right projectConfig -> do - createDirectory "entries" - - case (commitCommand (projectConfig :: ProjectConfig), gitRemote (projectConfig :: ProjectConfig)) of + globalInit = do + lift $ putStrLn "\nWelcome to xyz! Looks like this is your first time here. Let's configure a few things...\n" + editor <- lift editorPrompt + vcs <- lift vcsPrompt + let pushCmdAndRemote = case vcs of + Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)] + Nothing -> [] + + lift $ getGlobalProjectConfigPath >>= flip writeFile (toStrict . encodeToLazyText $ GlobalConfig editor (lookup "pushCommand" pushCmdAndRemote) (lookup "remote" pushCmdAndRemote)) + lift $ putStrLn "\nThanks! Now let's continue with initialising your project...\n" + + localInit = do + home <- lift $ getHomeDirectory + themes <- lift $ allFilesIn $ home ++ "/.xyz/themes" + projectSpec <- lift $ (\[x,y,z] -> (x, y, z, Nothing, Nothing, Nothing)) <$> fmap snd <$> initPrompt (map pack themes) + let localConfig = uncurryN LocalConfig projectSpec + lift $ writeFile "xyz.json" (toStrict . encodeToLazyText $ localConfig) + config <- resolveProjectConfig + lift $ createDirectory "entries" + + case (commitCommand (config :: ProjectConfig), gitRemote (config :: ProjectConfig)) of (Just cmd, Just remote) -> do - putStrLn "Initialising project with git" - mapM_ (callCommand . unpack . (+++ " > /dev/null 2>&1")) ["git init", "git remote add origin " +++ remote, "git add .", "git commit -m \"Initial commit\""] + lift $ putStrLn "Initialising project with git" + lift $ mapM_ (callCommand . unpack . (+++ " > /dev/null 2>&1")) ["git init", "git remote add origin " +++ remote, "git add .", "git commit -m \"Initial commit\""] (_, _) -> return() - putStrLn "Initialised empty project" - Left error -> do - putStrLn error + pure "Initialised empty project" -build :: ProjectConfig -> IO () -build config = allFilesIn "entries" >>= (writeOutProject config) >> putStrLn "Build successful" +build :: ProjectConfig -> ExceptT Text IO Text +build config = (lift $ allFilesIn "entries" >>= writeOutProject config) >> pure "Build successful" -entry :: ProjectConfig -> IO () +entry :: ProjectConfig -> ExceptT Text IO Text entry config = do - homeDir <- getHomeDirectory - entrySpec <- entryPrompt - entryNum <- fmap (show . (+1) . length) $ allFilesIn "entries" - stamp <- fmap (pack . show . round) getPOSIXTime - videoTemplate <- getEntryTemplate "video" - normalTemplate <- getEntryTemplate "normal" + homeDir <- lift getHomeDirectory + entrySpec <- lift entryPrompt + entryNum <- lift $ fmap (show . (+1) . length) $ allFilesIn "entries" + stamp <- lift $ fmap (pack . show . round) getPOSIXTime + videoTemplate <- getEntryTemplate $ "video" + normalTemplate <- getEntryTemplate $ "normal" let rawEntry = case entrySpec of Just (title, videoSpec) -> do let baseContext = [("timestamp", stamp), ("title", title)] case videoSpec of -- TODO: Properly handle the Maybes for video and normal templates - Just (videoId, videoFilename) -> (title, toStrict . render (fromJust videoTemplate) $ context $ baseContext ++ [("videoid", videoId), ("videofilename", videoFilename)]) - Nothing -> (title, toStrict . render (fromJust normalTemplate) $ context baseContext) + Just (videoId, videoFilename) -> (title, toStrict . render videoTemplate $ context $ baseContext ++ [("videoid", videoId), ("videofilename", videoFilename)]) + Nothing -> (title, toStrict . render normalTemplate $ context baseContext) let fileName = "entries/" ++ entryNum ++ "-" ++ (unpack . slugify $ fst rawEntry) ++ ".txt" - writeFile fileName $ snd rawEntry + lift $ writeFile fileName $ snd rawEntry - callCommand $ (unpack (editor (config :: ProjectConfig))) ++ " " ++ fileName + lift $ callCommand $ (unpack (editor (config :: ProjectConfig))) ++ " " ++ fileName build config - push <- pushPrompt + push <- lift pushPrompt case push of True -> do - callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push" + lift $ callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push" False -> return () - putStrLn "\nThanks for using xyz!" + pure "\nThanks for using xyz!" -config :: ProjectConfig -> IO () -config config = (putStrLn "\nProject details:\n") >> (putStr . unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where +config :: ProjectConfig -> ExceptT Text IO Text +config config = pure $ "\nProject details:\n" +++ (unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where n = name (config :: ProjectConfig) d = description (config :: ProjectConfig) t = theme (config :: ProjectConfig) @@ -163,16 +156,19 @@ usage = putStr . ununlines $ [ ] ] -continueIfValidProject :: (ProjectConfig -> IO ()) -> Either Text ProjectConfig -> IO () -continueIfValidProject next projectConfig = case projectConfig of - Right config -> next config - Left error -> putStrLn $ "This does not appear to be a vailid project directory: " +++ error +runExceptTAndOutput :: ExceptT Text IO Text -> IO () +runExceptTAndOutput e = do + result <- runExceptT e + case result of + Left error -> putStrLn error >> (exitWith $ ExitFailure 1) + Right output -> putStrLn output >> exitWith ExitSuccess -parse ["init"] = initGlobalIfNeeded (continueIfInvalidProject init) >> exitSuccess -parse ["build"] = resolveProjectConfig >>= (continueIfValidProject build) >> exitSuccess -parse ["entry"] = resolveProjectConfig >>= (continueIfValidProject entry) >> exitSuccess -parse ["config"] = resolveProjectConfig >>= (continueIfValidProject config) >> exitSuccess -parse [_] = usage >> exit -parse [] = usage >> exit +main :: IO () +main = getArgs >>= parse -exit = exitWith ExitSuccess +parse ["init"] = runExceptTAndOutput $ init getLocalProjectConfig getGlobalProjectConfig +parse ["build"] = runExceptTAndOutput $ resolveProjectConfig >>= build +parse ["entry"] = runExceptTAndOutput $ resolveProjectConfig >>= entry +parse ["config"] = runExceptTAndOutput $ resolveProjectConfig >>= config +parse [_] = usage +parse [] = usage diff --git a/package.yaml b/package.yaml index bd718e3..96e0fc0 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,10 @@ dependencies: - aeson - bytestring - tuple +- transformers +- utf8-string +- mtl +- errors library: source-dirs: src