{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hercules.CLI.Git where

import Data.List (dropWhileEnd)
import qualified Data.Text as T
import Hercules.CLI.Exception (exitMsg)
import Network.URI (URI (uriAuthority), URIAuth (uriRegName), parseURI)
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 = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'\n') 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 = forall a b. ConvertText a b => a -> b
toS 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"] forall a. Monoid a => a
mempty
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesDirectoryExist String
p) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"git root `" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS String
p forall a. Semigroup a => a -> a -> a
<> Text
"` is not a directory?"
  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"] forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. ConvertText a b => a -> b
toS forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> [Text]
lines forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. (a -> Bool) -> [a] -> [a]
filter (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"] 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"] 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"] forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
x ->
    String
x
      forall a b. a -> (a -> b) -> b
& forall a b. ConvertText a b => a -> b
toS
      forall a b. a -> (a -> b) -> b
& Text -> [Text]
T.lines
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map \Text
ln ->
        Text
ln
          forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace
          forall a b. a -> (a -> b) -> b
& 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd

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

allBranches :: [Text] -> [Text]
allBranches :: [Text] -> [Text]
allBranches = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
filterRef
  where
    filterRef :: Text -> [Text]
filterRef Text
ref =
      forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Text -> Text -> Maybe Text
T.stripPrefix Text
"refs/heads/" Text
ref)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO Text
getRemoteURL) forall a b. IO a -> IO b -> IO a
`onException` do
        forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: could not determine git upstream repository url"

getUpstreamRef :: IO Text
getUpstreamRef :: IO Text
getUpstreamRef =
  forall a b. ConvertText a b => a -> b
toS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", String
"@{u}"] forall a. Monoid a => a
mempty

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}"] forall a. Monoid a => a
mempty
      forall a b. IO a -> IO b -> IO a
`onException` 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 forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
upstreamRef
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
refsRemotes) String
upstreamRef
    else do
      forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"upstream branch is not remote"

getCurrentBranchMaybe :: IO (Maybe Text)
getCurrentBranchMaybe :: IO (Maybe Text)
getCurrentBranchMaybe =
  do
    String
x <- String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", String
"HEAD"] forall a. Monoid a => a
mempty

    case String
x of
      Char
'r' : Char
'e' : Char
'f' : Char
's' : Char
'/' : Char
'h' : Char
'e' : Char
'a' : Char
'd' : Char
's' : Char
'/' : String
branch -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall a b. ConvertText a b => a -> b
toS String
branch))
      String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_e :: SomeException) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

getIsDefault :: IO Bool
getIsDefault :: IO Bool
getIsDefault = do
  forall e a. Exception e => IO a -> IO (Either e a)
try IO Text
getUpstreamRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Text
_upstreamRef ->
      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}"] forall a. Monoid a => a
mempty
        String
upstreamDefaultRef <-
          String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", forall a b. ConvertText a b => a -> b
toS Text
upstream forall a. Semigroup a => a -> a -> a
<> String
"/HEAD"] forall a. Monoid a => a
mempty
            forall a b. IO a -> IO b -> IO a
`onException` do
              forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: Could not determine remote default branch"
              forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"     This may happen when the repository was initialized with git init instead of git clone"
              forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"     It can usually be fixed by running:"
              forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"         git remote set-head origin -a"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
upstreamRef forall a. Eq a => a -> a -> Bool
== String
upstreamDefaultRef)
        forall a b. IO a -> IO b -> IO a
`onException` forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: could not determine whether branch matches default branch"
    Left (SomeException
_ :: SomeException) -> do
      IO (Maybe Text)
getCurrentBranchMaybe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Text
Nothing ->
          forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"hci: Can't infer the context of your effect when you're on a git detached head."
        Just Text
x -> do
          [Text]
remotes <- IO [Text]
getRemotes
          case [Text]
remotes of
            [Text
upstream] -> do
              forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: Your branch does not seem to have an upstream. Assuming the local branch name and the single remote."
              String
upstreamDefaultRef <- String -> [String] -> String -> IO String
readProcessString String
"git" [String
"rev-parse", String
"--symbolic-full-name", forall a b. ConvertText a b => a -> b
toS Text
upstream forall a. Semigroup a => a -> a -> a
<> String
"/HEAD"] forall a. Monoid a => a
mempty
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
upstreamDefaultRef forall a. Eq a => a -> a -> Bool
== String
"refs/heads/" forall a. [a] -> [a] -> [a]
++ forall a b. ConvertText a b => a -> b
toS Text
x
            [] ->
              forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"hci: Can't infer whether you're on the default branch, because the repository does not have a remote."
            [Text]
_multiple ->
              forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"hci: Can't infer whether you're on the default branch, because the current branch does not have an upstream, and multiple remotes exist. Please set the upstream for the current branch."

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

-- TODO: store forge type in credentials.json
guessForgeTypeFromURL :: Text -> Maybe Text
guessForgeTypeFromURL :: Text -> Maybe Text
guessForgeTypeFromURL Text
urlString = do
  URI
uri <- String -> Maybe URI
parseURI (forall a b. ConvertText a b => a -> b
toS Text
urlString)
  URIAuth
autho <- URI -> Maybe URIAuth
uriAuthority URI
uri
  let host :: String
host = URIAuth -> String
uriRegName URIAuth
autho
  if String
"github" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
host
    then forall a. a -> Maybe a
Just Text
"github"
    else
      if String
"gitlab" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
host
        then forall a. a -> Maybe a
Just Text
"gitlab"
        else forall a. Maybe a
Nothing