hvr · August 29, 2015 13:57 · Mar 16, 2014 · Mar 16, 2014
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1 @@
+/dist/
diff --git a/LICENSE b/LICENSE
@@ -0,0 +1,4 @@
+              GNU GENERAL PUBLIC LICENSE
+                Version 3, 29 June 2007
+
+See full licencse text at <https://gnu.org/licenses/gpl.html>
diff --git a/Setup.hs b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/submodchecker.cabal b/submodchecker.cabal
@@ -0,0 +1,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:          [email protected]
+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
diff --git a/update.validate-submod-refs b/update.validate-submod-refs
@@ -0,0 +1,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[@]}"
diff --git a/validate-submod-refs.hs b/validate-submod-refs.hs
@@ -0,0 +1,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)
diff --git a/README.md b/README.md
@@ -0,0 +1 @@
+# Git server-side submodule reference validator
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		# Git server-side submodule reference validator