Last active

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Git server-side submodule reference validator

View .gitignore
1 2 3 4
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
 
See full licencse text at <https://gnu.org/licenses/gpl.html>
View .gitignore

Git server-side submodule reference validator

View .gitignore
1 2
import Distribution.Simple
main = defaultMain
View .gitignore
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
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
View .gitignore
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
#!/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[@]}"
View .gitignore
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
#!/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.