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)
]
]
-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
projects / xyz.git / commitdiff
