{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Git
( checkAutoUpdateBranchDoesntExist,
checkoutAtMergeBase,
cleanAndResetTo,
cleanup,
commit,
deleteBranchesEverywhere,
diff,
fetch,
fetchIfStale,
headHash,
push,
nixpkgsDir,
setupNixpkgs,
Git.show,
)
where
import Control.Concurrent
import Control.Exception
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (fromJust)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Data.Vector as V
import Language.Haskell.TH.Env (envQ)
import OurPrelude hiding (throw)
import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, getCurrentDirectory, setCurrentDirectory)
import System.Environment (getEnv)
import System.Environment.XDG.BaseDir (getUserCacheDir)
import System.Exit
import System.IO.Error (tryIOError)
import System.Posix.Env (setEnv)
import qualified System.Process.Typed
import Utils (Options (..), UpdateEnv (..), branchName, branchPrefix)
bin :: String
bin = fromJust ($$(envQ "GIT") :: Maybe String) <> "/bin/git"
procGit :: [String] -> ProcessConfig () () ()
procGit = proc bin
hubBin :: String
hubBin = fromJust ($$(envQ "HUB") :: Maybe String) <> "/bin/hub"
procHub :: [String] -> ProcessConfig () () ()
procHub = proc hubBin
clean :: ProcessConfig () () ()
clean = silently $ procGit ["clean", "-fdx"]
checkout :: Text -> Text -> ProcessConfig () () ()
checkout branch target =
silently $ procGit ["checkout", "-B", T.unpack branch, T.unpack target]
reset :: Text -> ProcessConfig () () ()
reset target = silently $ procGit ["reset", "--hard", T.unpack target]
delete1 :: Text -> ProcessConfig () () ()
delete1 branch = delete [branch]
delete :: [Text] -> ProcessConfig () () ()
delete branches = silently $ procGit (["branch", "-D"] ++ fmap T.unpack branches)
deleteOrigin :: [Text] -> ProcessConfig () () ()
deleteOrigin branches =
silently $ procGit (["push", "origin", "--delete"] ++ fmap T.unpack branches)
cleanAndResetTo :: MonadIO m => Text -> ExceptT Text m ()
cleanAndResetTo branch =
let target = "upstream/" <> branch
in do
runProcessNoIndexIssue_ $ silently $ procGit ["reset", "--hard"]
runProcessNoIndexIssue_ clean
runProcessNoIndexIssue_ $ checkout branch target
runProcessNoIndexIssue_ $ reset target
runProcessNoIndexIssue_ clean
show :: MonadIO m => Text -> Text -> ExceptT Text m Text
show branch file =
readProcessInterleavedNoIndexIssue_ $ silently $ procGit ["show", T.unpack ("remotes/upstream/" <> branch <> ":" <> file)]
cleanup :: MonadIO m => Text -> ExceptT Text m ()
cleanup bName = do
liftIO $ T.putStrLn ("Cleaning up " <> bName)
cleanAndResetTo "master"
runProcessNoIndexIssue_ (delete1 bName)
<|> liftIO (T.putStrLn ("Couldn't delete " <> bName))
diff :: MonadIO m => Text -> ExceptT Text m Text
diff branch = readProcessInterleavedNoIndexIssue_ $ procGit ["diff", T.unpack branch]
staleFetchHead :: MonadIO m => m Bool
staleFetchHead =
liftIO $ do
nixpkgsGit <- getUserCacheDir "nixpkgs"
let fetchHead = nixpkgsGit <> "/.git/FETCH_HEAD"
oneHourAgo <- addUTCTime (fromInteger $ -60 * 60) <$> getCurrentTime
e <- tryIOError $ getModificationTime fetchHead
if isLeft e
then do
return True
else do
fetchedLast <- getModificationTime fetchHead
return (fetchedLast < oneHourAgo)
fetchIfStale :: MonadIO m => ExceptT Text m ()
fetchIfStale = whenM staleFetchHead fetch
fetch :: MonadIO m => ExceptT Text m ()
fetch =
runProcessNoIndexIssue_ $
silently $ procGit ["fetch", "-q", "--prune", "--multiple", "upstream", "origin"]
push :: MonadIO m => UpdateEnv -> ExceptT Text m ()
push updateEnv =
runProcessNoIndexIssue_
( procGit
( [ "push",
"--force",
"--set-upstream",
"origin",
T.unpack (branchName updateEnv)
]
++ ["--dry-run" | not (doPR (options updateEnv))]
)
)
nixpkgsDir :: IO FilePath
nixpkgsDir = do
inNixpkgs <- inNixpkgsRepo
if inNixpkgs
then getCurrentDirectory
else getUserCacheDir "nixpkgs"
-- Setup a NixPkgs clone in $XDG_CACHE_DIR/nixpkgs
-- Since we are going to have to fetch, git reset, clean, and commit, we setup a
-- cache dir to avoid destroying any uncommitted work the user may have in PWD.
setupNixpkgs :: Text -> IO ()
setupNixpkgs githubt = do
fp <- nixpkgsDir
exists <- doesDirectoryExist fp
unless exists $ do
path <- getEnv "PATH"
procHub ["clone", "nixpkgs", fp]
& System.Process.Typed.setEnv -- requires that user has forked nixpkgs
[ ("PATH" :: String, path),
("GITHUB_TOKEN" :: String, githubt & T.unpack)
]
& runProcess_
setCurrentDirectory fp
shell (bin <> "remote add upstream https://github.com/NixOS/nixpkgs")
& runProcess_
inNixpkgs <- inNixpkgsRepo
unless inNixpkgs do
setCurrentDirectory fp
_ <- runExceptT fetchIfStale
_ <- runExceptT $ cleanAndResetTo "master"
return ()
System.Posix.Env.setEnv "NIX_PATH" ("nixpkgs=" <> fp) True
checkoutAtMergeBase :: MonadIO m => Text -> ExceptT Text m Text
checkoutAtMergeBase bName = do
base <-
readProcessInterleavedNoIndexIssue_
(procGit ["merge-base", "upstream/master", "upstream/staging"])
& fmapRT T.strip
runProcessNoIndexIssue_ (checkout bName base)
return base
checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m ()
checkAutoUpdateBranchDoesntExist pName = do
remoteBranches <-
readProcessInterleavedNoIndexIssue_ (procGit ["branch", "--remote"])
& fmapRT (T.lines >>> fmap T.strip)
when
(("origin/" <> branchPrefix <> pName) `elem` remoteBranches)
(throwE "Update branch already on origin.")
inNixpkgsRepo :: IO Bool
inNixpkgsRepo = do
currentDir <- getCurrentDirectory
doesFileExist (currentDir <> "/nixos/release.nix")
commit :: MonadIO m => Text -> ExceptT Text m ()
commit ref =
runProcessNoIndexIssue_ (procGit ["commit", "-am", T.unpack ref])
headHash :: MonadIO m => ExceptT Text m Text
headHash = T.strip <$> readProcessInterleavedNoIndexIssue_ (procGit ["rev-parse", "HEAD"])
deleteBranchesEverywhere :: Vector Text -> IO ()
deleteBranchesEverywhere branches = do
let branchList = V.toList $ branches
result <- runExceptT $ runProcessNoIndexIssue_ (delete branchList)
case result of
Left error1 -> T.putStrLn $ tshow error1
Right success1 -> T.putStrLn $ tshow success1
result2 <- runExceptT $ runProcessNoIndexIssue_ (deleteOrigin branchList)
case result2 of
Left error2 -> T.putStrLn $ tshow error2
Right success2 -> T.putStrLn $ tshow success2
runProcessNoIndexIssue_ ::
MonadIO m => ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ config = tryIOTextET go
where
go = do
(code, out, e) <- readProcess config
case code of
ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict e -> do
threadDelay 100000
go
ExitSuccess -> return ()
ExitFailure _ -> throw $ ExitCodeException code config out e
readProcessInterleavedNoIndexIssue_ ::
MonadIO m => ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ config = tryIOTextET go
where
go = do
(code, out) <- readProcessInterleaved config
case code of
ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict out -> do
threadDelay 100000
go
ExitSuccess -> return $ bytestringToText out
ExitFailure _ -> throw $ ExitCodeException code config out out