{- |
Module      : Singular.Registry.Candidate
Description : Which revision a run's evidence claims to replay
License     : Apache-2.0

Resolves the candidate revision for the row runners (#91): the
@CANDIDATE_SHA@ override wins for smoke runs, else the invocation
repository's @git rev-parse HEAD@, else the @RELEASE-COMMIT@ file a
published release archive carries at its root — the archive is not a
git checkout, so the file is found by walking up from the working
directory (the runners execute from @offchain/@ inside the extracted
archive). A revision that cannot be established fails closed, never
"unknown".
-}
module Singular.Registry.Candidate
    ( CandidateSource (..)
    , resolveCandidate
    , sourceName
    ) where

import Control.Exception (SomeException, try)
import Data.ByteString qualified as BS
import Data.Char (isSpace)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Environment (lookupEnv)
import System.FilePath (takeDirectory, (</>))
import System.Process (readProcess)

-- | Where a resolved candidate revision came from.
data CandidateSource
    = -- | The @CANDIDATE_SHA@ environment override.
      CandidateFromEnv
    | -- | The invocation repository's @git rev-parse HEAD@.
      CandidateFromGitHead
    | -- | The @RELEASE-COMMIT@ file of a published release archive.
      CandidateFromReleaseCommit
    deriving (CandidateSource -> CandidateSource -> Bool
(CandidateSource -> CandidateSource -> Bool)
-> (CandidateSource -> CandidateSource -> Bool)
-> Eq CandidateSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CandidateSource -> CandidateSource -> Bool
== :: CandidateSource -> CandidateSource -> Bool
$c/= :: CandidateSource -> CandidateSource -> Bool
/= :: CandidateSource -> CandidateSource -> Bool
Eq, Int -> CandidateSource -> ShowS
[CandidateSource] -> ShowS
CandidateSource -> String
(Int -> CandidateSource -> ShowS)
-> (CandidateSource -> String)
-> ([CandidateSource] -> ShowS)
-> Show CandidateSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CandidateSource -> ShowS
showsPrec :: Int -> CandidateSource -> ShowS
$cshow :: CandidateSource -> String
show :: CandidateSource -> String
$cshowList :: [CandidateSource] -> ShowS
showList :: [CandidateSource] -> ShowS
Show)

-- | Stable name for the source, as recorded in a run's @meta.json@.
sourceName :: CandidateSource -> String
sourceName :: CandidateSource -> String
sourceName CandidateSource
CandidateFromEnv = String
"env"
sourceName CandidateSource
CandidateFromGitHead = String
"git"
sourceName CandidateSource
CandidateFromReleaseCommit = String
"release-commit"

{- | Candidate revision, derived not told: an explicit override wins for
smoke runs, else the invocation repository's HEAD, else the
RELEASE-COMMIT file of the release archive the working directory sits
in. A revision that cannot be established fails closed — never
"unknown". Worktree cleanliness rides along as before: a @git status@
that cannot be read counts as dirty.
-}
resolveCandidate :: IO (Either String (String, Bool, CandidateSource))
resolveCandidate :: IO (Either String (String, Bool, CandidateSource))
resolveCandidate = do
    override <- String -> IO (Maybe String)
lookupEnv String
"CANDIDATE_SHA"
    headOut <-
        try (readProcess "git" ["rev-parse", "HEAD"] "")
            :: IO (Either SomeException String)
    statusOut <-
        try (readProcess "git" ["status", "--porcelain"] "")
            :: IO (Either SomeException String)
    let dirty = case Either SomeException String
statusOut of
            Right String
status -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
status
            Left SomeException
_ -> Bool
True
    case (override, headOut) of
        (Just String
sha, Either SomeException String
_) -> Either String (String, Bool, CandidateSource)
-> IO (Either String (String, Bool, CandidateSource))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Bool, CandidateSource)
-> Either String (String, Bool, CandidateSource)
forall a b. b -> Either a b
Right (String
sha, Bool
dirty, CandidateSource
CandidateFromEnv))
        (Maybe String
Nothing, Right String
sha) -> Either String (String, Bool, CandidateSource)
-> IO (Either String (String, Bool, CandidateSource))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Bool, CandidateSource)
-> Either String (String, Bool, CandidateSource)
forall a b. b -> Either a b
Right (ShowS
trim String
sha, Bool
dirty, CandidateSource
CandidateFromGitHead))
        (Maybe String
Nothing, Left SomeException
_) -> do
            fromArchive <- IO (Maybe String)
releaseCommitAbove
            pure $ case fromArchive of
                Just String
sha -> (String, Bool, CandidateSource)
-> Either String (String, Bool, CandidateSource)
forall a b. b -> Either a b
Right (String
sha, Bool
dirty, CandidateSource
CandidateFromReleaseCommit)
                Maybe String
Nothing ->
                    String -> Either String (String, Bool, CandidateSource)
forall a b. a -> Either a b
Left
                        String
"candidate: cannot establish repository revision: \
                        \no CANDIDATE_SHA, no git HEAD, and no RELEASE-COMMIT \
                        \in any parent directory"

{- | The RELEASE-COMMIT file of a release archive above the working
directory (#91): runners execute from @offchain/@ inside the
extracted archive, so the file sits in a parent directory. Empty
entries do not shadow: the walk continues.
-}
releaseCommitAbove :: IO (Maybe String)
releaseCommitAbove :: IO (Maybe String)
releaseCommitAbove = do
    cwd <- IO String
getCurrentDirectory
    go (ancestors cwd)
  where
    ancestors :: String -> [String]
ancestors String
dir =
        String
dir
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: case ShowS
takeDirectory String
dir of
                String
parent
                    | String
parent String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dir -> []
                    | Bool
otherwise -> String -> [String]
ancestors String
parent
    go :: [String] -> IO (Maybe String)
go [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    go (String
dir : [String]
rest) = do
        let path :: String
path = String
dir String -> ShowS
</> String
"RELEASE-COMMIT"
        exists <- String -> IO Bool
doesFileExist String
path
        if not exists
            then go rest
            else do
                bytes <- BS.readFile path
                case trim (T.unpack (TE.decodeUtf8Lenient bytes)) of
                    [] -> [String] -> IO (Maybe String)
go [String]
rest
                    String
sha -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
sha)

-- | Whitespace, including the trailing newline, off both ends.
trim :: String -> String
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse