From 207f897a5b2c8ee50c6ec812b60a0b3bb377f396 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 4 Dec 2023 12:03:11 +0000
Subject: [PATCH] Submodule linter: Allow references to tags
We modify the submodule linter so that if the bumped commit is a
specific tag then the commit is accepted.
Fixes #24241
(cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a)
---
linters/lint-submodule-refs/Main.hs | 23 ++++++++++++++++-------
linters/linters-common/Linters/Common.hs | 5 +++++
2 files changed, 21 insertions(+), 7 deletions(-)
diff --git a/linters/lint-submodule-refs/Main.hs b/linters/lint-submodule-refs/Main.hs
index a59ea2b9936..c7e6b1ff4fd 100644
--- a/linters/lint-submodule-refs/Main.hs
+++ b/linters/lint-submodule-refs/Main.hs
@@ -18,12 +18,12 @@ import System.Exit
-- text
import qualified Data.Text as T
import qualified Data.Text.IO as T
- ( putStrLn )
+ ( putStrLn, putStr )
-- linters-common
import Linters.Common
( GitType(..)
- , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid
+ , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid
)
--------------------------------------------------------------------------------
@@ -51,16 +51,18 @@ main = do
exitWith (ExitFailure 1)
bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do
- T.putStrLn $ " - " <> smPath <> " => " <> smCid
+ T.putStr $ " - " <> smPath <> " => " <> smCid
let smAbsPath = dir ++ "/" ++ T.unpack smPath
remoteBranches <- gitBranchesContain smAbsPath smCid
+ isTagged <- gitIsTagged smAbsPath smCid
let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches
originBranches = mapMaybe isOriginTracking remoteBranches
isOriginTracking = T.stripPrefix "origin/"
- let bad = null nonWip
- when bad $ do
+ case (nonWip ++ isTagged) of
+ [] -> do
+ T.putStrLn " ... BAD"
T.putStrLn $ " *FAIL* commit not found in submodule repo"
T.putStrLn " or not reachable from persistent branches"
T.putStrLn ""
@@ -70,8 +72,15 @@ main = do
commit <- gitNormCid smAbsPath ("origin/" <> branch)
T.putStrLn $ " - " <> branch <> " -> " <> commit
T.putStrLn ""
- pure bad
+ return True
+ (b:bs) -> do
+ let more = case bs of
+ [] -> ")"
+ rest -> " and " <> T.pack (show (length rest)) <> " more)"
+ T.putStrLn $ "... OK (" <> b <> more
+ return False
if bad
then exitWith (ExitFailure 1)
- else T.putStrLn " OK"
+ else T.putStrLn "OK"
+
diff --git a/linters/linters-common/Linters/Common.hs b/linters/linters-common/Linters/Common.hs
index 8d92a877879..b104b377acf 100644
--- a/linters/linters-common/Linters/Common.hs
+++ b/linters/linters-common/Linters/Common.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -105,6 +106,10 @@ gitBranchesContain d ref = do
return $!! map (T.drop 2) tmp
+gitIsTagged :: FilePath -> GitRef -> Sh [Text]
+gitIsTagged d ref =
+ T.lines <$> runGit d "tag" ["--points-at", ref]
+
-- | returns @[(path, (url, key))]@
--
-- may throw exception
--
GitLab