Fix extrating subtree hash in a bare repository

Changelog: Fix getting (sub)directory in a bare repository

3 files changed, 39 insertions, 10 deletions

diff --git a/src/Command/Subtree.hs b/src/Command/Subtree.hs
index 8d42d73..15cb2db 100644
--- a/src/Command/Subtree.hs
+++ b/src/Command/Subtree.hs
@@ -44,3 +44,4 @@ cmdSubtree (SubtreeCommand SubtreeOptions args) = do
 
     subtree <- getSubtree Nothing (T.unpack path) =<< readTree repo subdir tree
     outputMessage out $ textTreeId $ treeId subtree
+    outputEvent out $ TestMessage $ "path " <> T.pack (treeSubdir subtree)
diff --git a/src/Repo.hs b/src/Repo.hs
index 98178e6..b154209 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -280,15 +280,19 @@ getCommitMessage = fmap commitMessage . getCommitDetails
 getSubtree :: (MonadIO m, MonadFail m) => Maybe Commit -> FilePath -> Tree -> m Tree
 getSubtree mbCommit path tree = liftIO $ do
     let GitRepo {..} = treeRepo tree
-    readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":./" <> path <> "/" ] "" >>= \case
-        ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
-            return Tree
-                { treeRepo = treeRepo tree
-                , treeId = TreeId (BC.pack tid)
-                , treeSubdir = treeSubdir tree </> path
-                }
-        _ -> do
-            fail $ "subtree ‘" <> path <> "’ not found" <> maybe "" ((" in revision ‘" <>) . (<> "’") . showCommitId . commitId) mbCommit
+        dirs = dropWhile (`elem` [ ".", "/" ]) $ splitDirectories path
+
+    case dirs of
+        [] -> return tree
+        _ -> readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> joinPath dirs ] "" >>= \case
+            ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
+                return Tree
+                    { treeRepo = treeRepo tree
+                    , treeId = TreeId (BC.pack tid)
+                    , treeSubdir = joinPath $ treeSubdir tree : dirs
+                    }
+            _ -> do
+                fail $ "subtree ‘" <> path <> "’ not found" <> maybe "" ((" in revision ‘" <>) . (<> "’") . showCommitId . commitId) mbCommit
 
 
 checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
diff --git a/test/script/repo.et b/test/script/repo.et
index 7a34a1c..d93f700 100644
--- a/test/script/repo.et
+++ b/test/script/repo.et
@@ -14,52 +14,76 @@ test RepoSubtree:
         git -C work rev-parse HEAD:first
         git -C work rev-parse HEAD:first/second
 
+        git clone -q --bare work bare.git
+
     expect /([0-9a-f]+)/ from git_init capture commit
     expect /([0-9a-f]+)/ from git_init capture root
     expect /([0-9a-f]+)/ from git_init capture sub1
     expect /([0-9a-f]+)/ from git_init capture sub2
 
-    for repo in [ "./work" ]:
+    for repo in [ "./work", "./bare.git" ]:
         local:
             spawn as p on n args [ repo, "subtree", commit, "" ]
             expect from p /msg $root/
+            expect from p /path (.*)/ capture path
+            guard (path == "")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "." ]
             expect from p /msg $root/
+            expect from p /path (.*)/ capture path
+            guard (path == "")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "/" ]
             expect from p /msg $root/
+            expect from p /path (.*)/ capture path
+            guard (path == "")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "first" ]
             expect from p /msg $sub1/
+            expect from p /path (.*)/ capture path
+            guard (path == "first")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "./first" ]
             expect from p /msg $sub1/
+            expect from p /path (.*)/ capture path
+            guard (path == "first")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "/first" ]
             expect from p /msg $sub1/
+            expect from p /path (.*)/ capture path
+            guard (path == "first")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "./first/second" ]
             expect from p /msg $sub2/
+            expect from p /path (.*)/ capture path
+            guard (path == "first/second")
 
         local:
             spawn as p on n args [ repo, "subtree", commit, "/first/second" ]
             expect from p /msg $sub2/
+            expect from p /path (.*)/ capture path
+            guard (path == "first/second")
 
         local:
             spawn as p on n args [ repo, "subtree", "$sub1(first)", "second" ]
             expect from p /msg $sub2/
+            expect from p /path (.*)/ capture path
+            guard (path == "first/second")
 
         local:
             spawn as p on n args [ repo, "subtree", "$sub1(first)", "./second" ]
             expect from p /msg $sub2/
+            expect from p /path (.*)/ capture path
+            guard (path == "first/second")
 
         local:
             spawn as p on n args [ repo, "subtree", "$sub1(first)", "/second/" ]
             expect from p /msg $sub2/
+            expect from p /path (.*)/ capture path
+            guard (path == "first/second")