{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Git.FastForward.Core.MonadUpdateBranches
-- License     : BSD3
-- Maintainer  : tbidne@gmail.com
-- The MonadUpdateBranches class.
module Git.FastForward.Core.MonadUpdateBranches
  ( MonadUpdateBranches (..),
    runUpdateBranches,
  )
where

import App
import Common.IO
import Common.MonadLogger
import qualified Control.Monad.Reader as R
import qualified Data.Text as T
import Git.FastForward.Core.Internal
import Git.FastForward.Types.Env
import Git.FastForward.Types.LocalBranches
import Git.FastForward.Types.MergeType
import Git.FastForward.Types.UpdateResult
import Git.Types.GitTypes
import qualified System.Exit as Ex

-- | The 'MonadUpdateBranches' class is used to describe updating branches
-- on a git filesystem.
class Monad m => MonadUpdateBranches m where
  -- | Performs 'fetch'.
  fetch :: Maybe FilePath -> m ()

  -- | Retrieves all local branches.
  getBranches :: Maybe FilePath -> m LocalBranches

  -- | Updates a branch by 'Name', returns the result.
  updateBranch :: Maybe FilePath -> MergeType -> Name -> m UpdateResult

  -- | Pushes branches, returns the results.
  pushBranches :: Maybe FilePath -> [Name] -> m [UpdateResult]

  -- | Checks out the passed 'CurrentBranch'.
  checkoutCurrent :: Maybe FilePath -> CurrentBranch -> m ()

-- | `MonadUpdateBranches` instance for `IO`. In general, we do not care
-- about error handling /except/ during 'updateBranch'. This is
-- because a failure during 'updateBranch' is relatively common as we're
-- being conservative by merging with "--ff-only", and we'd rather log it
-- and continue trying to update other branches.
instance MonadUpdateBranches IO where
  fetch :: Maybe FilePath -> IO ()
  fetch :: Maybe FilePath -> IO ()
fetch path :: Maybe FilePath
path = do
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo "Fetching..."
    Either Text Text
res <- Text -> Maybe FilePath -> IO (Either Text Text)
tryShExitCode "git fetch --prune" Maybe FilePath
path
    case Either Text Text
res of
      Left t :: Text
t -> do
        Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logError Text
t
        IO ()
forall a. IO a
Ex.exitFailure
      Right _ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  getBranches :: Maybe FilePath -> IO LocalBranches
  getBranches :: Maybe FilePath -> IO LocalBranches
getBranches path :: Maybe FilePath
path = do
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo "Parsing branches..."
    Either Text Text
res <- Text -> Maybe FilePath -> IO (Either Text Text)
tryShExitCode "git branch" Maybe FilePath
path
    case Either Text Text
res Either Text Text
-> (Text -> Either Text LocalBranches) -> Either Text LocalBranches
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Either Text LocalBranches
textToLocalBranches of
      Left t :: Text
t -> do
        Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logError Text
t
        IO LocalBranches
forall a. IO a
Ex.exitFailure
      Right x :: LocalBranches
x -> LocalBranches -> IO LocalBranches
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalBranches
x

  updateBranch :: Maybe FilePath -> MergeType -> Name -> IO UpdateResult
  updateBranch :: Maybe FilePath -> MergeType -> Name -> IO UpdateResult
updateBranch path :: Maybe FilePath
path mergeType :: MergeType
mergeType nm :: Name
nm@(Name name :: Text
name) = do
    let checkout :: IO (Either Text Text)
checkout = Text -> Maybe FilePath -> IO (Either Text Text)
tryShExitCode ("git checkout \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"") Maybe FilePath
path
        update :: IO (Either Text Text)
update = Text -> Maybe FilePath -> IO (Either Text Text)
tryShExitCode (MergeType -> Text
mergeTypeToCmd MergeType
mergeType) Maybe FilePath
path
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Updating " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    Either Text Text
res <- IO (Either Text Text)
-> IO (Either Text Text) -> IO (Either Text Text)
forall e a. IO (Either e a) -> IO (Either e a) -> IO (Either e a)
failFast IO (Either Text Text)
checkout IO (Either Text Text)
update
    case Either Text Text
res of
      Left t :: Text
t -> do
        Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarn Text
t
        UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
Failure Name
nm
      Right o :: Text
o
        | Text -> Bool
branchUpToDate Text
o -> UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
NoChange Name
nm
        | Bool
otherwise -> UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
Success Name
nm

  pushBranches :: Maybe FilePath -> [Name] -> IO [UpdateResult]
  pushBranches :: Maybe FilePath -> [Name] -> IO [UpdateResult]
pushBranches path :: Maybe FilePath
path = (Name -> IO UpdateResult) -> [Name] -> IO [UpdateResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe FilePath -> Name -> IO UpdateResult
pushBranch Maybe FilePath
path)

  checkoutCurrent :: Maybe FilePath -> CurrentBranch -> IO ()
  checkoutCurrent :: Maybe FilePath -> Name -> IO ()
checkoutCurrent path :: Maybe FilePath
path (Name name :: Text
name) = do
    Either Text Text
res <- Text -> Maybe FilePath -> IO (Either Text Text)
tryShAndReturnStdErr ("git checkout \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"") Maybe FilePath
path
    case Either Text Text
res of
      Left t :: Text
t -> Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logError Text
t
      Right o :: Text
o -> Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo Text
o

pushBranch :: Maybe FilePath -> Name -> IO UpdateResult
pushBranch :: Maybe FilePath -> Name -> IO UpdateResult
pushBranch path :: Maybe FilePath
path nm :: Name
nm@(Name name :: Text
name) = do
  Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Pushing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  -- "git push" returns the "up to date..." string as stderr for
  -- some reason...
  Either Text Text
res <- Text -> Maybe FilePath -> IO (Either Text Text)
tryShAndReturnStdErr ("git push " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Maybe FilePath
path
  case Either Text Text
res of
    Left t :: Text
t -> do
      Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarn Text
t
      UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
Failure Name
nm
    Right o :: Text
o
      | Text -> Bool
remoteUpToDate Text
o -> UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
NoChange Name
nm
      | Bool
otherwise -> UpdateResult -> IO UpdateResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateResult -> IO UpdateResult)
-> UpdateResult -> IO UpdateResult
forall a b. (a -> b) -> a -> b
$ Name -> UpdateResult
Success Name
nm

instance MonadUpdateBranches m => MonadUpdateBranches (AppT Env m) where
  fetch :: Maybe FilePath -> AppT Env m ()
fetch = m () -> AppT Env m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m () -> AppT Env m ())
-> (Maybe FilePath -> m ()) -> Maybe FilePath -> AppT Env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> m ()
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> m ()
fetch
  getBranches :: Maybe FilePath -> AppT Env m LocalBranches
getBranches = m LocalBranches -> AppT Env m LocalBranches
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m LocalBranches -> AppT Env m LocalBranches)
-> (Maybe FilePath -> m LocalBranches)
-> Maybe FilePath
-> AppT Env m LocalBranches
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> m LocalBranches
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> m LocalBranches
getBranches
  updateBranch :: Maybe FilePath -> MergeType -> Name -> AppT Env m UpdateResult
updateBranch path :: Maybe FilePath
path mergeType :: MergeType
mergeType = m UpdateResult -> AppT Env m UpdateResult
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m UpdateResult -> AppT Env m UpdateResult)
-> (Name -> m UpdateResult) -> Name -> AppT Env m UpdateResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> MergeType -> Name -> m UpdateResult
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> MergeType -> Name -> m UpdateResult
updateBranch Maybe FilePath
path MergeType
mergeType
  pushBranches :: Maybe FilePath -> [Name] -> AppT Env m [UpdateResult]
pushBranches path :: Maybe FilePath
path = m [UpdateResult] -> AppT Env m [UpdateResult]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m [UpdateResult] -> AppT Env m [UpdateResult])
-> ([Name] -> m [UpdateResult])
-> [Name]
-> AppT Env m [UpdateResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> [Name] -> m [UpdateResult]
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> [Name] -> m [UpdateResult]
pushBranches Maybe FilePath
path
  checkoutCurrent :: Maybe FilePath -> Name -> AppT Env m ()
checkoutCurrent path :: Maybe FilePath
path = m () -> AppT Env m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m () -> AppT Env m ()) -> (Name -> m ()) -> Name -> AppT Env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> Name -> m ()
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> Name -> m ()
checkoutCurrent Maybe FilePath
path

-- | High level logic of `MonadUpdateBranches` usage. This function is the
-- entrypoint for any `MonadUpdateBranches` instance.
runUpdateBranches :: (R.MonadReader Env m, MonadLogger m, MonadUpdateBranches m) => m ()
runUpdateBranches :: m ()
runUpdateBranches = do
  Env {Maybe FilePath
path :: Env -> Maybe FilePath
path :: Maybe FilePath
path, MergeType
mergeType :: Env -> MergeType
mergeType :: MergeType
mergeType, [Name]
push :: Env -> [Name]
push :: [Name]
push, Bool
doFetch :: Env -> Bool
doFetch :: Bool
doFetch} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  if Bool
doFetch
    then Maybe FilePath -> m ()
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> m ()
fetch Maybe FilePath
path
    else () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LocalBranches {Name
current :: LocalBranches -> Name
current :: Name
current, [Name]
branches :: LocalBranches -> [Name]
branches :: [Name]
branches} <- Maybe FilePath -> m LocalBranches
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> m LocalBranches
getBranches Maybe FilePath
path
  [UpdateResult]
updated <- (Name -> m UpdateResult) -> [Name] -> m [UpdateResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe FilePath -> MergeType -> Name -> m UpdateResult
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> MergeType -> Name -> m UpdateResult
updateBranch Maybe FilePath
path MergeType
mergeType) [Name]
branches
  [UpdateResult] -> m ()
forall (m :: * -> *). MonadLogger m => [UpdateResult] -> m ()
logUpdate [UpdateResult]
updated
  [UpdateResult]
pushed <- Maybe FilePath -> [Name] -> m [UpdateResult]
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> [Name] -> m [UpdateResult]
pushBranches Maybe FilePath
path [Name]
push
  [UpdateResult] -> m ()
forall (m :: * -> *). MonadLogger m => [UpdateResult] -> m ()
logPush [UpdateResult]
pushed
  Maybe FilePath -> Name -> m ()
forall (m :: * -> *).
MonadUpdateBranches m =>
Maybe FilePath -> Name -> m ()
checkoutCurrent Maybe FilePath
path Name
current

logUpdate :: MonadLogger m => [UpdateResult] -> m ()
logUpdate :: [UpdateResult] -> m ()
logUpdate updated :: [UpdateResult]
updated = do
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo ""
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue "UPDATE SUMMARY"
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue "--------------"
  SplitResults -> m ()
forall (m :: * -> *). MonadLogger m => SplitResults -> m ()
displaySplits (SplitResults -> m ()) -> SplitResults -> m ()
forall a b. (a -> b) -> a -> b
$ [UpdateResult] -> SplitResults
splitResults [UpdateResult]
updated

logPush :: MonadLogger m => [UpdateResult] -> m ()
logPush :: [UpdateResult] -> m ()
logPush pushed :: [UpdateResult]
pushed = do
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo ""
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue "PUSH SUMMARY"
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue "------------"
  SplitResults -> m ()
forall (m :: * -> *). MonadLogger m => SplitResults -> m ()
displaySplits (SplitResults -> m ()) -> SplitResults -> m ()
forall a b. (a -> b) -> a -> b
$ [UpdateResult] -> SplitResults
splitResults [UpdateResult]
pushed

displaySplits :: MonadLogger m => SplitResults -> m ()
displaySplits :: SplitResults -> m ()
displaySplits SplitResults {[FilePath]
successes :: SplitResults -> [FilePath]
successes :: [FilePath]
successes, [FilePath]
noChanges :: SplitResults -> [FilePath]
noChanges :: [FilePath]
noChanges, [FilePath]
failures :: SplitResults -> [FilePath]
failures :: [FilePath]
failures} = do
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoSuccess (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Successes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
successes)
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "No Change: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
noChanges)
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Failures: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
failures) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"

failFast :: IO (Either e a) -> IO (Either e a) -> IO (Either e a)
failFast :: IO (Either e a) -> IO (Either e a) -> IO (Either e a)
failFast io1 :: IO (Either e a)
io1 io2 :: IO (Either e a)
io2 = do
  Either e a
res <- IO (Either e a)
io1
  case Either e a
res of
    Left e :: e
e -> Either e a -> IO (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> IO (Either e a)) -> Either e a -> IO (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left e
e
    Right _ -> IO (Either e a)
io2