Project.hs

{-# OPTIONS_GHC -Wall #-}

{- | Steps for building a whole project: identifying it, replacing
placeholders in its files as they are prepared, and building with its fonts.

Placeholders such as @${NAME}@ come from environment variables (see
'environmentPlaceholders'), the same for every file, and from the last commit
to change each file (see 'filePlaceholders'), so that a document says when it
last changed. 'placeholderAliases' gives a placeholder the value of another.

A project is a directory, and the build runs with it as the working
directory, so file paths are relative to it, such as @"src/report.fodt"@ and
@"public/report.pdf"@.
-}
module Document.Build.Project (
  -- * Projects
  projectPath,
  projectPathOf,

  -- * Placeholders
  Placeholders,
  environmentPlaceholders,
  directoryName,
  filePlaceholderNames,
  filePlaceholders,
  placeholderValue,
  withPlaceholder,
  placeholderAliases,
  substitutePlaceholders,

  -- * Files
  clean,
  prepareFile,

  -- * Fonts
  withFonts,
) where

import Control.Monad.Reader (ask)
import Control.Monad.Trans.Class (lift)
import Data.Bool (bool)
import Data.List (isPrefixOf, stripPrefix, tails)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as Text
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Document.Build.Build (Build, Command, io, process, say, withTempDirectory)
import Document.Build.Error (CommandLine (..), ReviewBuildError)
import Document.Build.File (copyTo, writeUtf8)
import Document.Build.Git (GitDetails (..), gitDetails, gitLastCommit, gitPlaceholders)
import Document.Build.Replace (replaceStrings, xmlEscape)
import System.Directory (doesDirectoryExist, makeAbsolute, removePathForcibly)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.FilePath (dropTrailingPathSeparator, takeFileName, (</>))
import System.FilePather.Combinators (hasExtension, onFile)

{- | The path of the project in the directory being operated on, such as
@"group/project"@: the environment variable @CI_PROJECT_PATH@,
which GitLab CI sets, or otherwise the path in the URL of the @origin@ git
remote (see 'projectPathOf'), or otherwise the empty string.

Use it to make an exception for one project in a build file.

@since 0.1.0.0
-}
projectPath :: (ReviewBuildError e) => Command e String
projectPath =
  do
    d <- ask
    lift $
      io (lookupEnv "CI_PROJECT_PATH")
        >>= maybe
          ( io (doesDirectoryExist (d </> ".git"))
              >>= bool
                (pure "")
                (projectPathOf . takeWhile (/= '\n') <$> process (CommandLine "git" ["-C", d, "config", "--default", "", "--get", "remote.origin.url"]))
          )
          pure

{- | The project path in a git remote URL: the path after the host, without
@.git@. A remote without a host is a local path, which is used as it is.

>>> projectPathOf "git@gitlab.com:group/project.git"
"group/project"

>>> projectPathOf "https://example.com/group/subgroup/project.git"
"group/subgroup/project"

>>> projectPathOf "/srv/git/project"
"/srv/git/project"

@since 0.1.0.0
-}
projectPathOf :: String -> String
projectPathOf url =
  let u =
        let x = dropTrailingPathSeparator url
         in maybe x reverse (stripPrefix (reverse ".git") (reverse x))
      scheme =
        listToMaybe [drop 3 t | t <- tails u, "://" `isPrefixOf` t]
   in case scheme of
        Just h -> drop 1 (dropWhile (/= '/') h)
        Nothing -> bool u (drop 1 (dropWhile (/= ':') u)) ('@' `elem` u)

{- | Placeholders, such as @${GIT_COMMIT_TIME}@, and their values.

@since 0.1.0.0
-}
type Placeholders = [(String, String)]

{- | Placeholders from environment variables, each by its name without @${@
and @}@, with the command that gives its value when the variable is not set.
For example, for some of the variables that GitLab CI sets:

@
environmentPlaceholders [("CI_PAGES_URL", pure ""), ("CI_PROJECT_TITLE", 'directoryName')]
@

@since 0.1.0.0
-}
environmentPlaceholders :: [(String, Command e String)] -> Command e Placeholders
environmentPlaceholders =
  traverse
    ( \(n, fallback) ->
        (,) ("${" <> n <> "}")
          <$> (lift (io (lookupEnv n)) >>= maybe fallback pure)
    )

{- | The name of the directory being operated on, such as @"project"@ for
@"."@ in @\/home\/user\/project@.

@since 0.1.0.0
-}
directoryName :: Command e String
directoryName =
  ask >>= lift . io . fmap (takeFileName . dropTrailingPathSeparator) . makeAbsolute

{- | The names of the placeholders of 'filePlaceholders', without @${@ and
@}@.

>>> filePlaceholderNames
["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
-}
filePlaceholderNames :: [String]
filePlaceholderNames =
  fmap (takeWhile (/= '}') . drop 2 . fst) (gitPlaceholders (GitDetails "" "" "" "" epoch "" "" epoch "" []))

{- | Placeholders for the last commit to change the file being operated on,
named by 'filePlaceholderNames' (see 'Document.Build.Git.gitPlaceholders').

These are of the file, not of the repository, so a document says when it last
changed, and by whom. A file that no commit has changed, such as a new file,
has the placeholders of the last commit of the repository, with a warning.
Fails with 'Document.Build.Error.ShallowRepository' if the git history is
shallow (see 'Document.Build.Git.gitLastCommit').

@since 0.1.0.0
-}
filePlaceholders :: (ReviewBuildError e) => Command e Placeholders
filePlaceholders =
  do
    p <- ask
    gitPlaceholders
      <$> ( gitLastCommit
              >>= maybe
                (lift (say ("warning: " <> p <> " has no git history, so its placeholders are of the last commit of the repository")) *> onFile "." gitDetails)
                pure
          )

-- | The start of 1970, UTC.
epoch :: UTCTime
epoch =
  posixSecondsToUTCTime 0

{- | The value of a placeholder, by its name without @${@ and @}@.

>>> placeholderValue [("${UPDATED}", "now")] "UPDATED"
"now"

@since 0.1.0.0
-}
placeholderValue :: Placeholders -> String -> String
placeholderValue ph n =
  fromMaybe "" (lookup ("${" <> n <> "}") ph)

{- | Set the value of a placeholder, by its name without @${@ and @}@, adding
it if there is none.

>>> withPlaceholder "PAGES_URL" "https://example.com/" [("${PAGES_URL}", ""), ("${TITLE}", "Report")]
[("${PAGES_URL}","https://example.com/"),("${TITLE}","Report")]

>>> withPlaceholder "PAGES_URL" "https://example.com/" [("${TITLE}", "Report")]
[("${TITLE}","Report"),("${PAGES_URL}","https://example.com/")]

@since 0.1.0.0
-}
withPlaceholder :: String -> String -> Placeholders -> Placeholders
withPlaceholder n v ph =
  let k = "${" <> n <> "}"
   in maybe (ph <> [(k, v)]) (const (fmap (\(k', x) -> (k', bool x v (k' == k))) ph)) (lookup k ph)

{- | Add placeholders that have the values of others, each as a pair of names
without @${@ and @}@: the new placeholder, and the placeholder whose value it
has. A placeholder with no value has the empty string.

>>> placeholderAliases [("UPDATED", "GIT_COMMIT_TIME")] [("${GIT_COMMIT_TIME}", "2026-10-09 01:02:03 UTC")]
[("${GIT_COMMIT_TIME}","2026-10-09 01:02:03 UTC"),("${UPDATED}","2026-10-09 01:02:03 UTC")]

@since 0.1.0.0
-}
placeholderAliases :: [(String, String)] -> Placeholders -> Placeholders
placeholderAliases as ph =
  foldl (\x (n, v) -> withPlaceholder n (placeholderValue ph v) x) ph as

{- | Replace placeholders in the file being operated on, writing to a file
path, and return the file path. Values are escaped for XML files (flat
LibreOffice files, HTML and SVG), and inserted as they are into other files.

@since 0.1.0.0
-}
substitutePlaceholders :: (ReviewBuildError e) => Placeholders -> FilePath -> Command e FilePath
substitutePlaceholders ph o =
  do
    p <- ask
    let xml = hasExtension ["fodt", "fods", "fodg", "fodp", "html", "svg"] p
    replaceStrings (bool ph (fmap (fmap xmlEscape) ph) xml) o

{- | Remove a directory, such as the output of an earlier build.

@since 0.1.0.0
-}
clean :: FilePath -> Build e ()
clean d =
  say ("+ rm -rf " <> d) *> io (removePathForcibly d)

{- | Prepare the file being operated on as a file path, and return the file
path: replace placeholders in it if it has one of the given extensions (see
'substitutePlaceholders'), and copy it otherwise. The placeholders are a
command, run on the file being operated on, only if it has one of the
extensions, such as 'filePlaceholders'.

@since 0.1.0.0
-}
prepareFile :: (ReviewBuildError e) => [String] -> Command e Placeholders -> FilePath -> Command e FilePath
prepareFile text ph o =
  ask >>= bool (copyTo o) (ph >>= \x -> substitutePlaceholders x o) . hasExtension text

{- | Run a build with the fonts in a directory available to LibreOffice and
pandoc, through a fontconfig file in a temporary directory, if the directory
exists, so that documents look the same on every machine.

@since 0.1.0.0
-}
withFonts :: FilePath -> Build e a -> Build e a
withFonts dir b =
  io (doesDirectoryExist dir)
    >>= bool
      b
      ( withTempDirectory "fonts" $ \tmp ->
          do
            dir' <- io (makeAbsolute dir)
            conf <-
              writeUtf8 (tmp </> "fonts.conf") . Text.pack . unlines $
                [ "<?xml version=\"1.0\"?>"
                , "<!DOCTYPE fontconfig SYSTEM \"fonts.dtd\">"
                , "<fontconfig>"
                , "  <include ignore_missing=\"yes\">/etc/fonts/fonts.conf</include>"
                , "  <dir>" <> xmlEscape dir' <> "</dir>"
                , "  <cachedir>" <> xmlEscape (tmp </> "fontcache") <> "</cachedir>"
                , "</fontconfig>"
                ]
            io (setEnv "FONTCONFIG_FILE" conf)
            r <- b
            io (unsetEnv "FONTCONFIG_FILE")
            pure r
      )