Git.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | Commands that get details of files from git, ready to be inserted into
documents.
-}
module Document.Build.Git (
  -- * Details
  GitDetails (..),
  gitCommitHash,
  gitCommitHashShort,
  gitAuthorName,
  gitAuthorEmail,
  gitAuthorTime,
  gitCommitterName,
  gitCommitterEmail,
  gitCommitTime,
  gitSubject,
  gitAuthors,
  gitDetails,
  gitLastCommit,
  gitLogFormat,
  parseGitLog,
  GetGitDetails (..),
  HasGitDetails (..),
  ReviewGitDetails (..),
  AsGitDetails (..),

  -- * Placeholders
  gitPlaceholders,
  formatTimeUtc,

  -- * Files
  gitFiles,
) where

import Control.DeepSeq (NFData)
import Control.Lens (Field1, Field10, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _10, _2, _3, _4, _5, _6, _7, _8, _9)
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Class (lift)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
import Data.Bool (bool)
import Data.Containers.ListUtils (nubOrd)
import Data.Data (Data)
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.Error (BuildError (..), CommandLine (..), ReviewBuildError)
import GHC.Generics (Generic)
import System.Directory (doesDirectoryExist)
import System.FilePath (normalise, takeDirectory, takeFileName, (</>))
import Text.Read (readMaybe)

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

{- | Details of the last commit to change a file, and everyone who has
changed it: the commit hash, abbreviated commit hash, author name, author
email, author time, committer name, committer email, commit time, subject,
and the authors of every commit to change the file as @Name \<email\>@, most
recent first, without duplicates.

@since 0.1.0.0
-}
data GitDetails
  = GitDetails String String String String UTCTime String String UTCTime String [String]
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

-- | @since 0.1.0.0
instance ToJSON GitDetails where
  toJSON (GitDetails h h' an ae at cn ce ct subject as) =
    object
      [ "hash" .= h
      , "hashShort" .= h'
      , "authorName" .= an
      , "authorEmail" .= ae
      , "authorTime" .= at
      , "committerName" .= cn
      , "committerEmail" .= ce
      , "commitTime" .= ct
      , "subject" .= subject
      , "authors" .= as
      ]

-- | @since 0.1.0.0
instance FromJSON GitDetails where
  parseJSON =
    withObject "GitDetails" $ \o ->
      GitDetails
        <$> o .: "hash"
        <*> o .: "hashShort"
        <*> o .: "authorName"
        <*> o .: "authorEmail"
        <*> o .: "authorTime"
        <*> o .: "committerName"
        <*> o .: "committerEmail"
        <*> o .: "commitTime"
        <*> o .: "subject"
        <*> o .: "authors"

-- | @since 0.1.0.0
instance Field1 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field2 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field3 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field4 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field5 GitDetails GitDetails UTCTime UTCTime

-- | @since 0.1.0.0
instance Field6 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field7 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field8 GitDetails GitDetails UTCTime UTCTime

-- | @since 0.1.0.0
instance Field9 GitDetails GitDetails String String

-- | @since 0.1.0.0
instance Field10 GitDetails GitDetails [String] [String]

-- | @since 0.1.0.0
gitCommitHash :: Lens' GitDetails String
gitCommitHash =
  _1
{-# INLINE gitCommitHash #-}

-- | @since 0.1.0.0
gitCommitHashShort :: Lens' GitDetails String
gitCommitHashShort =
  _2
{-# INLINE gitCommitHashShort #-}

-- | @since 0.1.0.0
gitAuthorName :: Lens' GitDetails String
gitAuthorName =
  _3
{-# INLINE gitAuthorName #-}

-- | @since 0.1.0.0
gitAuthorEmail :: Lens' GitDetails String
gitAuthorEmail =
  _4
{-# INLINE gitAuthorEmail #-}

-- | @since 0.1.0.0
gitAuthorTime :: Lens' GitDetails UTCTime
gitAuthorTime =
  _5
{-# INLINE gitAuthorTime #-}

-- | @since 0.1.0.0
gitCommitterName :: Lens' GitDetails String
gitCommitterName =
  _6
{-# INLINE gitCommitterName #-}

-- | @since 0.1.0.0
gitCommitterEmail :: Lens' GitDetails String
gitCommitterEmail =
  _7
{-# INLINE gitCommitterEmail #-}

-- | @since 0.1.0.0
gitCommitTime :: Lens' GitDetails UTCTime
gitCommitTime =
  _8
{-# INLINE gitCommitTime #-}

-- | @since 0.1.0.0
gitSubject :: Lens' GitDetails String
gitSubject =
  _9
{-# INLINE gitSubject #-}

-- | @since 0.1.0.0
gitAuthors :: Lens' GitDetails [String]
gitAuthors =
  _10
{-# INLINE gitAuthors #-}

{- | 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 . (^. 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
-}
gitDetails :: (ReviewBuildError e) => Command e GitDetails
gitDetails =
  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 (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 (GitDetails h h' an ae at cn ce ct subject as) =
  [ ("${GIT_COMMIT_HASH}", h)
  , ("${GIT_COMMIT_HASH_SHORT}", h')
  , ("${GIT_AUTHOR_NAME}", an)
  , ("${GIT_AUTHOR_EMAIL}", ae)
  , ("${GIT_AUTHOR_TIME}", formatTimeUtc at)
  , ("${GIT_COMMITTER_NAME}", cn)
  , ("${GIT_COMMITTER_EMAIL}", ce)
  , ("${GIT_COMMIT_TIME}", formatTimeUtc ct)
  , ("${GIT_SUBJECT}", subject)
  , ("${GIT_AUTHORS}", intercalate ", " as)
  ]

{- | 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)))

-- | @since 0.1.0.0
class GetGitDetails s where
  getGitDetails :: Getter s GitDetails

-- | @since 0.1.0.0
instance GetGitDetails GitDetails where
  getGitDetails =
    id
  {-# INLINE getGitDetails #-}

-- | @since 0.1.0.0
class (GetGitDetails s) => HasGitDetails s where
  {-# MINIMAL setGitDetails #-}
  setGitDetails :: GitDetails -> s -> s

  gitDetailsLens :: Lens' s GitDetails
  gitDetailsLens =
    lens (view getGitDetails) (flip setGitDetails)
  {-# INLINE gitDetailsLens #-}

-- | @since 0.1.0.0
instance HasGitDetails GitDetails where
  setGitDetails =
    const
  {-# INLINE setGitDetails #-}

-- | @since 0.1.0.0
class ReviewGitDetails t where
  reviewGitDetails :: Review t GitDetails

-- | @since 0.1.0.0
instance ReviewGitDetails GitDetails where
  reviewGitDetails =
    unto id
  {-# INLINE reviewGitDetails #-}

-- | @since 0.1.0.0
class (ReviewGitDetails t) => AsGitDetails t where
  {-# MINIMAL matchGitDetails #-}
  matchGitDetails :: t -> Maybe GitDetails

  _GitDetails :: Prism' t GitDetails
  _GitDetails =
    prism' (review reviewGitDetails) matchGitDetails
  {-# INLINE _GitDetails #-}

-- | @since 0.1.0.0
instance AsGitDetails GitDetails where
  matchGitDetails =
    Just
  {-# INLINE matchGitDetails #-}