Record date in git sources

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),

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")
         ]