gistfile1.txt

import System.Random
import Control.Applicative
import Control.Monad
import qualified Crypto.Hash.SHA256 as SHA256
-- import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.Process
import System.Exit
import Data.Monoid

-- | Canonical hash function for Provision objects.
-- Currently a SHA256 in base 16.
structHash :: String -> BS.ByteString
structHash x = Base16.encode $ SHA256.hashlazy $ LBS8.pack $ x

randomHashStr :: IO String
randomHashStr = do
  r <- randomIO :: IO Int
  pure $ BS8.unpack $ structHash $ show r
makeTmpBranch :: IO String
makeTmpBranch = do
  s <- fmap (take 8) $ randomHashStr
  pure $ realBranch <> "-" <> tmpBranchAdd <> "-" <> s
makeMergeBranch :: IO String
makeMergeBranch = do
  s <- fmap (take 8) $ randomHashStr
  pure $ realBranch <> "-" <> mergeBranchAdd <> "-" <> s

runOk :: IO (ExitCode, String, String) -> IO Bool
runOk k = do
  (ec,out,err) <- k
  putStrLn $ out
  putStrLn $ err -- TODO wrong streamChunksToFile
  pure $ ec == ExitSuccess
runOkGetOut :: IO (ExitCode, String, String) -> IO (Maybe String)
runOkGetOut k = do
  (ec,out,err) <- k
  putStrLn $ out
  putStrLn $ err -- TODO wrong streamChunksToFile
  pure $ if ec == ExitSuccess then Just out else Nothing
dropEnd n = reverse . drop n . reverse


git = "C:/workspace/ext/git/bin/git.exe"

-- git checkout COMM -b BRANCH
gitCheckoutB :: Maybe String -> String -> IO Bool
gitCheckoutB Nothing b = runOk $ readProcessWithExitCode git ["checkout", "-b", b] ""
gitCheckoutB (Just com) b = runOk $ readProcessWithExitCode git ["checkout", com, "-b", b] ""

gitCurrentBranch :: IO String
gitCurrentBranch = do
  r <- runOkGetOut $ readProcessWithExitCode git ["rev-parse", "--abbrev-ref", "HEAD"] ""
  case r of
    Nothing -> error "Could not get current branch"
    Just x -> pure $ dropEnd 1 x -- Loose newline

gitMerge :: String -> IO Bool
gitMerge branch = runOk $ readProcessWithExitCode git ["merge", branch] ""

gitMergeSquash :: String -> IO Bool
gitMergeSquash branch = runOk $ readProcessWithExitCode git ["merge", "--squash", branch] ""

gitMergeBase :: String -> String -> IO (String)
gitMergeBase branch1 branch2 = do
  r <- fmap (fmap $ dropEnd 1) $ runOkGetOut $ readProcessWithExitCode git ["merge-base", branch1, branch2] ""
  case r of
    Nothing -> error "Could not get merge-base"
    Just x -> pure $ dropEnd 1 x -- Loose newline

gitBranchD :: String -> IO Bool
gitBranchD branch = runOk $ readProcessWithExitCode git ["branch", "-D", branch] ""

gitAdd dirs = runOk $ readProcessWithExitCode git (["add"]<>dirs) ""
gitCommit msg = runOk $ readProcessWithExitCode git (["commmit", "-m"]<>[show msg]) ""

-- Append to tmp branch
appendChange = do
  curBranch <- gitCurrentBranch
  when (curBranch == realBranch) $ do
    tmpB <- makeTmpBranch
    gitCheckoutB Nothing tmpB -- TODO abort on error
    pure ()
  gitAdd trackDirs
  gitCommit "" -- No message
  -- TODO handler error
  pure ()


-- Push up
pushUp = do
  tmpBranch <- gitCurrentBranch
  runOk $ readProcessWithExitCode git ["push", "-u", buildMachine, tmpBranch] ""

-- Merge tmp branch back to real
mergeBack = do
  -- Find last common ancestor of vertex-tmp* and vertex.
  tmpBranch <- gitCurrentBranch
  mb <- gitMergeBase realBranch tmpBranch
  print mb
  mergeB <- makeMergeBranch
  -- Make a commit on a new branch (merge-) with LCA as parent, having all changes from vertex-temp
  gitCheckoutB (Just mb) mergeB
  gitMergeSquash tmpBranch
  print $ "Done, TODO commit and merge " <> mergeB <> " back to " <> realBranch
  print $ "TODO delete " <> mergeB <> " and " <> tmpBranch


realBranch = "vertex-hans"
tmpBranchAdd = "tmp"
trackDirs = ["Strat"]
mergeBranchAdd = "merge"
buildMachine = "strats1" -- A Git remote


-- If I'm on branch vertex, fork off vertex-tmp-*, if I'm alredy on these do nothing
-- Commit w/o real msg
autoSave = error ""


-- Whenever I say "test" (or save)
-- Push the current (tmp branch) to strats1
-- This has to be configured to listen to vertex-NAME-HIGHERST-N, or something
-- On strats1, check out and build (aborting previous builds)
-- (When build finishes update cluster state)
pushToBuilder = error ""
   -- e.g. git push -u BUILD_MACHINE CURRENT_TMP_BRANCH
   -- TODO need a hook to checkout latest pushed branch and build


mergeTmpToReal = error ""


main = do
  args <- getArgs
  case args of
    ["append"] -> void $ appendChange
    ["push-up"] -> void $ pushUp
    ["merge-back"] -> void $ mergeBack
    _ -> error "Unknown cmd"