content: {-# LANGUAGE ViewPatterns #-}
  
  module Development.Bake.Git(
      SHA1, fromSHA1, toSHA1, ovenGit,
      gitPatchExtra, gitInit
      ) where
  
  import Development.Bake.Core.Type
  import General.Extra
  import Development.Shake.Command
  import Control.Monad.Extra
  import Data.List.Extra
  import General.HTML
  import System.Directory.Extra
  import System.FilePath
  import Data.Maybe
  import Data.Tuple.Extra
  import Data.Char
  import Data.Hashable
  import Data.Monoid
  import Prelude
  
  
  data SHA1 = SHA1 Int String deriving (Show,Eq) -- a number of leading primes, followed by a valid SHA1
  
  -- | Convert a SHA1 obtained from Git into a SHA1. Only done by ovenInit or ovenUpdate
  toSHA1 :: String -> SHA1
  toSHA1 x = checkSHA1 x $ SHA1 0 x
  
  fromSHA1 :: SHA1 -> String
  fromSHA1 (SHA1 _ x) = x
  
  instance Stringy SHA1 where
      stringyFrom x = checkSHA1 b $ SHA1 (length a) b
          where (a,b) = span (== '\'') x
      stringyTo (SHA1 primes sha) = replicate primes '\'' ++ sha
      stringyPretty (SHA1 primes sha) = replicate primes '\'' ++ take 7 sha
  
  -- either returns the second argument, or raises an error
  checkSHA1 :: String -> a -> a
  checkSHA1 x res
      | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x
      | not $ all (`elem` "0123456789abcdef") x = error $ "SHA1 for Git must be all lower case hex, got " ++ show x
      | otherwise = res
  
  
  -- | Modify an 'Oven' to work with the Git version control system.
  --   Requires the name of the repo (e.g. @https:\/\/github.com\/ndmitchell\/bake.git@)
  --   and the name of a branch (e.g. @master@). You can optionally give a path fragment
  --   which is used to clone into.
  ovenGit :: String -> String -> Maybe FilePath -> Oven () () test -> Oven SHA1 SHA1 test
  ovenGit repo branch (fromMaybe "." -> path) o = o
      {ovenInit = gitInit repo branch
      ,ovenUpdate = gitUpdate
      ,ovenPrepare = \s ps -> do gitCheckout s ps; ovenPrepare o () $ map (const ()) ps
      ,ovenPatchExtra = \s p -> gitPatchExtra s p =<< gitInitMirror
      ,ovenSupersede = \_ _ -> False
      }
      where
          gitSafe dir = do
              time_ $ cmd (Cwd dir) "git config user.email" ["https://github.com/ndmitchell/bake"]
              time_ $ cmd (Cwd dir) "git config user.name" ["Bake Continuous Integration"]
  
          -- initialise the mirror, or make it up to date
          gitInitMirror = traced "gitInitMirror" $ do
              -- make sure we descend one directory, since bake writes .bake.name
              mirror <- fmap (</> "mirror") $ createDir "../bake-git" [repo]
              createDirectoryIfMissing True mirror
              -- see http://blog.plataformatec.com.br/2013/05/how-to-properly-mirror-a-git-repository/
              ready <- doesFileExist $ mirror </> "HEAD"
              if ready then
                  time_ $ cmd (Cwd mirror) "git fetch --prune"
               else do
                  time_ $ cmd (Cwd mirror) "git clone --mirror" [repo] "."
                  gitSafe mirror
              return mirror
  
          gitUpdate s ps = traced "gitUpdate" $ do
              gitCheckout s ps
              Stdout x <- time $ cmd (Cwd path) "git rev-parse" [branch]
              time_ $ cmd (Cwd path) "git push" [repo] [branch ++ ":" ++ branch]
              return $ toSHA1 $ trim x
  
          gitCheckout s ps = traced "gitCheckout" $ do
              createDirectoryIfMissing True path
              mirror <- gitInitMirror
              unlessM (doesDirectoryExist $ path </>".git") $ do
                  time_ $ cmd (Cwd path) "git init"
                  gitSafe path
                  time_ $ cmd (Cwd path) "git remote add origin" [(if path == "." then "" else "../") ++ mirror]
              time_ $ cmd (Cwd path) "git fetch"
              time_ $ cmd (Cwd path) "git reset" -- to unwedge a previous merge conflict
              time_ $ cmd (Cwd path) "git checkout" [branch]
              time_ $ cmd (Cwd path) "git reset --hard" ["origin/" ++ branch]
              Stdout x <- time $ cmd (Cwd path) "git rev-parse HEAD"
              when (trim x /= fromSHA1 s) $ error $
                  "The branch " ++ branch ++ " changed SHA1 independently of bake.\n" ++
                  "Expected value: " ++ fromSHA1 s ++ "\n" ++
                  "But has become: " ++ trim x
              forM_ ps $ \p ->
                  time_ $ cmd (Cwd path) "git merge" (fromSHA1 p)
  
  
  gitInit :: String -> String -> IO SHA1
  gitInit repo branch = traced "gitInit" $ do
      Stdout hash <- time $ cmd "git ls-remote" [repo] [branch]
      case words $ concat $ takeEnd 1 $ lines hash of
          [] -> error "Couldn't find branch"
          x:xs -> return $ toSHA1 $ trim x
  
  
  traced :: String -> IO a -> IO a
  traced msg act = do
      putStrLn $ "% GIT: Begin " ++ msg
      res <- act
      putStrLn $ "% GIT: Finish " ++ msg
      return res
  
  
  ---------------------------------------------------------------------
  -- DIFF UTILITIES
  
  gitPatchExtra :: SHA1 -> Maybe SHA1 -> FilePath -> IO (String, String)
  gitPatchExtra s Nothing dir = do
      Stdout full <- time $ cmd (Cwd dir) "git log --no-merges -n10 --pretty=format:%s" [fromSHA1 s]
      Stdout count <- time $ cmd (Cwd dir) "git rev-list --count" [fromSHA1 s]
      let summary = takeWhile (/= '\n') full
      return (renderHTML $ do str_ $ count ++ " patches"; br_; str_ summary
             ,renderHTML $ pre_ $ str_ full)
  
  gitPatchExtra s (Just p) dir = do
      Stdout diff <- time $ cmd (Cwd dir)
          "git diff" [fromSHA1 s ++ "..." ++ fromSHA1 p]
      Stdout stat <- time $ cmd (Cwd dir)
          "git diff --stat" [fromSHA1 s ++ "..." ++ fromSHA1 p]
      Stdout log <- time $ cmd (Cwd dir)
          "git log --no-merges -n1 --pretty=format:%s" [fromSHA1 p]
      return (renderHTML $ do str_ $ reduceStat stat; br_; str_ $ take 120 $ takeWhile (/= '\n') log
             ,renderHTML $ pre_ $ do prettyStat stat; str_ "\n"; prettyDiff diff)
  
  
  reduceStat :: String -> String
  reduceStat = commasLimit 3 . map trim . map (takeWhile (/= '|')) . dropEnd 1 . lines
  
  
  diff :: FilePath -> String
  diff x = "diff:" ++ show (abs $ hash x)
  
  -- |
  -- > src/Paths.hs                          |   11 ++
  -- > src/Test.hs                           |  258 ++++++++++++------------
  -- > travis.hs                             |    4 +-
  -- > 28 files changed, 1612 insertions(+), 1302 deletions(-)
  prettyStat :: String -> HTML
  prettyStat = unlines_ . maybe [] (uncurry snoc . (map f *** str_)) . unsnoc . map trimStart . lines
      where
          f x = a__ [href_ $ "#" ++ diff a] (str_ a) <> str_ b <> g c
              where (ab,c) = break (== '|') x
                    (a,b) = spanEnd isSpace ab
          g x@('+':_) = span__ [class_ "green"] (str_ a) <> g b
              where (a,b) = span (== '+') x
          g x@('-':_) = span__ [class_ "red"] (str_ a) <> g b
              where (a,b) = span (== '-') x
          g (x:xs) = str_ [x] <> g xs
          g [] = mempty
  
  
  -- |
  -- > diff --git a/bake.cabal b/bake.cabal
  -- > index 1aa1251..785cecc 100755
  -- > --- a/bake.cabal
  -- > +++ b/bake.cabal
  -- > @@ -1,7 +1,7 @@
  -- >  cabal-version:      >= 1.10
  -- >  build-type:         Simple
  -- >  name:               bake
  -- > -version:            0.1
  -- > +version:            0.2
  prettyDiff :: String -> HTML
  prettyDiff = unlines_ . map f . lines
      where
          f x | "diff --git " `isPrefixOf` x =
              let files = [y | ab:'/':y <- drop 2 $ words x, ab `elem` "ab"] in
              a__ (take 1 [name_ $ diff y | y <- files]) mempty <>
              b_ (str_ x)
          f x | any (`isPrefixOf` x) ["index ","--- ","+++ "] = b_ $ str_ x
          f xs@('+':_) = span__ [class_ "green"] $ str_ xs
          f xs@('-':_) = span__ [class_ "red"] $ str_ xs
          f xs = str_ xs
  