Skip to content

Commit

Permalink
Fix a number of issues
Browse files Browse the repository at this point in the history
These were uncovered when researching commercialhaskell/stack#105. What
I discovered:

* There was an extra layer of `.git` directories in computed paths
* The HEAD file should be added dependently regardless of whether it's a
  detached head
* Add a missing check in relRef for newline
* Switch newline handling to check both CR and LR for Windows support
  • Loading branch information
snoyberg committed Jun 18, 2017
1 parent 450a7ab commit 6a1a639
Showing 1 changed file with 11 additions and 7 deletions.
18 changes: 11 additions & 7 deletions src/Development/GitRev.hs
Original file line number Diff line number Diff line change
Expand Up @@ -67,21 +67,22 @@ runGit args def useIdx = do
then do
-- a lot of bookkeeping to record the right dependencies
pwd <- runIO getDotGit
let hd = pwd </> ".git" </> "HEAD"
index = pwd </> ".git" </> "index"
packedRefs = pwd </> ".git" </> "packed-refs"
let hd = pwd </> "HEAD"
index = pwd </> "index"
packedRefs = pwd </> "packed-refs"
hdExists <- runIO $ doesFileExist hd
when hdExists $ do
addDependentFile hd
-- the HEAD file either contains the hash of a detached head
-- or a pointer to the file that contains the hash of the head
splitAt 5 `fmap` runIO (readFile hd) >>= \case
-- pointer to ref
("ref: ", relRef) -> do
let ref = pwd </> ".git" </> relRef
let ref = pwd </> tillNewLine relRef
refExists <- runIO $ doesFileExist ref
when refExists $ addDependentFile ref
-- detached head
_hash -> addDependentFile hd
_hash -> return ()
-- add the index if it exists to set the dirty flag
indexExists <- runIO $ doesFileExist index
when (indexExists && useIdx == IdxUsed) $ addDependentFile index
Expand All @@ -93,10 +94,13 @@ runGit args def useIdx = do
runIO $ do
(code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
case code of
ExitSuccess -> return (takeWhile (/= '\n') out)
ExitSuccess -> return (tillNewLine out)
ExitFailure _ -> return def
else return def

tillNewLine :: String -> String
tillNewLine = takeWhile (\c -> c /= '\n' && c /= '\r')

-- | Determine where our @.git@ directory is, in case we're in a
-- submodule.
getDotGit :: IO FilePath
Expand Down Expand Up @@ -124,7 +128,7 @@ getGitRoot = do
(code, out, _) <-
readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
case code of
ExitSuccess -> return $ takeWhile (/= '\n') out
ExitSuccess -> return $ tillNewLine out
ExitFailure _ -> return pwd -- later steps will fail, that's fine

-- | Type to flag if the git index is used or not in a call to runGit
Expand Down

0 comments on commit 6a1a639

Please sign in to comment.