{-# LANGUAGE BlockArguments #-}

module Hercules.CLI.Git where

import Data.List (dropWhileEnd)
import qualified Data.Text as T
import Hercules.CLI.Exception (exitMsg)
import Protolude
import System.Directory (doesDirectoryExist)
import System.Process (readProcess)

readProcessString :: FilePath -> [[Char]] -> [Char] -> IO [Char]
readProcessString :: String -> [String] -> String -> IO String
readProcessString String
exe [String]
args String
input = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
exe [String]
args String
input

readProcessItem :: FilePath -> [[Char]] -> [Char] -> IO Text
readProcessItem :: String -> [String] -> String -> IO Text
readProcessItem String
exe [String]
args String
input = String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcessString String
exe [String]
args String
input

getGitRoot :: IO FilePath
getGitRoot :: IO String
getGitRoot = do
  String
p <- String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--show-toplevel"] String
forall a. Monoid a => a
mempty
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesDirectoryExist String
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"git root `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not a directory?"
  String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p

getRemotes :: IO [Text]
getRemotes :: IO [Text]
getRemotes = String -> [String] -> String -> IO String
readProcess String
"git" [String
"remote"] String
forall a. Monoid a => a
mempty IO String -> (String -> Text) -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Text
forall a b. ConvertText a b => a -> b
toS IO Text -> (Text -> [Text]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> [Text]
lines IO [Text] -> ([Text] -> [Text]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"")

getRef :: IO Text
getRef :: IO Text
getRef = do
  String -> [String] -> String -> IO Text
readProcessItem String
"git" [String
"rev-parse", String
"--symbolic-full-name", String
"HEAD"] String
forall a. Monoid a => a
mempty

getRev :: IO Text
getRev :: IO Text
getRev = do
  String -> [String] -> String -> IO Text
readProcessItem String
"git" [String
"rev-parse", String
"HEAD"] String
forall a. Monoid a => a
mempty

-- | rev (sha) and ref
getRevsAndRefs :: IO [(Text, Text)]
getRevsAndRefs :: IO [(Text, Text)]
getRevsAndRefs =
  -- restrict to heads and tags, because other ones aren't relevant on CI, probably
  String -> [String] -> String -> IO String
readProcess String
"git" [String
"show-ref"] String
forall a. Monoid a => a
mempty IO String -> (String -> [(Text, Text)]) -> IO [(Text, Text)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
x ->
    String
x String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
forall a b. ConvertText a b => a -> b
toS
      Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
T.lines
      [Text] -> ([Text] -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
& (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map \Text
ln ->
        Text
ln
          Text -> (Text -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace
          (Text, Text) -> ((Text, Text) -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace)

getRefs :: IO [Text]
getRefs :: IO [Text]
getRefs = IO [(Text, Text)]
getRevsAndRefs IO [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd

getHypotheticalRefs :: IO [Text]
getHypotheticalRefs :: IO [Text]
getHypotheticalRefs = do
  [Text]
refs <- IO [Text]
getRefs
  [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ([Text]
refs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]
allBranches [Text]
refs))

allBranches :: [Text] -> [Text]
allBranches :: [Text] -> [Text]
allBranches = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
filterRef
  where
    filterRef :: Text -> [Text]
filterRef Text
ref =
      Maybe Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Text -> Text -> Maybe Text
T.stripPrefix Text
"refs/heads/" Text
ref)
        [Text] -> [Text] -> [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Text -> Text -> Maybe Text
T.stripPrefix Text
"refs/remotes/" Text
ref)

getAllBranches :: IO [Text]
getAllBranches :: IO [Text]
getAllBranches = IO [Text]
getRefs IO [Text] -> ([Text] -> [Text]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Text] -> [Text]
allBranches

getUpstreamURL :: IO Text
getUpstreamURL :: IO Text
getUpstreamURL = do
  [Text]
remotes <- IO [Text]
getRemotes
  case [Text]
remotes of
    [Text
x] -> Text -> IO Text
getRemoteURL Text
x
    [Text]
_ -> do
      (IO Text
getBranchUpstream IO Text -> (Text -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO Text
getRemoteURL) IO Text -> IO () -> IO Text
forall a b. IO a -> IO b -> IO a
`onException` do
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: could not determine git upstream repository url"

getBranchUpstream :: IO Text
getBranchUpstream :: IO Text
getBranchUpstream = do
  String
upstreamRef <-
    String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", String
"@{u}"] String
forall a. Monoid a => a
mempty
      IO String -> IO () -> IO String
forall a b. IO a -> IO b -> IO a
`onException` Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: could not determine current branch's upstream"
  let refsRemotes :: String
refsRemotes = String
"refs/remotes/"
  if String
refsRemotes String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
upstreamRef
    then Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
refsRemotes) String
upstreamRef
    else do
      Text -> IO Text
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"upstream branch is not remote"

getIsDefault :: IO Bool
getIsDefault :: IO Bool
getIsDefault = do
  Text
upstream <- IO Text
getBranchUpstream
  String
upstreamRef <- String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", String
"@{u}"] String
forall a. Monoid a => a
mempty
  String
upstreamDefaultRef <- String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", Text -> String
forall a b. ConvertText a b => a -> b
toS Text
upstream String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/HEAD"] String
forall a. Monoid a => a
mempty
  Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
upstreamRef String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
upstreamDefaultRef)

getRemoteURL :: Text -> IO Text
getRemoteURL :: Text -> IO Text
getRemoteURL Text
remoteName =
  String -> [String] -> String -> IO Text
readProcessItem String
"git" [String
"remote", String
"get-url", Text -> String
forall a b. ConvertText a b => a -> b
toS Text
remoteName] String
forall a. Monoid a => a
mempty