{-# LANGUAGE LambdaCase #-}

{-|

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 (ZonedTime)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath (splitFileName)
import System.Process (readProcessWithExitCode)

data AdvisoryGitInfo = AdvisoryGitInfo
  { AdvisoryGitInfo -> ZonedTime
firstAppearanceCommitDate :: ZonedTime
  , AdvisoryGitInfo -> ZonedTime
lastModificationCommitDate :: ZonedTime
  }

data GitError
  = GitProcessError ExitCode String String -- ^ exit code, stdout and stderr
  | GitTimeParseError String -- ^ unable to parse this input as a datetime
  deriving (Int -> GitError -> ShowS
[GitError] -> ShowS
GitError -> String
(Int -> GitError -> ShowS)
-> (GitError -> String) -> ([GitError] -> ShowS) -> Show GitError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitError -> ShowS
showsPrec :: Int -> GitError -> ShowS
$cshow :: GitError -> String
show :: GitError -> String
$cshowList :: [GitError] -> ShowS
showList :: [GitError] -> ShowS
Show)

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

-- | Get top-level directory of the working tree.
--
getRepoRoot :: FilePath -> IO (Either GitError FilePath)
getRepoRoot :: String -> IO (Either GitError String)
getRepoRoot String
path = do
  (ExitCode
status, String
stdout, String
stderr) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
    String
"git"
    [ String
"-C", String
path
    , String
"rev-parse"
    , String
"--show-toplevel"
    ]
    String
"" -- standard input
  Either GitError String -> IO (Either GitError String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GitError String -> IO (Either GitError String))
-> Either GitError String -> IO (Either GitError String)
forall a b. (a -> b) -> a -> b
$ case ExitCode
status of
    ExitCode
ExitSuccess -> String -> Either GitError String
forall a b. b -> Either a b
Right (String -> Either GitError String)
-> String -> Either GitError String
forall a b. (a -> b) -> a -> b
$ ShowS
trim String
stdout
    ExitCode
_ -> GitError -> Either GitError String
forall a b. a -> Either a b
Left (GitError -> Either GitError String)
-> GitError -> Either GitError String
forall a b. (a -> b) -> a -> b
$ ExitCode -> String -> String -> GitError
GitProcessError ExitCode
status String
stdout String
stderr
  where
    trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace 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

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

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

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