Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Git server-side submodule reference validator

Git server-side submodule reference validator

GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
See full licencse text at <https://gnu.org/licenses/gpl.html>
import Distribution.Simple
main = defaultMain
name: submodchecker
version: 0.1.0.0
synopsis: Git server-side submodule reference validator
homepage: https://gist.github.com/9580927.git
license: GPL-3
license-file: LICENSE
author: Herbert Valerio Riedel
maintainer: hvr@gnu.org
build-type: Simple
extra-source-files: README.md
cabal-version: >=1.10
executable submodchecker
main-is: validate-submod-refs.hs
build-depends: base >=4.5 && <4.8, shelly >=1.4 && <1.6, text >=0.11 && <1.2, deepseq ==1.3.*
default-language: Haskell2010
ghc-options: -Wall
#!/bin/bash
SUBMODCHECKER=submodchecker
set -e
if [ -z "$GIT_DIR" ]; then
echo "Don't run this script from the command line." >&2
echo " (if you want, you could supply GIT_DIR then run" >&2
echo " $0 <ref> <oldrev> <newrev>)" >&2
exit 1
fi
refname="$1"
oldrev="$2"
newrev="$3"
[ "$(git config --bool hooks.submodcheck)" = "true" ] || exit 0
if [ -z "$refname" -o -z "$oldrev" -o -z "$newrev" ]; then
echo "usage: $0 <ref> <oldrev> <newrev>" >&2
exit 1
fi
case "$refname" in
refs/heads/wip/*)
echo "skipping submodule checks for wip/ branch"
exit 0
;;
esac
# if $oldrev == $zero, then this is a newly created ref
# if $newrev == $zero it's a commit to delete a ref
zero="0000000000000000000000000000000000000000"
if [ "$newrev" = "$zero" ]; then
newrev_type=delete
exit 0
else
newrev_type=$(git cat-file -t $newrev)
fi
oldrefs=( $(git for-each-ref --format '^%(refname:short)' refs/heads/ | grep -v '^^wip/') )
# list of all commits that became newly reachable from non-wip/ branches
commits=( $(git rev-list $newrev "${oldrefs[@]}" | tac) )
exec $SUBMODCHECKER "$GIT_DIR" "${commits[@]}"
#!/opt/ghc/7.8.1/bin/runghc
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.DeepSeq
import Control.Monad
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Prelude hiding (FilePath)
import Shelly
import System.Environment
main :: IO ()
main = do
dir0:refs <- getArgs
let dir = fromText (T.pack dir0)
shelly $ forM_ (map T.pack refs) $ \ref -> do
(cid,deltas) <- gitDiffTree dir ref
let smDeltas = [ (smPath, smCid) | (_, (GitTypeGitLink, smCid), smPath) <- deltas ]
unless (null smDeltas) $ do
echo $ "Submodule update(s) detected in " <> cid <> ":"
(_, msg) <- gitCatCommit dir cid
unless ("submodule" `T.isInfixOf` msg) $ do
echo "*FAIL* commit message does not contain magic 'submodule' word"
quietExit 1
modMapping <- getModules dir ref
forM_ smDeltas $ \(smPath,smCid) -> do
echo $ " " <> smPath <> " => " <> smCid
(smUrl,_) <- maybe (fail "failed to lookup repo-url") return $
lookup smPath modMapping
if not ("." `T.isPrefixOf` smUrl)
then echo $ "skipping non-relative Git url (" <> smUrl <> ")"
else do
branches <- gitBranchesContain (dir </> smUrl) smCid
let branches' = filter (not . ("wip/" `T.isPrefixOf`)) branches
when (null branches') $ do
echo $ "*FAIL* commit not found in submodule repo ('" <> smUrl <> "')"
echo " or not reachable from persistent branches"
quietExit 1
return ()
echo " OK"
-- | Run @git@ operation
runGit :: FilePath -> Text -> [Text] -> Sh Text
runGit d op args = do
d' <- toTextWarn d
silently $ run "git" ("--git-dir=" <> d' : op : args)
gitCatCommit :: FilePath -> Text -> Sh (Text,Text)
gitCatCommit d ref = do
tmp <- runGit d "cat-file" ["commit", ref ]
return (fmap (T.drop 2) $ T.breakOn "\n\n" tmp)
-- | wrapper around @git branch --contains@
gitBranchesContain :: FilePath -> Text -> Sh [Text]
gitBranchesContain d ref = do
tmp <- liftM T.lines $
errExit False $ print_stderr False $
runGit d "branch" ["--contains", ref]
unless (all (\s -> T.take 2 s `elem` [" ","* "]) tmp) $
fail "gitBranchesContain: internal error"
return $!! map (T.drop 2) tmp
-- | returns @[(path, (url, key))]@
--
-- may throw exception
getModules :: FilePath -> Text -> Sh [(Text, (Text, Text))]
getModules d ref = do
tmp <- runGit d "show" [ref <> ":.gitmodules"]
setStdin tmp
res <- liftM T.lines $ runGit d "config" [ "--file", "/dev/stdin", "-l" ]
let ms = [ (T.tail key1,(key2, T.tail val))
| r <- res, "submodule." `T.isPrefixOf` r
, let (key,val) = T.break (=='=') r
, let (key',key2) = T.breakOnEnd "." key
, let (_,key1) = T.break (=='.') (T.init key')
]
ms' = [ (path', (url, k))
| es@((k,_):_) <- groupBy ((==) `on` fst) ms
, let props = map snd es
, let url = fromMaybe (error "getModules1") (lookup "url" props)
, let path' = fromMaybe (error "getModules2") (lookup "path" props)
]
return $!! ms'
gitDiffTree :: FilePath -> Text -> Sh (Text, [([(GitType, Text, Char)], (GitType, Text), Text)])
gitDiffTree d ref = do
tmp <- liftM T.lines $ runGit d "diff-tree" ["--root","-c", "-r", ref]
case tmp of
cid:deltas -> return $!! (cid, map parseDtLine deltas)
[] -> return ("", [])
where
parseDtLine :: Text -> ([(GitType, Text, Char)], (GitType, Text), Text)
parseDtLine l
| sanityCheck = force (zip3 (map cvtMode mode') oid' (T.unpack k),(cvtMode mode,oid),fp)
| otherwise = error "in parseDtLine"
where
sanityCheck = n > 0 && T.length k == n
n = T.length cols
(mode',mode:tmp') = splitAt n $ T.split (==' ') l''
(oid',[oid,k]) = splitAt n tmp'
[l'',fp] = T.split (=='\t') l'
(cols,l') = T.span (==':') l
z40 :: Text
z40 = T.pack (replicate 40 '0')
data GitType
= GitTypeVoid
| GitTypeRegFile
| GitTypeExeFile
| GitTypeTree
| GitTypeSymLink
| GitTypeGitLink
deriving (Show,Eq,Ord,Enum)
instance NFData GitType
cvtMode :: Text -> GitType
cvtMode "000000" = GitTypeVoid
cvtMode "040000" = GitTypeSymLink
cvtMode "100644" = GitTypeRegFile
cvtMode "100755" = GitTypeExeFile
cvtMode "120000" = GitTypeSymLink
cvtMode "160000" = GitTypeGitLink
cvtMode x = error ("cvtMode: " ++ show x)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.