{-# 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 :: String
bin = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust ($$(envQ "GIT") :: Maybe String) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/bin/git"

procGit :: [String] -> ProcessConfig () () ()
procGit :: [String] -> ProcessConfig () () ()
procGit = String -> [String] -> ProcessConfig () () ()
proc String
bin

hubBin :: String
hubBin :: String
hubBin = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust ($$(envQ "HUB") :: Maybe String) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/bin/hub"

procHub :: [String] -> ProcessConfig () () ()
procHub :: [String] -> ProcessConfig () () ()
procHub = String -> [String] -> ProcessConfig () () ()
proc String
hubBin

clean :: ProcessConfig () () ()
clean :: ProcessConfig () () ()
clean = ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"clean", String
"-fdx"]

checkout :: Text -> Text -> ProcessConfig () () ()
checkout :: Text -> Text -> ProcessConfig () () ()
checkout Text
branch Text
target =
  ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"checkout", String
"-B", Text -> String
T.unpack Text
branch, Text -> String
T.unpack Text
target]

reset :: Text -> ProcessConfig () () ()
reset :: Text -> ProcessConfig () () ()
reset Text
target = ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"reset", String
"--hard", Text -> String
T.unpack Text
target]

delete1 :: Text -> ProcessConfig () () ()
delete1 :: Text -> ProcessConfig () () ()
delete1 Text
branch = [Text] -> ProcessConfig () () ()
delete [Text
branch]

delete :: [Text] -> ProcessConfig () () ()
delete :: [Text] -> ProcessConfig () () ()
delete [Text]
branches = ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit ([String
"branch", String
"-D"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack [Text]
branches)

deleteOrigin :: [Text] -> ProcessConfig () () ()
deleteOrigin :: [Text] -> ProcessConfig () () ()
deleteOrigin [Text]
branches =
  ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit ([String
"push", String
"origin", String
"--delete"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack [Text]
branches)

cleanAndResetTo :: MonadIO m => Text -> ExceptT Text m ()
cleanAndResetTo :: Text -> ExceptT Text m ()
cleanAndResetTo Text
branch =
  let target :: Text
target = Text
"upstream/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
   in do
        ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m ())
-> ProcessConfig () () () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"reset", String
"--hard"]
        ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ProcessConfig () () ()
clean
        ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m ())
-> ProcessConfig () () () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ProcessConfig () () ()
checkout Text
branch Text
target
        ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m ())
-> ProcessConfig () () () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Text -> ProcessConfig () () ()
reset Text
target
        ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ProcessConfig () () ()
clean

show :: MonadIO m => Text -> Text -> ExceptT Text m Text
show :: Text -> Text -> ExceptT Text m Text
show Text
branch Text
file =
  ProcessConfig () () () -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m Text)
-> ProcessConfig () () () -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"show", Text -> String
T.unpack (Text
"remotes/upstream/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
file)]

cleanup :: MonadIO m => Text -> ExceptT Text m ()
cleanup :: Text -> ExceptT Text m ()
cleanup Text
bName = do
  IO () -> ExceptT Text m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text m ()) -> IO () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text
"Cleaning up " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bName)
  Text -> ExceptT Text m ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
cleanAndResetTo Text
"master"
  ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (Text -> ProcessConfig () () ()
delete1 Text
bName)
    ExceptT Text m () -> ExceptT Text m () -> ExceptT Text m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO () -> ExceptT Text m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
T.putStrLn (Text
"Couldn't delete " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bName))

diff :: MonadIO m => Text -> ExceptT Text m Text
diff :: Text -> ExceptT Text m Text
diff Text
branch = ProcessConfig () () () -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m Text)
-> ProcessConfig () () () -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"diff", Text -> String
T.unpack Text
branch]

staleFetchHead :: MonadIO m => m Bool
staleFetchHead :: m Bool
staleFetchHead =
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    String
nixpkgsGit <- String -> IO String
getUserCacheDir String
"nixpkgs"
    let fetchHead :: String
fetchHead = String
nixpkgsGit String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/.git/FETCH_HEAD"
    UTCTime
oneHourAgo <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Integer -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ -Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    Either IOError UTCTime
e <- IO UTCTime -> IO (Either IOError UTCTime)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO UTCTime -> IO (Either IOError UTCTime))
-> IO UTCTime -> IO (Either IOError UTCTime)
forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationTime String
fetchHead
    if Either IOError UTCTime -> Bool
forall a b. Either a b -> Bool
isLeft Either IOError UTCTime
e
      then do
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        UTCTime
fetchedLast <- String -> IO UTCTime
getModificationTime String
fetchHead
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
fetchedLast UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
oneHourAgo)

fetchIfStale :: MonadIO m => ExceptT Text m ()
fetchIfStale :: ExceptT Text m ()
fetchIfStale = ExceptT Text m Bool -> ExceptT Text m () -> ExceptT Text m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT Text m Bool
forall (m :: * -> *). MonadIO m => m Bool
staleFetchHead ExceptT Text m ()
forall (m :: * -> *). MonadIO m => ExceptT Text m ()
fetch

fetch :: MonadIO m => ExceptT Text m ()
fetch :: ExceptT Text m ()
fetch =
  ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (ProcessConfig () () () -> ExceptT Text m ())
-> ProcessConfig () () () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$
    ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr -> ProcessConfig () () ()
silently (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ [String] -> ProcessConfig () () ()
procGit [String
"fetch", String
"-q", String
"--prune", String
"--multiple", String
"upstream", String
"origin"]

push :: MonadIO m => UpdateEnv -> ExceptT Text m ()
push :: UpdateEnv -> ExceptT Text m ()
push UpdateEnv
updateEnv =
  ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_
    ( [String] -> ProcessConfig () () ()
procGit
        ( [ String
"push",
            String
"--force",
            String
"--set-upstream",
            String
"origin",
            Text -> String
T.unpack (UpdateEnv -> Text
branchName UpdateEnv
updateEnv)
          ]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--dry-run" | Bool -> Bool
not (Options -> Bool
doPR (UpdateEnv -> Options
options UpdateEnv
updateEnv))]
        )
    )

nixpkgsDir :: IO FilePath
nixpkgsDir :: IO String
nixpkgsDir = do
  Bool
inNixpkgs <- IO Bool
inNixpkgsRepo
  if Bool
inNixpkgs
    then IO String
getCurrentDirectory
    else String -> IO String
getUserCacheDir String
"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 :: Text -> IO ()
setupNixpkgs Text
githubt = do
  String
fp <- IO String
nixpkgsDir
  Bool
exists <- String -> IO Bool
doesDirectoryExist String
fp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
path <- String -> IO String
getEnv String
"PATH"
    [String] -> ProcessConfig () () ()
procHub [String
"clone", String
"nixpkgs", String
fp]
      ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& [(String, String)]
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
[(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
System.Process.Typed.setEnv -- requires that user has forked nixpkgs
        [ (String
"PATH" :: String, String
path),
          (String
"GITHUB_TOKEN" :: String, Text
githubt Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack)
        ]
      ProcessConfig () () ()
-> (ProcessConfig () () () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
    String -> IO ()
setCurrentDirectory String
fp
    String -> ProcessConfig () () ()
shell (String
bin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"remote add upstream https://github.com/NixOS/nixpkgs")
      ProcessConfig () () ()
-> (ProcessConfig () () () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
  Bool
inNixpkgs <- IO Bool
inNixpkgsRepo
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inNixpkgs do
    String -> IO ()
setCurrentDirectory String
fp
    Either Text ()
_ <- ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => ExceptT Text m ()
fetchIfStale
    Either Text ()
_ <- ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
cleanAndResetTo Text
"master"
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  String -> String -> Bool -> IO ()
System.Posix.Env.setEnv String
"NIX_PATH" (String
"nixpkgs=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp) Bool
True

checkoutAtMergeBase :: MonadIO m => Text -> ExceptT Text m Text
checkoutAtMergeBase :: Text -> ExceptT Text m Text
checkoutAtMergeBase Text
bName = do
  Text
base <-
    ProcessConfig () () () -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_
      ([String] -> ProcessConfig () () ()
procGit [String
"merge-base", String
"upstream/master", String
"upstream/staging"])
      ExceptT Text m Text
-> (ExceptT Text m Text -> ExceptT Text m Text)
-> ExceptT Text m Text
forall a b. a -> (a -> b) -> b
& (Text -> Text) -> ExceptT Text m Text -> ExceptT Text m Text
forall (m :: * -> *) a b l.
Monad m =>
(a -> b) -> ExceptT l m a -> ExceptT l m b
fmapRT Text -> Text
T.strip
  ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ (Text -> Text -> ProcessConfig () () ()
checkout Text
bName Text
base)
  Text -> ExceptT Text m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
base

checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m ()
checkAutoUpdateBranchDoesntExist :: Text -> ExceptT Text m ()
checkAutoUpdateBranchDoesntExist Text
pName = do
  [Text]
remoteBranches <-
    ProcessConfig () () () -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ ([String] -> ProcessConfig () () ()
procGit [String
"branch", String
"--remote"])
      ExceptT Text m Text
-> (ExceptT Text m Text -> ExceptT Text m [Text])
-> ExceptT Text m [Text]
forall a b. a -> (a -> b) -> b
& (Text -> [Text]) -> ExceptT Text m Text -> ExceptT Text m [Text]
forall (m :: * -> *) a b l.
Monad m =>
(a -> b) -> ExceptT l m a -> ExceptT l m b
fmapRT (Text -> [Text]
T.lines (Text -> [Text]) -> ([Text] -> [Text]) -> Text -> [Text]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip)
  Bool -> ExceptT Text m () -> ExceptT Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    ((Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branchPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pName) Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
remoteBranches)
    (Text -> ExceptT Text m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"Update branch already on origin.")

inNixpkgsRepo :: IO Bool
inNixpkgsRepo :: IO Bool
inNixpkgsRepo = do
  String
currentDir <- IO String
getCurrentDirectory
  String -> IO Bool
doesFileExist (String
currentDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/nixos/release.nix")

commit :: MonadIO m => Text -> ExceptT Text m ()
commit :: Text -> ExceptT Text m ()
commit Text
ref =
  ProcessConfig () () () -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ([String] -> ProcessConfig () () ()
procGit [String
"commit", String
"-am", Text -> String
T.unpack Text
ref])

headHash :: MonadIO m => ExceptT Text m Text
headHash :: ExceptT Text m Text
headHash = Text -> Text
T.strip (Text -> Text) -> ExceptT Text m Text -> ExceptT Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessConfig () () () -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ ([String] -> ProcessConfig () () ()
procGit [String
"rev-parse", String
"HEAD"])

deleteBranchesEverywhere :: Vector Text -> IO ()
deleteBranchesEverywhere :: Vector Text -> IO ()
deleteBranchesEverywhere Vector Text
branches = do
  let branchList :: [Text]
branchList = Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList (Vector Text -> [Text]) -> Vector Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Vector Text
branches
  Either Text ()
result <- ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ([Text] -> ProcessConfig () () ()
delete [Text]
branchList)
  case Either Text ()
result of
    Left Text
error1 -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
tshow Text
error1
    Right ()
success1 -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> Text
forall a. Show a => a -> Text
tshow ()
success1
  Either Text ()
result2 <- ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ([Text] -> ProcessConfig () () ()
deleteOrigin [Text]
branchList)
  case Either Text ()
result2 of
    Left Text
error2 -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
tshow Text
error2
    Right ()
success2 -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> Text
forall a. Show a => a -> Text
tshow ()
success2

runProcessNoIndexIssue_ ::
  MonadIO m => ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ :: ProcessConfig () () () -> ExceptT Text m ()
runProcessNoIndexIssue_ ProcessConfig () () ()
config = IO () -> ExceptT Text m ()
forall (m :: * -> *) a. MonadIO m => IO a -> ExceptT Text m a
tryIOTextET IO ()
go
  where
    go :: IO ()
go = do
      (ExitCode
code, ByteString
out, ByteString
e) <- ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess ProcessConfig () () ()
config
      case ExitCode
code of
        ExitFailure Int
128
          | ByteString
"index.lock" ByteString -> ByteString -> Bool
`BS.isInfixOf` ByteString -> ByteString
BSL.toStrict ByteString
e -> do
            Int -> IO ()
threadDelay Int
100000
            IO ()
go
        ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ExitFailure Int
_ -> ExitCodeException -> IO ()
forall a e. Exception e => e -> a
throw (ExitCodeException -> IO ()) -> ExitCodeException -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode
-> ProcessConfig () () ()
-> ByteString
-> ByteString
-> ExitCodeException
ExitCodeException ExitCode
code ProcessConfig () () ()
config ByteString
out ByteString
e

readProcessInterleavedNoIndexIssue_ ::
  MonadIO m => ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ :: ProcessConfig () () () -> ExceptT Text m Text
readProcessInterleavedNoIndexIssue_ ProcessConfig () () ()
config = IO Text -> ExceptT Text m Text
forall (m :: * -> *) a. MonadIO m => IO a -> ExceptT Text m a
tryIOTextET IO Text
go
  where
    go :: IO Text
go = do
      (ExitCode
code, ByteString
out) <- ProcessConfig () () () -> IO (ExitCode, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString)
readProcessInterleaved ProcessConfig () () ()
config
      case ExitCode
code of
        ExitFailure Int
128
          | ByteString
"index.lock" ByteString -> ByteString -> Bool
`BS.isInfixOf` ByteString -> ByteString
BSL.toStrict ByteString
out -> do
            Int -> IO ()
threadDelay Int
100000
            IO Text
go
        ExitCode
ExitSuccess -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bytestringToText ByteString
out
        ExitFailure Int
_ -> ExitCodeException -> IO Text
forall a e. Exception e => e -> a
throw (ExitCodeException -> IO Text) -> ExitCodeException -> IO Text
forall a b. (a -> b) -> a -> b
$ ExitCode
-> ProcessConfig () () ()
-> ByteString
-> ByteString
-> ExitCodeException
ExitCodeException ExitCode
code ProcessConfig () () ()
config ByteString
out ByteString
out