Git.hs

{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall #-}

{- | Commands that get details of files from git, ready to be inserted into
documents.
-}
module Document.Build.Git (
  -- * Details
  readGitDetails,
  gitLastCommit,
  gitLogFormat,
  parseGitLog,

  -- * Placeholders
  gitPlaceholders,
  formatTimeUtc,

  -- * Files
  gitFiles,
) where

import Control.Lens (cloneLens, view)
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Class (lift)
import Data.Bool (bool)
import Data.Containers.ListUtils (nubOrd)
import Data.List (intercalate)
import Data.Time (UTCTime, defaultTimeLocale, formatTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Document.Build.Build (Command, failBuild, io, process)
import Document.Build.CommandLine (CommandLine (..))
import Document.Build.Error (BuildError (..), ReviewBuildError)
import Document.Build.Error.ProcessOutputUnrecognised (ProcessOutputUnrecognised (..))
import Document.Build.GitDetails (GitDetails (..))
import Document.Build.Name.GitAuthorEmail (GitAuthorEmailLike (..))
import Document.Build.Name.GitAuthorName (GitAuthorNameLike (..))
import Document.Build.Name.GitAuthorTime (GitAuthorTimeLike (..))
import Document.Build.Name.GitAuthors (GitAuthorsLike (..))
import Document.Build.Name.GitCommitHash (GitCommitHashLike (..))
import Document.Build.Name.GitCommitHashShort (GitCommitHashShortLike (..))
import Document.Build.Name.GitCommitTime (GitCommitTimeLike (..))
import Document.Build.Name.GitCommitterEmail (GitCommitterEmailLike (..))
import Document.Build.Name.GitCommitterName (GitCommitterNameLike (..))
import Document.Build.Name.GitSubject (GitSubjectLike (..))
import System.Directory (doesDirectoryExist)
import System.FilePath (normalise, takeDirectory, takeFileName, (</>))
import Text.Read (readMaybe)

{- $setup
>>> import Control.Lens (cloneLens, view, (^?), _Just)
-}

{- | The @git log@ format that 'parseGitLog' reads: fields separated by NUL.

@since 0.1.0.0
-}
gitLogFormat :: String
gitLogFormat =
  "%H%x00%h%x00%aN%x00%aE%x00%at%x00%cN%x00%cE%x00%ct%x00%s"

{- | Parse the output of @git log -n 1@ with 'gitLogFormat', and the authors.

>>> let d = parseGitLog "0123abcd\NUL0123\NULTony\NULtony@example.com\NUL0\NULTony\NULtony@example.com\NUL86400\NULfix typo\n" ["Tony <tony@example.com>"]
>>> d ^? _Just . gitSubject
Just "fix typo"

>>> fmap (formatTimeUtc . view (cloneLens gitCommitTime)) d
Just "1970-01-02 00:00:00 UTC"

>>> parseGitLog "" []
Nothing

@since 0.1.0.0
-}
parseGitLog :: String -> [String] -> Maybe GitDetails
parseGitLog s as =
  let time = fmap (posixSecondsToUTCTime . fromInteger) . readMaybe
   in case splitOn '\NUL' (takeWhile (/= '\n') s) of
        [h, h', an, ae, at, cn, ce, ct, subject] ->
          (\at' ct' -> GitDetails h h' an ae at' cn ce ct' subject as) <$> time at <*> time ct
        _ -> Nothing

splitOn :: Char -> String -> [String]
splitOn c s =
  case break (== c) s of
    (a, []) -> [a]
    (a, _ : r) -> a : splitOn c r

{- | Details of the last commit to change the file or directory being operated
on, from @git log@. Fails with 'FileNotInGit' if no commit has changed it, and
with 'ShallowRepository' if the git history is shallow (see 'gitLastCommit').

@since 0.1.0.0
-}
readGitDetails :: (ReviewBuildError e) => Command e GitDetails
readGitDetails =
  do
    p <- ask
    gitLastCommit >>= maybe (lift (failBuild (FileNotInGit p))) pure

{- | Details of the last commit to change the file or directory being operated
on, from @git log@, or 'Nothing' if no commit has changed it, such as a file
that has not been committed.

Fails with 'ShallowRepository' if the git history is shallow, such as a clone
in GitLab CI without @GIT_DEPTH: 0@: the last commit to change a file is not
known if it is older than the history, and the authors are not all known.

@since 0.1.0.0
-}
gitLastCommit :: (ReviewBuildError e) => Command e (Maybe GitDetails)
gitLastCommit =
  do
    p <- ask
    isDirectory <- lift (io (doesDirectoryExist p))
    let (d, f) = bool (takeDirectory p, takeFileName p) (p, ".") isDirectory
        c = CommandLine "git" ["-C", d, "log", "-n", "1", "--format=" <> gitLogFormat, "--", f]
    shallow <- lift (process (CommandLine "git" ["-C", d, "rev-parse", "--is-shallow-repository"]))
    o <-
      lift $
        bool
          (process c)
          (failBuild (ShallowRepository d))
          (takeWhile (/= '\n') shallow == "true")
    if null o
      then pure Nothing
      else do
        as <- lift (process (CommandLine "git" ["-C", d, "log", "--format=%aN <%aE>", "--", f]))
        lift (maybe (failBuild (BuildErrorProcessOutputUnrecognised (ProcessOutputUnrecognised c ("fields in the format " <> gitLogFormat)))) (pure . Just) (parseGitLog o (nubOrd (lines as))))

{- | Placeholders and their values for the details of a commit, to use with
'Document.Build.Replace.replaceStrings'.

>>> fmap fst (gitPlaceholders (GitDetails "" "" "" "" (read "1970-01-01 00:00:00 UTC") "" "" (read "1970-01-01 00:00:00 UTC") "" []))
["${GIT_COMMIT_HASH}","${GIT_COMMIT_HASH_SHORT}","${GIT_AUTHOR_NAME}","${GIT_AUTHOR_EMAIL}","${GIT_AUTHOR_TIME}","${GIT_COMMITTER_NAME}","${GIT_COMMITTER_EMAIL}","${GIT_COMMIT_TIME}","${GIT_SUBJECT}","${GIT_AUTHORS}"]

@since 0.1.0.0
-}
gitPlaceholders :: GitDetails -> [(String, String)]
gitPlaceholders d =
  [ ("${GIT_COMMIT_HASH}", view (cloneLens gitCommitHash) d)
  , ("${GIT_COMMIT_HASH_SHORT}", view (cloneLens gitCommitHashShort) d)
  , ("${GIT_AUTHOR_NAME}", view (cloneLens gitAuthorName) d)
  , ("${GIT_AUTHOR_EMAIL}", view (cloneLens gitAuthorEmail) d)
  , ("${GIT_AUTHOR_TIME}", formatTimeUtc (view (cloneLens gitAuthorTime) d))
  , ("${GIT_COMMITTER_NAME}", view (cloneLens gitCommitterName) d)
  , ("${GIT_COMMITTER_EMAIL}", view (cloneLens gitCommitterEmail) d)
  , ("${GIT_COMMIT_TIME}", formatTimeUtc (view (cloneLens gitCommitTime) d))
  , ("${GIT_SUBJECT}", view (cloneLens gitSubject) d)
  , ("${GIT_AUTHORS}", intercalate ", " (view (cloneLens gitAuthors) d))
  ]

{- | Format a time in UTC, as @YYYY-MM-DD HH:MM:SS UTC@.

>>> formatTimeUtc (read "2026-10-09 01:02:03 UTC")
"2026-10-09 01:02:03 UTC"

@since 0.1.0.0
-}
formatTimeUtc :: UTCTime -> String
formatTimeUtc =
  formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z"
{-# INLINE formatTimeUtc #-}

{- | The files in the git index of the directory being operated on, in the
form of 'System.FilePather.Combinators.directoryFiles'.

@since 0.1.0.0
-}
gitFiles :: (ReviewBuildError e) => Command e [FilePath]
gitFiles =
  do
    d <- ask
    o <- lift (process (CommandLine "git" ["-C", d, "ls-files", "-z"]))
    pure (fmap (normalise . (d </>)) (filter (not . null) (splitOn '\NUL' o)))