Checkout command

Changelog: Added `checkout` command

5 files changed, 131 insertions, 15 deletions

diff --git a/minici.cabal b/minici.cabal
index fc3c3da..7c05311 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -48,6 +48,7 @@ executable minici
 
     other-modules:
         Command
+        Command.Checkout
         Command.Run
         Config
         Job
diff --git a/src/Command.hs b/src/Command.hs
index 2114d90..8ca0655 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -10,6 +10,7 @@ module Command (
     getCommonOptions,
     getConfigPath,
     getConfig,
+    getRepo, getDefaultRepo,
     getTerminalOutput,
 ) where
 
@@ -25,15 +26,18 @@ import System.Exit
 import System.IO
 
 import Config
+import Repo
 import Terminal
 
 data CommonOptions = CommonOptions
     { optJobs :: Int
+    , optRepo :: [ DeclaredRepo ]
     }
 
 defaultCommonOptions :: CommonOptions
 defaultCommonOptions = CommonOptions
     { optJobs = 2
+    , optRepo = []
     }
 
 class CommandArgumentsType (CommandArguments c) => Command c where
@@ -79,10 +83,16 @@ instance CommandArgumentsType [ Text ] where
 newtype CommandExec a = CommandExec (ReaderT CommandInput IO a)
     deriving (Functor, Applicative, Monad, MonadIO)
 
+instance MonadFail CommandExec where
+    fail err = liftIO $ do
+        hPutStrLn stderr err
+        exitFailure
+
 data CommandInput = CommandInput
     { ciOptions :: CommonOptions
     , ciConfigPath :: Maybe FilePath
     , ciConfig :: Either String Config
+    , ciRepos :: [ ( Maybe RepoName, Repo ) ]
     , ciTerminalOutput :: TerminalOutput
     }
 
@@ -92,18 +102,26 @@ getCommonOptions = CommandExec (asks ciOptions)
 getConfigPath :: CommandExec FilePath
 getConfigPath = CommandExec $ do
     asks ciConfigPath >>= \case
-        Nothing -> liftIO $ do
-            hPutStrLn stderr "no job file found"
-            exitFailure
+        Nothing -> fail $ "no job file found"
         Just path -> return path
 
 getConfig :: CommandExec Config
 getConfig = CommandExec $ do
     asks ciConfig >>= \case
-        Left err -> liftIO $ do
-            hPutStrLn stderr err
-            exitFailure
+        Left err -> fail err
         Right config -> return config
 
+getRepo :: RepoName -> CommandExec Repo
+getRepo name = CommandExec $ do
+    asks (lookup (Just name) . ciRepos) >>= \case
+        Just repo -> return repo
+        Nothing -> fail $ "repo `" <> showRepoName name <> "' not declared"
+
+getDefaultRepo :: CommandExec Repo
+getDefaultRepo = CommandExec $ do
+    asks (lookup Nothing . ciRepos) >>= \case
+        Just repo -> return repo
+        Nothing -> fail $ "no defalut repo"
+
 getTerminalOutput :: CommandExec TerminalOutput
 getTerminalOutput = CommandExec (asks ciTerminalOutput)
diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
new file mode 100644
index 0000000..c180a34
--- /dev/null
+++ b/src/Command/Checkout.hs
@@ -0,0 +1,34 @@
+module Command.Checkout (
+    CheckoutCommand,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Command
+import Repo
+
+
+data CheckoutCommand = CheckoutCommand (Maybe RepoName) Text
+
+instance Command CheckoutCommand where
+    commandName _ = "checkout"
+    commandDescription _ = "Checkout (part of) a given repository"
+
+    type CommandArguments CheckoutCommand = [ Text ]
+
+    commandUsage _ = T.pack $ unlines $
+        [ "Usage: minici checkout [<repo> [<revision>]] [<option>...]"
+        ]
+
+    commandInit _ _ = \case
+        (name : revision : _) -> CheckoutCommand (Just (RepoName name)) revision
+        [ name ] -> CheckoutCommand (Just (RepoName name)) "HEAD"
+        [] -> CheckoutCommand Nothing "HEAD"
+    commandExec = cmdCheckout
+
+cmdCheckout :: CheckoutCommand -> CommandExec ()
+cmdCheckout (CheckoutCommand name revision) = do
+    repo <- maybe getDefaultRepo getRepo name
+    commit <- maybe (fail $ T.unpack $ "revision `" <> revision <> "' not found") return =<< readCommit repo revision
+    checkoutAt commit "."
diff --git a/src/Main.hs b/src/Main.hs
index 6a7cf8d..f86bd77 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -16,8 +16,10 @@ import System.FilePath
 import System.IO
 
 import Command
+import Command.Checkout
 import Command.Run
 import Config
+import Repo
 import Terminal
 import Version
 
@@ -34,17 +36,28 @@ defaultCmdlineOptions = CmdlineOptions
     , optCommon = defaultCommonOptions
     }
 
-options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]
+options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ]
 options =
-    [ Option ['h'] ["help"]
-        (NoArg $ \opts -> opts { optShowHelp = True })
+    [ Option [ 'h' ] [ "help" ]
+        (NoArg $ \opts -> return opts { optShowHelp = True })
         "show this help and exit"
-    , Option ['V'] ["version"]
-        (NoArg $ \opts -> opts { optShowVersion = True })
+    , Option [ 'V' ] [ "version" ]
+        (NoArg $ \opts -> return opts { optShowVersion = True })
         "show version and exit"
-    , Option ['j'] ["jobs"]
-        (ReqArg (\num opts -> opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>")
+    , Option [ 'j' ] [ "jobs" ]
+        (ReqArg (\num opts -> return opts { optCommon = (optCommon opts) { optJobs = read num }}) "<num>")
         ("number of jobs to run simultaneously (default " <> show (optJobs defaultCommonOptions) <> ")")
+    , Option [] [ "repo" ]
+        (ReqArg (\value opts ->
+            case span (/= ':') value of
+                ( repo, ':' : path ) -> return opts
+                    { optCommon = (optCommon opts)
+                        { optRepo = DeclaredRepo (RepoName $ T.pack repo) path : optRepo (optCommon opts)
+                        }
+                    }
+                _ -> throwError $ "--repo: invalid value `" <> value <> "'"
+        ) "<repo>:<path>")
+        ("override or declare repo path")
     ]
 
 data SomeCommandType = forall c. Command c => SC (Proxy c)
@@ -52,6 +65,7 @@ data SomeCommandType = forall c. Command c => SC (Proxy c)
 commands :: [ SomeCommandType ]
 commands =
     [ SC $ Proxy @RunCommand
+    , SC $ Proxy @CheckoutCommand
     ]
 
 lookupCommand :: String -> Maybe SomeCommandType
@@ -68,7 +82,17 @@ main = do
             _ -> ( Nothing, args )
 
     (opts, cmdargs) <- case getOpt RequireOrder options args' of
-        (o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
+        (os, cmdargs, []) -> do
+            let merge :: ([String], CmdlineOptions) -> (CmdlineOptions -> Except String CmdlineOptions) -> ([String], CmdlineOptions)
+                merge ( errs, o ) f = case runExcept $ f o of
+                    Left err -> ( err : errs, o )
+                    Right o' -> ( errs, o' )
+
+            case foldl merge ( [], defaultCmdlineOptions ) os of
+                ( [], opts ) -> return ( opts , cmdargs )
+                ( errs, _ ) -> do
+                    hPutStrLn stderr $ unlines (reverse errs) <> "Try `minici --help' for more information."
+                    exitFailure
         (_, _, errs) -> do
             hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
             exitFailure
@@ -159,5 +183,19 @@ runSomeCommand ciConfigPath ciOptions (SC tproxy) args = do
 
     let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
     let CommandExec exec = commandExec cmd
+
+    namedRepos <- forM (optRepo ciOptions) $ \decl -> do
+        openRepo (repoPath decl) >>= \case
+            Just repo -> return ( Just (repoName decl), repo )
+            Nothing -> do
+                hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl
+                exitFailure
+
+    defaultRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath
+    let ciRepos = concat
+            [ maybe [] (\r -> [ ( Nothing, r ) ]) defaultRepo
+            , namedRepos
+            ]
+
     ciTerminalOutput <- initTerminalOutput
     flip runReaderT CommandInput {..} exec
diff --git a/src/Repo.hs b/src/Repo.hs
index c8e818c..1053248 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -1,10 +1,14 @@
 module Repo (
-    Repo, Commit, commitId,
+    Repo,
+    DeclaredRepo(..),
+    RepoName(..), textRepoName, showRepoName,
+    Commit, commitId,
     CommitId, textCommitId, showCommitId,
     TreeId, textTreeId, showTreeId,
     Tag(..),
 
     openRepo,
+    readCommit,
     readBranch,
     readTag,
     listCommits,
@@ -53,6 +57,21 @@ data Repo
         , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ])
         }
 
+data DeclaredRepo = DeclaredRepo
+    { repoName :: RepoName
+    , repoPath :: FilePath
+    }
+
+newtype RepoName = RepoName Text
+    deriving (Eq, Ord)
+
+textRepoName :: RepoName -> Text
+textRepoName (RepoName text) = text
+
+showRepoName :: RepoName -> String
+showRepoName = T.unpack . textRepoName
+
+
 data Commit = Commit
     { commitRepo :: Repo
     , commitId_ :: CommitId
@@ -133,6 +152,12 @@ mkCommit commitRepo commitId_ = do
     commitDetails <- newMVar Nothing
     return $ Commit {..}
 
+readCommit :: MonadIO m => Repo -> Text -> m (Maybe Commit)
+readCommit repo@GitRepo {..} ref = liftIO $ do
+    readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{commit}" ] "" >>= \case
+        ( ExitSuccess, out, _ ) | cid : _ <- lines out -> Just <$> mkCommit repo (CommitId $ BC.pack cid)
+        _                                              -> return Nothing
+
 readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit)
 readCommitFromFile repo@GitRepo {..} path = liftIO $ do
     try @IOException (BC.readFile $ gitDir </> path) >>= \case