{-# LANGUAGE QuasiQuotes #-}

-- | Provides utilities for querying git.
--
-- @since 0.1
module Development.GitRev.Utils.Git
  ( GitError (..),
    gitBranchQ,
    gitCommitCountQ,
    gitCommitDateQ,
    gitDescribeQ,
    gitDiffQ,
    gitDirtyQ,
    gitDirtyTrackedQ,
    gitHashQ,
    gitShortHashQ,
    gitTreeQ,
  )
where

import Control.Exception
  ( Exception (displayException, fromException),
    SomeAsyncException (SomeAsyncException),
    SomeException,
    catchJust,
    throwIO,
    toException,
  )
import Control.Monad (when, (<=<))
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TEnc
import Language.Haskell.TH (Q, runIO)
import Language.Haskell.TH.Syntax (Lift, addDependentFile)
import System.Directory.OsPath
  ( doesDirectoryExist,
    doesFileExist,
    findExecutable,
    getCurrentDirectory,
  )
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.File.OsPath qualified as FileIO
import System.OsPath (OsPath, osp, (</>))
import System.OsPath qualified as OsPath
import System.OsString qualified as OsString
import System.Process (readProcessWithExitCode)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> import Development.GitRev.Typed (qToCode)

-- | Returns the latest git hash.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitHashQ)
-- Right ...
--
-- @since 0.1
gitHashQ :: Q (Either GitError String)
gitHashQ :: Q (Either GitError String)
gitHashQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"rev-parse", String
"HEAD"] IndexUsed
IdxNotUsed

-- | Returns the latest git short hash.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitShortHashQ)
-- Right ...
--
-- @since 0.1
gitShortHashQ :: Q (Either GitError String)
gitShortHashQ :: Q (Either GitError String)
gitShortHashQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"rev-parse", String
"--short", String
"HEAD"] IndexUsed
IdxNotUsed

-- | Returns the current git branch.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitBranchQ)
-- Right ...
--
-- @since 0.1
gitBranchQ :: Q (Either GitError String)
gitBranchQ :: Q (Either GitError String)
gitBranchQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"rev-parse", String
"--abbrev-ref", String
"HEAD"] IndexUsed
IdxNotUsed

-- | Returns the git description.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitDescribeQ)
-- Right ...
--
-- @since 0.1
gitDescribeQ :: Q (Either GitError String)
gitDescribeQ :: Q (Either GitError String)
gitDescribeQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"describe", String
"--long", String
"--always"] IndexUsed
IdxNotUsed

-- | Returns the git dirty status.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitDirtyQ)
-- Right ...
--
-- @since 0.1
gitDirtyQ :: Q (Either GitError Bool)
gitDirtyQ :: Q (Either GitError Bool)
gitDirtyQ = (String -> Bool) -> Either GitError String -> Either GitError Bool
forall a b. (a -> b) -> Either GitError a -> Either GitError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Bool
nonEmpty (Either GitError String -> Either GitError Bool)
-> Q (Either GitError String) -> Q (Either GitError Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"status", String
"--porcelain"] IndexUsed
IdxUsed

-- | Returns the git dirty status, ignoring untracked files.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitDirtyTrackedQ)
-- Right ...
--
-- @since 0.1
gitDirtyTrackedQ :: Q (Either GitError Bool)
gitDirtyTrackedQ :: Q (Either GitError Bool)
gitDirtyTrackedQ =
  (String -> Bool) -> Either GitError String -> Either GitError Bool
forall a b. (a -> b) -> Either GitError a -> Either GitError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Bool
nonEmpty
    (Either GitError String -> Either GitError Bool)
-> Q (Either GitError String) -> Q (Either GitError Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"status", String
"--porcelain", String
"--untracked-files=no"] IndexUsed
IdxUsed

-- | Returns the git commit count.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitCommitCountQ)
-- Right ...
--
-- @since 0.1
gitCommitCountQ :: Q (Either GitError String)
gitCommitCountQ :: Q (Either GitError String)
gitCommitCountQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"rev-list", String
"HEAD", String
"--count"] IndexUsed
IdxNotUsed

-- | Returns the latest git commit date.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitCommitDateQ)
-- Right ...
--
-- @since 0.1
gitCommitDateQ :: Q (Either GitError String)
gitCommitDateQ :: Q (Either GitError String)
gitCommitDateQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"log", String
"HEAD", String
"-1", String
"--format=%cd"] IndexUsed
IdxNotUsed

-- | Return the diff of the working copy with HEAD.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitDiffQ)
-- Right ...
--
-- @since 0.1
gitDiffQ :: Q (Either GitError String)
gitDiffQ :: Q (Either GitError String)
gitDiffQ = (String -> String)
-> [String] -> IndexUsed -> Q (Either GitError String)
runGitPostprocess String -> String
forall a. a -> a
id [String
"diff", String
"HEAD"] IndexUsed
IdxNotUsed

-- | Returns the hash of the current tree.
--
-- ==== __Examples__
--
-- >>> $$(qToCode gitTreeQ)
-- Right ...
--
-- @since 0.1
gitTreeQ :: Q (Either GitError String)
gitTreeQ :: Q (Either GitError String)
gitTreeQ = [String] -> IndexUsed -> Q (Either GitError String)
runGit [String
"show", String
"HEAD", String
"--format=%T", String
"--no-patch"] IndexUsed
IdxNotUsed

nonEmpty :: String -> Bool
nonEmpty :: String -> Bool
nonEmpty String
"" = Bool
False
nonEmpty String
_ = Bool
True

-- | Errors that can be encountered with git.
--
-- @since 0.1
data GitError
  = -- | @since 0.1
    GitNotFound
  | -- | @since 0.1
    GitRunError String
  deriving stock
    ( -- | @since 0.1
      GitError -> GitError -> Bool
(GitError -> GitError -> Bool)
-> (GitError -> GitError -> Bool) -> Eq GitError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitError -> GitError -> Bool
== :: GitError -> GitError -> Bool
$c/= :: GitError -> GitError -> Bool
/= :: GitError -> GitError -> Bool
Eq,
      -- | @since 0.1
      (forall (m :: * -> *). Quote m => GitError -> m Exp)
-> (forall (m :: * -> *). Quote m => GitError -> Code m GitError)
-> Lift GitError
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => GitError -> m Exp
forall (m :: * -> *). Quote m => GitError -> Code m GitError
$clift :: forall (m :: * -> *). Quote m => GitError -> m Exp
lift :: forall (m :: * -> *). Quote m => GitError -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => GitError -> Code m GitError
liftTyped :: forall (m :: * -> *). Quote m => GitError -> Code m GitError
Lift,
      -- | @since 0.1
      Int -> GitError -> String -> String
[GitError] -> String -> String
GitError -> String
(Int -> GitError -> String -> String)
-> (GitError -> String)
-> ([GitError] -> String -> String)
-> Show GitError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GitError -> String -> String
showsPrec :: Int -> GitError -> String -> String
$cshow :: GitError -> String
show :: GitError -> String
$cshowList :: [GitError] -> String -> String
showList :: [GitError] -> String -> String
Show
    )

-- | @since 0.1
instance Exception GitError where
  displayException :: GitError -> String
displayException GitError
GitNotFound = String
"Git executable not found"
  displayException (GitRunError String
s) = String
"Git error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

runGit :: [String] -> IndexUsed -> Q (Either GitError String)
runGit :: [String] -> IndexUsed -> Q (Either GitError String)
runGit = (String -> String)
-> [String] -> IndexUsed -> Q (Either GitError String)
runGitPostprocess String -> String
tillNewLineStr

-- | Run git with the given arguments and no stdin, returning the
-- stdout output.
runGitPostprocess ::
  -- | Post-processing on the result.
  (String -> String) ->
  -- | Args to run with git.
  [String] ->
  -- | Whether the index is used.
  IndexUsed ->
  Q (Either GitError String)
runGitPostprocess :: (String -> String)
-> [String] -> IndexUsed -> Q (Either GitError String)
runGitPostprocess String -> String
postProcess [String]
args IndexUsed
useIdx = do
  let oops :: SomeException -> IO (ExitCode, String, String)
      oops :: SomeException -> IO (ExitCode, String, String)
oops SomeException
ex = (ExitCode, String, String) -> IO (ExitCode, String, String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure Int
1, String
"", SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex)
  gitFound <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Maybe OsPath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe OsPath -> Bool) -> IO (Maybe OsPath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> IO (Maybe OsPath)
findExecutable [osp|git|]
  if gitFound
    then do
      -- a lot of bookkeeping to record the right dependencies
      pwd <- runIO getDotGit
      let hd = OsPath
pwd OsPath -> OsPath -> OsPath
</> [osp|HEAD|]
          index = OsPath
pwd OsPath -> OsPath -> OsPath
</> [osp|index|]
          packedRefs = OsPath
pwd OsPath -> OsPath -> OsPath
</> [osp|packed-refs|]
      hdFp <- OsPath.decodeUtf hd
      hdExists <- runIO $ doesFileExist hd
      when hdExists $ do
        addDependentFile hdFp
        -- the HEAD file either contains the hash of a detached head
        -- or a pointer to the file that contains the hash of the head
        T.splitAt 5 <$> runIO (readFileUtf8 hd) >>= \case
          -- pointer to ref
          (Text
"ref: ", Text
relRef) -> do
            relRefOs <- String -> Q OsPath
forall (m :: * -> *). MonadThrow m => String -> m OsPath
OsPath.encodeUtf (String -> Q OsPath) -> String -> Q OsPath
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
relRef
            let ref = OsPath
pwd OsPath -> OsPath -> OsPath
</> OsPath -> OsPath
tillNewLineOsPath OsPath
relRefOs
            refExists <- runIO $ doesFileExist ref
            refFp <- OsPath.decodeUtf ref
            when refExists $ addDependentFile refFp
          -- detached head
          (Text, Text)
_hash -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- add the index if it exists to set the dirty flag
      indexExists <- runIO $ doesFileExist index
      when (indexExists && useIdx == IdxUsed) $ do
        indexFp <- OsPath.decodeUtf index
        addDependentFile indexFp
      -- if the refs have been packed, the info we're looking for
      -- might be in that file rather than the one-file-per-ref case
      -- handled above
      packedExists <- runIO $ doesFileExist packedRefs
      when packedExists $ do
        packedRefsFp <- OsPath.decodeUtf packedRefs
        addDependentFile packedRefsFp
      runIO $ do
        (code, out, err) <-
          readProcessWithExitCode "git" args "" `catchSync` oops
        case code of
          ExitCode
ExitSuccess -> Either GitError String -> IO (Either GitError String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GitError String -> IO (Either GitError String))
-> Either GitError String -> IO (Either GitError String)
forall a b. (a -> b) -> a -> b
$ String -> Either GitError String
forall a b. b -> Either a b
Right (String -> String
postProcess String
out)
          ExitFailure Int
_ -> Either GitError String -> IO (Either GitError String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GitError String -> IO (Either GitError String))
-> Either GitError String -> IO (Either GitError String)
forall a b. (a -> b) -> a -> b
$ GitError -> Either GitError String
forall a b. a -> Either a b
Left (GitError -> Either GitError String)
-> GitError -> Either GitError String
forall a b. (a -> b) -> a -> b
$ String -> GitError
GitRunError String
err
    else pure $ Left GitNotFound

tillNewLineStr :: String -> String
tillNewLineStr :: String -> String
tillNewLineStr = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')

tillNewLineOsPath :: OsPath -> OsPath
tillNewLineOsPath :: OsPath -> OsPath
tillNewLineOsPath = (OsChar -> Bool) -> OsPath -> OsPath
OsString.takeWhile (\OsChar
c -> OsChar
c OsChar -> OsChar -> Bool
forall a. Eq a => a -> a -> Bool
/= OsChar
nl Bool -> Bool -> Bool
&& OsChar
c OsChar -> OsChar -> Bool
forall a. Eq a => a -> a -> Bool
/= OsChar
cr)
  where
    nl :: OsChar
nl = Char -> OsChar
OsString.unsafeFromChar Char
'\n'
    cr :: OsChar
cr = Char -> OsChar
OsString.unsafeFromChar Char
'\r'

-- | Determine where our @.git@ directory is, in case we're in a
-- submodule.
getDotGit :: IO OsPath
getDotGit :: IO OsPath
getDotGit = do
  pwd <- IO OsPath
getGitRoot
  let dotGit = OsPath
pwd OsPath -> OsPath -> OsPath
</> [osp|.git|]
      oops = OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsPath
dotGit -- it's gonna fail, that's fine
  isDir <- doesDirectoryExist dotGit

  if isDir
    then pure dotGit
    else do
      isFile <- doesFileExist dotGit
      if isFile
        then do
          T.splitAt 8 <$> readFileUtf8 dotGit >>= \case
            (Text
"gitdir: ", Text
relDir) -> do
              relDirOs <- String -> IO OsPath
forall (m :: * -> *). MonadThrow m => String -> m OsPath
OsPath.encodeUtf (String -> IO OsPath) -> String -> IO OsPath
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
relDir
              isRelDir <- doesDirectoryExist relDirOs
              if isRelDir
                then pure relDirOs
                else oops
            (Text, Text)
_ -> IO OsPath
oops
        else oops

readFileUtf8 :: OsPath -> IO Text
readFileUtf8 :: OsPath -> IO Text
readFileUtf8 =
  ((UnicodeException -> IO Text)
-> (Text -> IO Text) -> Either UnicodeException Text -> IO Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UnicodeException -> IO Text
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    (Either UnicodeException Text -> IO Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
TEnc.decodeUtf8'
    (ByteString -> IO Text)
-> (OsPath -> IO ByteString) -> OsPath -> IO Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< OsPath -> IO ByteString
FileIO.readFile'

-- | Get the root directory of the Git repo.
getGitRoot :: IO OsPath
getGitRoot :: IO OsPath
getGitRoot = do
  pwd <- IO OsPath
getCurrentDirectory
  (code, out, _) <-
    readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
  out' <- OsPath.encodeUtf out
  case code of
    ExitCode
ExitSuccess -> OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OsPath -> IO OsPath) -> OsPath -> IO OsPath
forall a b. (a -> b) -> a -> b
$ OsPath -> OsPath
tillNewLineOsPath OsPath
out'
    ExitFailure Int
_ -> OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsPath
pwd -- later steps will fail, that's fine

-- | Type to flag if the git index is used or not in a call to runGit
data IndexUsed
  = -- | The git index is used
    IdxUsed
  | -- | The git index is /not/ used
    IdxNotUsed
  deriving stock (IndexUsed -> IndexUsed -> Bool
(IndexUsed -> IndexUsed -> Bool)
-> (IndexUsed -> IndexUsed -> Bool) -> Eq IndexUsed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexUsed -> IndexUsed -> Bool
== :: IndexUsed -> IndexUsed -> Bool
$c/= :: IndexUsed -> IndexUsed -> Bool
/= :: IndexUsed -> IndexUsed -> Bool
Eq)

catchSync :: IO a -> (SomeException -> IO a) -> IO a
catchSync :: forall a. IO a -> (SomeException -> IO a) -> IO a
catchSync = (SomeException -> Bool) -> IO a -> (SomeException -> IO a) -> IO a
forall e a.
Exception e =>
(e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchIf SomeException -> Bool
forall e. Exception e => e -> Bool
isSyncException

catchIf ::
  (Exception e) =>
  (e -> Bool) ->
  IO a ->
  (e -> IO a) ->
  IO a
catchIf :: forall e a.
Exception e =>
(e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchIf e -> Bool
p = (e -> Maybe e) -> IO a -> (e -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (\e
e -> if e -> Bool
p e
e then e -> Maybe e
forall a. a -> Maybe a
Just e
e else Maybe e
forall a. Maybe a
Nothing)

isSyncException :: (Exception e) => e -> Bool
isSyncException :: forall e. Exception e => e -> Bool
isSyncException e
e = case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) of
  Just SomeAsyncException {} -> Bool
False
  Maybe SomeAsyncException
Nothing -> Bool
True