diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs index 87ae027..09f1ed2 100644 --- a/src/Niv/Git/Cmd.hs +++ b/src/Niv/Git/Cmd.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,6 +10,7 @@ module Niv.Git.Cmd where import Control.Applicative import Control.Arrow +import Control.Monad (unless, void) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 import qualified Data.HashMap.Strict as HMS @@ -23,6 +25,7 @@ import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts import System.Exit (ExitCode (ExitSuccess)) import System.Process (readProcessWithExitCode) +import UnliftIO gitCmd :: Cmd gitCmd = @@ -115,11 +118,13 @@ describeGit = Opts.<$$> " niv add git --repo /my/custom/repo --name custom --ref foobar" ] +data CommitInfo = CommitInfo {revision :: T.Text, date :: T.Text} + gitUpdate :: -- | latest rev - (T.Text -> T.Text -> IO T.Text) -> + (T.Text -> T.Text -> IO CommitInfo) -> -- | latest rev and default ref - (T.Text -> IO (T.Text, T.Text)) -> + (T.Text -> IO (T.Text, CommitInfo)) -> Update () () gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do useOrSet "type" -< ("git" :: Box T.Text) @@ -129,66 +134,50 @@ gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do discoverRefAndRev = proc repository -> do refAndRev <- run defaultRefAndHEAD' -< repository update "ref" -< fst <$> refAndRev - update "rev" -< snd <$> refAndRev + update "rev" -< (revision . snd) <$> refAndRev + update "date" -< (date . snd) <$> refAndRev returnA -< () discoverRev = proc repository -> do ref <- load "ref" -< () rev <- run' (uncurry latestRev') -< (,) <$> repository <*> ref - update "rev" -< rev + update "rev" -< revision <$> rev + update "date" -< date <$> rev returnA -< () -- | The "real" (IO) update gitUpdate' :: Update () () gitUpdate' = gitUpdate latestRev defaultRefAndHEAD -latestRev :: - -- | the repository - T.Text -> - -- | the ref/branch - T.Text -> - IO T.Text -latestRev repo ref = do - let gitArgs = ["ls-remote", repo, "refs/heads/" <> ref] - sout <- runGit gitArgs - case sout of - ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls - (l1 : []) -> parseRev gitArgs l1 - [] -> abortNoOutput gitArgs +-- TODO: document the git operations +latestRevInfo :: T.Text -> Maybe T.Text -> IO (T.Text, CommitInfo) +latestRevInfo repo mref = runGits $ \git -> do + void $ git ["init"] + void $ git ["remote", "add", "origin", repo] + ref <- maybe (git ["remote", "show", "origin"] >>= findRef) pure mref + void $ git ["fetch", "origin", ref, "--depth", "1"] + git ["show", "--quiet", "--format=%H%n%aD", "origin/" <> ref] >>= \case + [] -> abort "Git did not produce enough output while reading commit information" + [rev, dte] -> do + unless (isRev rev) $ do + abort $ "The revision retrieved from git does not look like a revision: '" <> rev <> "'." + pure (ref, CommitInfo {revision = rev, date = dte}) + output -> + abort $ T.unlines $ + ["Git produced too much output while reading commit information:"] <> output where - parseRev args l = maybe (abortNoRev args l) pure $ do - checkRev $ T.takeWhile (/= '\t') l - checkRev t = if isRev t then Just t else Nothing - abortNoOutput args = - abortGitFailure - args - "Git didn't produce any output." - abortTooMuchOutput args ls = - abortGitFailure args $ T.unlines $ - ["Git produced too much output:"] <> map (" " <>) ls + findRef ls = case listToMaybe $ mapMaybe (T.stripPrefix "HEAD branch:" . T.strip) ls of + Just l -> pure (T.strip l) + Nothing -> abort $ T.unlines $ ["could not parse default ref: "] <> ls + +latestRev :: T.Text -> T.Text -> IO CommitInfo +latestRev repo ref = snd <$> latestRevInfo repo (Just ref) +-- TODO: test this defaultRefAndHEAD :: -- | the repository T.Text -> - IO (T.Text, T.Text) -defaultRefAndHEAD repo = do - sout <- runGit args - case sout of - (l1 : l2 : _) -> (,) <$> parseRef l1 <*> parseRev l2 - _ -> - abortGitFailure args $ T.unlines $ - [ "Could not read reference and revision from stdout:" - ] - <> sout - where - args = ["ls-remote", "--symref", repo, "HEAD"] - parseRef l = maybe (abortNoRef args l) pure $ do - -- ref: refs/head/master\tHEAD -> master\tHEAD - refAndSym <- T.stripPrefix "ref: refs/heads/" l - let ref = T.takeWhile (/= '\t') refAndSym - if T.null ref then Nothing else Just ref - parseRev l = maybe (abortNoRev args l) pure $ do - checkRev $ T.takeWhile (/= '\t') l - checkRev t = if isRev t then Just t else Nothing + IO (T.Text, CommitInfo) +defaultRefAndHEAD repo = latestRevInfo repo Nothing abortNoRev :: [T.Text] -> T.Text -> IO a abortNoRev args l = abortGitFailure args $ "Could not read revision from: " <> l @@ -209,6 +198,22 @@ runGit args = do T.unwords ["stderr:", T.pack serr] ] +runGits :: (([T.Text] -> IO [T.Text]) -> IO a) -> IO a +runGits act = withSystemTempDirectory "niv" $ \f -> do + past <- newIORef [] + let runGit' args = do + atomicModifyIORef past (\past' -> (past' <> [args], ())) + runGit ("-C" : T.pack f : args) + tryAny (act runGit') >>= \case + Left e -> do + past' <- readIORef past + abort $ bug $ T.unlines $ + [ "An error happened while executing the following git commands in the niv checkout '" <> T.pack f <> "':" + ] + <> (map (\cmd -> T.intercalate " " (" git" : cmd)) past') + <> [tshow e] + Right a -> pure a + isRev :: T.Text -> Bool isRev t = -- commit hashes are comprised of abcdef0123456789 @@ -219,7 +224,7 @@ isRev t = abortGitFailure :: [T.Text] -> T.Text -> IO a abortGitFailure args msg = - abort $ bug $ + abort $ T.unlines [ "Could not read the output of 'git'.", T.unwords ("command:" : "git" : args), diff --git a/src/Niv/Git/Test.hs b/src/Niv/Git/Test.hs index 8b499f9..eaa4791 100644 --- a/src/Niv/Git/Test.hs +++ b/src/Niv/Git/Test.hs @@ -65,8 +65,10 @@ test_gitUpdateRev = do $ error $ "State mismatch: " <> show actualState where - latestRev' _ _ = pure "some-other-rev" - defaultRefAndHEAD' _ = pure ("some-ref", "some-rev") + latestRev' _ _ = pure someOtherCommit + someCommit = CommitInfo {revision = "some-rev", date = "some-date"} + someOtherCommit = CommitInfo {revision = "some-other-rev", date = "some-other-date"} + defaultRefAndHEAD' _ = pure ("some-ref", someCommit) initialState = HMS.fromList [("repo", (Free, "git@github.com:nmattia/niv"))] @@ -75,6 +77,7 @@ test_gitUpdateRev = do [ ("repo", "git@github.com:nmattia/niv"), ("ref", "some-ref"), ("rev", "some-other-rev"), + ("date", "some-other-date"), ("type", "git") ] @@ -115,8 +118,10 @@ test_gitCalledOnce = do $ error $ "State mismatch: " <> show actualState where - latestRev' _ _ = pure "some-other-rev" - defaultRefAndHEAD' _ = pure ("some-ref", "some-rev") + latestRev' _ _ = pure someOtherCommit + someCommit = CommitInfo {revision = "some-rev", date = "some-date"} + someOtherCommit = CommitInfo {revision = "some-other-rev", date = "some-other-date"} + defaultRefAndHEAD' _ = pure ("some-ref", someCommit) initialState = HMS.fromList [("repo", (Free, "git@github.com:nmattia/niv"))] @@ -125,5 +130,6 @@ test_gitCalledOnce = do [ ("repo", "git@github.com:nmattia/niv"), ("ref", "some-ref"), ("rev", "some-other-rev"), + ("date", "some-other-date"), ("type", "git") ]