Fix extrating subtree hash in a bare repository

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

2 files changed, 14 insertions, 9 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 ()