Git.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}

{-|

Helpers for deriving advisory metadata from a Git repo.

-}
module Security.Advisories.Git
  ( AdvisoryGitInfo(..)
  , GitError(..)
  , explainGitError
  , getAdvisoryGitInfo
  , getRepoRoot
  , add
  , commit
  )
  where

import Data.Char (isSpace)
import Data.List (dropWhileEnd)
import Data.Time (UTCTime, zonedTimeToUTC)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath (splitFileName)
import System.Process (readProcessWithExitCode)
import Control.Applicative ((<|>))

data AdvisoryGitInfo = AdvisoryGitInfo
  { firstAppearanceCommitDate :: UTCTime
  , lastModificationCommitDate :: UTCTime
  }

data GitError
  = GitProcessError ExitCode String String -- ^ exit code, stdout and stderr
  | GitTimeParseError String -- ^ unable to parse this input as a datetime
  deriving stock (Eq, Ord, Show)

explainGitError :: GitError -> String
explainGitError = \case
  GitProcessError status stdout stderr ->
    unlines
      [ "git exited with status " <> show status
      , ">>> standard output:"
      , stdout
      , ">>> standard error:"
      , stderr
      ]
  GitTimeParseError s ->
    "failed to parse time: " <> s

-- | Get top-level directory of the working tree.
--
getRepoRoot :: FilePath -> IO (Either GitError FilePath)
getRepoRoot path = do
  (status, stdout, stderr) <- readProcessWithExitCode
    "git"
    [ "-C", path
    , "rev-parse"
    , "--show-toplevel"
    ]
    "" -- standard input
  pure $ case status of
    ExitSuccess -> Right $ trim stdout
    _ -> Left $ GitProcessError status stdout stderr
  where
    trim = dropWhileEnd isSpace . dropWhile isSpace

-- | Add changes to index
--
add
  :: FilePath   -- ^ path to working tree
  -> [FilePath] -- ^ files to update in index
  -> IO (Either GitError ())
add path pathspecs = do
  (status, stdout, stderr) <- readProcessWithExitCode
    "git"
    ( ["-C", path, "add"] <> pathspecs )
    "" -- standard input
  pure $ case status of
    ExitSuccess -> Right ()
    _ -> Left $ GitProcessError status stdout stderr

-- | Commit changes to repo.
--
commit
  :: FilePath   -- ^ path to working tree
  -> String     -- ^ commit message
  -> IO (Either GitError ())
commit path msg = do
  (status, stdout, stderr) <- readProcessWithExitCode
    "git"
    ["-C", path, "commit", "-m", msg]
    "" -- standard input
  pure $ case status of
    ExitSuccess -> Right ()
    _ -> Left $ GitProcessError status stdout stderr

getAdvisoryGitInfo :: FilePath -> IO (Either GitError AdvisoryGitInfo)
getAdvisoryGitInfo path = do
  let (dir, file) = splitFileName path
  (status, stdout, stderr) <- readProcessWithExitCode
    "git"
    [ "-C", dir
    , "log"
    , "--pretty=format:%cI"  -- print committer date
    , "--find-renames"
    , file
    ]
    "" -- standard input
  let timestamps = filter (not . null) $ lines stdout
  case status of
    ExitSuccess | not (null timestamps) ->
      pure $ AdvisoryGitInfo
        <$> parseTime (last timestamps)  -- first commit is last line
        <*> parseTime (head timestamps)  -- most recent commit is first line
    _ ->
      -- `null lines` should not happen, but if it does we treat it
      -- the same as `ExitFailure`
      pure . Left $ GitProcessError status stdout stderr
  where
    parseTime :: String -> Either GitError UTCTime
    parseTime s = maybe (Left $ GitTimeParseError s) Right $
       iso8601ParseM s
         <|> zonedTimeToUTC <$> iso8601ParseM s