Explicit Tree type for use in checkout

3 files changed, 24 insertions, 17 deletions

diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
index c180a34..1859c05 100644
--- a/src/Command/Checkout.hs
+++ b/src/Command/Checkout.hs
@@ -30,5 +30,5 @@ instance Command CheckoutCommand where
 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 "."
+    tree <- maybe (fail $ T.unpack $ "revision `" <> revision <> "' not found") getCommitTree =<< readCommit repo revision
+    checkoutAt tree "."
diff --git a/src/Job.hs b/src/Job.hs
index cf7dde8..261d038 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -180,10 +180,10 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case
 
 runJobs :: JobManager -> Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ]
 runJobs mngr@JobManager {..} commit jobs = do
-    treeId <- getTreeId commit
+    tree <- getCommitTree commit
     results <- atomically $ do
         forM jobs $ \job -> do
-            let jid = JobId [ JobIdTree treeId, JobIdName (jobName job) ]
+            let jid = JobId [ JobIdTree (treeId tree), JobIdName (jobName job) ]
             tid <- reserveTaskId mngr
             managed <- readTVar jmJobs
             ( job, tid, ) <$> case M.lookup jid managed of
@@ -282,10 +282,10 @@ updateStatusFile path outVar = void $ liftIO $ forkIO $ loop Nothing
 prepareJob :: (MonadIO m, MonadMask m, MonadFail m) => FilePath -> Commit -> Job -> (FilePath -> FilePath -> m a) -> m a
 prepareJob dir commit job inner = do
     withSystemTempDirectory "minici" $ \checkoutPath -> do
-        checkoutAt commit checkoutPath
-        tid <- getTreeId commit
+        tree <- getCommitTree commit
+        checkoutAt tree checkoutPath
 
-        let jdir = dir </> "jobs" </> showTreeId tid </> stringJobName (jobName job)
+        let jdir = dir </> "jobs" </> showTreeId (treeId tree) </> stringJobName (jobName job)
         liftIO $ createDirectoryIfMissing True jdir
 
         inner checkoutPath jdir
diff --git a/src/Repo.hs b/src/Repo.hs
index 71fcca5..0720179 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -4,6 +4,7 @@ module Repo (
     RepoName(..), textRepoName, showRepoName,
     Commit, commitId,
     CommitId, textCommitId, showCommitId,
+    Tree, treeId, treeRepo,
     TreeId, textTreeId, showTreeId,
     Tag(..),
 
@@ -14,7 +15,7 @@ module Repo (
     listCommits,
     findUpstreamRef,
 
-    getTreeId,
+    getCommitTree,
     getCommitTitle,
     getCommitMessage,
 
@@ -82,11 +83,16 @@ commitId :: Commit -> CommitId
 commitId = commitId_
 
 data CommitDetails = CommitDetails
-    { commitTreeId :: TreeId
+    { commitTree :: Tree
     , commitTitle :: Text
     , commitMessage :: Text
     }
 
+data Tree = Tree
+    { treeRepo :: Repo
+    , treeId :: TreeId
+    }
+
 data Tag a = Tag
     { tagTag :: Text
     , tagObject :: a
@@ -220,15 +226,17 @@ getCommitDetails Commit {..} = do
                     runGitCommand commitRepo [ "cat-file", "commit", showCommitId commitId_ ]
                 let info = map (fmap (drop 1) . span (/= ' ')) infoPart
 
-                Just commitTreeId <- return $ TreeId . BC.pack <$> lookup "tree" info
+                Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info
+                let treeRepo = commitRepo
+                let commitTree = Tree {..}
                 let commitTitle = T.pack title
                 let commitMessage = T.pack $ unlines $ dropWhile null message
 
                 let details = CommitDetails {..}
                 return ( Just details, details )
 
-getTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId
-getTreeId = fmap commitTreeId . getCommitDetails
+getCommitTree :: (MonadIO m, MonadFail m) => Commit -> m Tree
+getCommitTree = fmap commitTree . getCommitDetails
 
 getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text
 getCommitTitle = fmap commitTitle . getCommitDetails
@@ -237,10 +245,9 @@ getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text
 getCommitMessage = fmap commitMessage . getCommitDetails
 
 
-checkoutAt :: (MonadIO m, MonadFail m) => Commit -> FilePath -> m ()
-checkoutAt commit@Commit {..} dest = do
-    let GitRepo {..} = commitRepo
-    tid <- getTreeId commit
+checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
+checkoutAt Tree {..} dest = do
+    let GitRepo {..} = treeRepo
     liftIO $ withMVar gitLock $ \_ -> withSystemTempFile "minici-checkout.index" $ \index _ -> do
         let gitProc args = (proc "git" args)
                 { env = Just
@@ -249,7 +256,7 @@ checkoutAt commit@Commit {..} dest = do
                     , ( "GIT_WORK_TREE", "." )
                     ]
                 }
-        "" <- readCreateProcess (gitProc [ "read-tree", showTreeId tid ]) ""
+        "" <- readCreateProcess (gitProc [ "read-tree", showTreeId treeId ]) ""
         "" <- readCreateProcess (gitProc [ "checkout-index", "--all", "--prefix=" <> addTrailingPathSeparator dest ]) ""
         return ()