Git server-side submodule reference validator

.gitignore

/dist/

README.md

Git server-side submodule reference validator

LICENSE

              GNU GENERAL PUBLIC LICENSE
                Version 3, 29 June 2007

See full licencse text at <https://gnu.org/licenses/gpl.html>

Setup.hs

import Distribution.Simple
main = defaultMain

submodchecker.cabal

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

update.validate-submod-refs

#!/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[@]}"

validate-submod-refs.hs

#!/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)