git-rule.hs

{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeSynonymInstances       #-}

import           Data.Char
import           Data.Maybe
import           Data.Monoid
import           Development.Shake
import           Development.Shake.Command
import           Development.Shake.Classes
import           Development.Shake.FilePath
import           Development.Shake.Rule
import           Development.Shake.Util
import qualified System.Directory as IO
import           System.FilePath.Posix  (splitPath)



testCommit = "cd0500843a404f2e4d70831df470abe4b4f14098"
-- testCommit = "a9dba7dc6ff1f6f5d99e293522f48e5b97f58770"

main :: IO ()
main = (shakeArgs shakeOptions {shakeFiles=buildDir, shakeProgress=progressSimple}) $ do
  -- we expect to find all of these files after we run everything
  want [ (testGit </> gitHiddenFile)
       ]
  includeCommitHashValue
  
  -- any time file is missing or git commit has differs, run these actions
  (testGit </> gitHiddenFile) %> \_ -> do
    commitHashValue testGit testCommit
    gitAdd testStatic "git@github.com:mchaver/some-repo.git" testCommit


-- custom rules

newtype GitCommitHash = GitCommitHash (FilePath, String)
  deriving (Show,Binary,NFData,Hashable,Typeable,Eq)

instance Rule GitCommitHash String where
  storedValue _ (GitCommitHash (file, _)) = do
    exists <- IO.doesDirectoryExist file
    if not exists then return Nothing else do
      getGitCommitHash file

  equalValue _ (GitCommitHash (_,commit)) old new = if commit == new then EqualCheap else NotEqual

commitHashValue :: FilePath -> String -> Action ()
commitHashValue fp hs = do
  apply1 $ GitCommitHash (fp,hs) :: Action String
  return ()

includeCommitHashValue :: Rules ()
includeCommitHashValue = do
  rule $ \q@(GitCommitHash (_,commit)) -> Just $ do
  
-- utility functions

trim :: String -> String
trim xs = dropSpaceTail "" $ dropWhile isSpace xs

dropSpaceTail :: String -> String -> String
dropSpaceTail maybeStuff "" = ""
dropSpaceTail maybeStuff (x:xs)
        | isSpace x = dropSpaceTail (x:maybeStuff) xs
        | null maybeStuff = x : dropSpaceTail "" xs
        | otherwise       = reverse maybeStuff ++ x : dropSpaceTail "" xs

    opts <- getShakeOptions
    liftIO $ fmap (fromMaybe commit) $ storedValue opts q

getGitCommitHash :: FilePath -> IO (Maybe String)
getGitCommitHash fp = do
  (Stdout untrimmedCommitHash) <- cmd [Cwd fp] "git rev-parse HEAD"
  let commitHash = trim untrimmedCommitHash
  if commitHash == ""
    then return Nothing
    else return . Just $ commitHash