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

-- |
--
-- Helpers for deriving advisory metadata from a Git repo.
module Security.Advisories.Sync.Git
  ( GitDirectoryInfo (..),
    GitError (..),
    GitErrorCase (..),
    explainGitError,
    Repository (..),
    GitRepositoryEnsuredStatus (..),
    ensureGitRepositoryWithRemote,
    getDirectoryGitInfo,
    updateGitRepository,
    GitRepositoryStatus (..),
    gitRepositoryStatus,
  )
where

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (runExceptT, throwE)
import Data.Time (ZonedTime)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import qualified System.Directory as D
import System.Exit (ExitCode (ExitSuccess))
import System.Process (readProcessWithExitCode)

type Cmd = (FilePath, [String])

data GitError = GitError
  { GitError -> Cmd
gitCmd :: Cmd,
    GitError -> GitErrorCase
gitError :: GitErrorCase
  }

runGit :: [String] -> IO (Cmd, ExitCode, String, String)
runGit :: [String] -> IO (Cmd, ExitCode, String, String)
runGit [String]
args =
  (\(ExitCode
status, String
stdout, String
stderr) -> ((String
"git", [String]
args), ExitCode
status, String
stdout, String
stderr))
    ((ExitCode, String, String) -> (Cmd, ExitCode, String, String))
-> IO (ExitCode, String, String)
-> IO (Cmd, ExitCode, String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String]
args String
""

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

explainGitError :: GitError -> String
explainGitError :: GitError -> String
explainGitError GitError
e =
  [String] -> String
unlines
    [ String
"Called " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show (Cmd -> String
forall a b. (a, b) -> a
fst (Cmd -> String) -> Cmd -> String
forall a b. (a -> b) -> a -> b
$ GitError -> Cmd
gitCmd GitError
e) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show (Cmd -> [String]
forall a b. (a, b) -> b
snd (Cmd -> [String]) -> Cmd -> [String]
forall a b. (a -> b) -> a -> b
$ GitError -> Cmd
gitCmd GitError
e),
      case GitError -> GitErrorCase
gitError GitError
e of
        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
    ]

data Repository = Repository
  { Repository -> String
repositoryRoot :: FilePath,
    Repository -> String
repositoryUrl :: String,
    Repository -> String
repositoryBranch :: String
  }

data GitRepositoryStatus
  = GitDirectoryMissing
  | GitDirectoryEmpty
  | GitDirectoryInitialized

gitRepositoryStatus :: Repository -> IO GitRepositoryStatus
gitRepositoryStatus :: Repository -> IO GitRepositoryStatus
gitRepositoryStatus Repository
repo = do
  Bool
exists <- String -> IO Bool
D.doesDirectoryExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ Repository -> String
repositoryRoot Repository
repo
  if Bool
exists
    then String -> IO GitRepositoryStatus -> IO GitRepositoryStatus
forall a. String -> IO a -> IO a
D.withCurrentDirectory (Repository -> String
repositoryRoot Repository
repo) (IO GitRepositoryStatus -> IO GitRepositoryStatus)
-> IO GitRepositoryStatus -> IO GitRepositoryStatus
forall a b. (a -> b) -> a -> b
$ do
      (Cmd
_, ExitCode
checkStatus, String
checkStdout, String
_) <-
        [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"rev-parse", String
"--is-inside-work-tree"]
      let out :: [String]
out = (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
checkStdout
      case ExitCode
checkStatus of
        ExitCode
ExitSuccess
          | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
out) Bool -> Bool -> Bool
&& [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true" ->
              GitRepositoryStatus -> IO GitRepositoryStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GitRepositoryStatus
GitDirectoryInitialized
        ExitCode
_ ->
          GitRepositoryStatus -> IO GitRepositoryStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GitRepositoryStatus
GitDirectoryEmpty
    else GitRepositoryStatus -> IO GitRepositoryStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GitRepositoryStatus
GitDirectoryMissing

data GitRepositoryEnsuredStatus
  = GitRepositoryCreated
  | GitRepositoryExisting

ensureGitRepositoryWithRemote ::
  Repository ->
  GitRepositoryStatus ->
  IO (Either GitError GitRepositoryEnsuredStatus)
ensureGitRepositoryWithRemote :: Repository
-> GitRepositoryStatus
-> IO (Either GitError GitRepositoryEnsuredStatus)
ensureGitRepositoryWithRemote Repository
repo =
  \case
    GitRepositoryStatus
GitDirectoryMissing ->
      IO (Either GitError GitRepositoryEnsuredStatus)
clone
    GitRepositoryStatus
GitDirectoryEmpty ->
      IO (Either GitError GitRepositoryEnsuredStatus)
clone
    GitRepositoryStatus
GitDirectoryInitialized ->
      Either GitError GitRepositoryEnsuredStatus
-> IO (Either GitError GitRepositoryEnsuredStatus)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitError GitRepositoryEnsuredStatus
 -> IO (Either GitError GitRepositoryEnsuredStatus))
-> Either GitError GitRepositoryEnsuredStatus
-> IO (Either GitError GitRepositoryEnsuredStatus)
forall a b. (a -> b) -> a -> b
$ GitRepositoryEnsuredStatus
-> Either GitError GitRepositoryEnsuredStatus
forall a b. b -> Either a b
Right GitRepositoryEnsuredStatus
GitRepositoryExisting
  where
    clone :: IO (Either GitError GitRepositoryEnsuredStatus)
clone = do
      (Cmd
cmd, ExitCode
status, String
stdout, String
stderr) <-
        [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"clone", String
"-b", Repository -> String
repositoryBranch Repository
repo, Repository -> String
repositoryUrl Repository
repo, Repository -> String
repositoryRoot Repository
repo]
      Either GitError GitRepositoryEnsuredStatus
-> IO (Either GitError GitRepositoryEnsuredStatus)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitError GitRepositoryEnsuredStatus
 -> IO (Either GitError GitRepositoryEnsuredStatus))
-> Either GitError GitRepositoryEnsuredStatus
-> IO (Either GitError GitRepositoryEnsuredStatus)
forall a b. (a -> b) -> a -> b
$
        if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess
          then GitError -> Either GitError GitRepositoryEnsuredStatus
forall a b. a -> Either a b
Left (GitError -> Either GitError GitRepositoryEnsuredStatus)
-> GitError -> Either GitError GitRepositoryEnsuredStatus
forall a b. (a -> b) -> a -> b
$ Cmd -> GitErrorCase -> GitError
GitError Cmd
cmd (GitErrorCase -> GitError) -> GitErrorCase -> GitError
forall a b. (a -> b) -> a -> b
$ ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
status String
stdout String
stderr
          else GitRepositoryEnsuredStatus
-> Either GitError GitRepositoryEnsuredStatus
forall a b. b -> Either a b
Right GitRepositoryEnsuredStatus
GitRepositoryCreated

updateGitRepository :: Repository -> IO (Either GitError ())
updateGitRepository :: Repository -> IO (Either GitError ())
updateGitRepository Repository
repo =
  String -> IO (Either GitError ()) -> IO (Either GitError ())
forall a. String -> IO a -> IO a
D.withCurrentDirectory (Repository -> String
repositoryRoot Repository
repo) (IO (Either GitError ()) -> IO (Either GitError ()))
-> IO (Either GitError ()) -> IO (Either GitError ())
forall a b. (a -> b) -> a -> b
$
    ExceptT GitError IO () -> IO (Either GitError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT GitError IO () -> IO (Either GitError ()))
-> ExceptT GitError IO () -> IO (Either GitError ())
forall a b. (a -> b) -> a -> b
$ do
      (Cmd, ExitCode, String, String)
_ <- IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a. IO a -> ExceptT GitError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Cmd, ExitCode, String, String)
 -> ExceptT GitError IO (Cmd, ExitCode, String, String))
-> IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"remote", String
"add", String
"origin", Repository -> String
repositoryUrl Repository
repo] -- can fail if it exists
      (Cmd
setUrlCmd, ExitCode
setUrlStatus, String
setUrlStdout, String
setUrlStderr) <-
        IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a. IO a -> ExceptT GitError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Cmd, ExitCode, String, String)
 -> ExceptT GitError IO (Cmd, ExitCode, String, String))
-> IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"remote", String
"set-url", String
"origin", Repository -> String
repositoryUrl Repository
repo]
      Bool -> ExceptT GitError IO () -> ExceptT GitError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
setUrlStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (ExceptT GitError IO () -> ExceptT GitError IO ())
-> ExceptT GitError IO () -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
        GitError -> ExceptT GitError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (GitError -> ExceptT GitError IO ())
-> GitError -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
          Cmd -> GitErrorCase -> GitError
GitError Cmd
setUrlCmd (GitErrorCase -> GitError) -> GitErrorCase -> GitError
forall a b. (a -> b) -> a -> b
$
            ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
setUrlStatus String
setUrlStdout String
setUrlStderr

      (Cmd
fetchAllCmd, ExitCode
fetchAllStatus, String
fetchAllStdout, String
fetchAllStderr) <-
        IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a. IO a -> ExceptT GitError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Cmd, ExitCode, String, String)
 -> ExceptT GitError IO (Cmd, ExitCode, String, String))
-> IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"fetch", String
"--all"]
      Bool -> ExceptT GitError IO () -> ExceptT GitError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
fetchAllStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (ExceptT GitError IO () -> ExceptT GitError IO ())
-> ExceptT GitError IO () -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
        GitError -> ExceptT GitError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (GitError -> ExceptT GitError IO ())
-> GitError -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
          Cmd -> GitErrorCase -> GitError
GitError Cmd
fetchAllCmd (GitErrorCase -> GitError) -> GitErrorCase -> GitError
forall a b. (a -> b) -> a -> b
$
            ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
fetchAllStatus String
fetchAllStdout String
fetchAllStderr

      (Cmd
checkoutBranchCmd, ExitCode
checkoutBranchStatus, String
checkoutBranchStdout, String
checkoutBranchStderr) <-
        IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a. IO a -> ExceptT GitError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Cmd, ExitCode, String, String)
 -> ExceptT GitError IO (Cmd, ExitCode, String, String))
-> IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"checkout", Repository -> String
repositoryBranch Repository
repo]
      Bool -> ExceptT GitError IO () -> ExceptT GitError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
checkoutBranchStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (ExceptT GitError IO () -> ExceptT GitError IO ())
-> ExceptT GitError IO () -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
        GitError -> ExceptT GitError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (GitError -> ExceptT GitError IO ())
-> GitError -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
          Cmd -> GitErrorCase -> GitError
GitError Cmd
checkoutBranchCmd (GitErrorCase -> GitError) -> GitErrorCase -> GitError
forall a b. (a -> b) -> a -> b
$
            ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
checkoutBranchStatus String
checkoutBranchStdout String
checkoutBranchStderr

      (Cmd
resetCmd, ExitCode
resetStatus, String
resetStdout, String
resetStderr) <-
        IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a. IO a -> ExceptT GitError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Cmd, ExitCode, String, String)
 -> ExceptT GitError IO (Cmd, ExitCode, String, String))
-> IO (Cmd, ExitCode, String, String)
-> ExceptT GitError IO (Cmd, ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"reset", String
"--hard", String
"origin/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Repository -> String
repositoryBranch Repository
repo]

      Bool -> ExceptT GitError IO () -> ExceptT GitError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
resetStatus ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (ExceptT GitError IO () -> ExceptT GitError IO ())
-> ExceptT GitError IO () -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
        GitError -> ExceptT GitError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (GitError -> ExceptT GitError IO ())
-> GitError -> ExceptT GitError IO ()
forall a b. (a -> b) -> a -> b
$
          Cmd -> GitErrorCase -> GitError
GitError Cmd
resetCmd (GitErrorCase -> GitError) -> GitErrorCase -> GitError
forall a b. (a -> b) -> a -> b
$
            ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
resetStatus String
resetStdout String
resetStderr

newtype GitDirectoryInfo = GitDirectoryInfo
  { GitDirectoryInfo -> ZonedTime
lastModificationCommitDate :: ZonedTime
  }

getDirectoryGitInfo :: FilePath -> IO (Either GitError GitDirectoryInfo)
getDirectoryGitInfo :: String -> IO (Either GitError GitDirectoryInfo)
getDirectoryGitInfo String
path = do
  (Cmd
cmd, ExitCode
status, String
stdout, String
stderr) <-
    [String] -> IO (Cmd, ExitCode, String, String)
runGit [String
"-C", String
path, String
"log", String
"--pretty=format:%cI", String
"--find-renames", String
"advisories"]
  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
      onError :: GitErrorCase -> Either GitError b
onError = GitError -> Either GitError b
forall a b. a -> Either a b
Left (GitError -> Either GitError b)
-> (GitErrorCase -> GitError) -> GitErrorCase -> Either GitError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cmd -> GitErrorCase -> GitError
GitError Cmd
cmd
  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 GitDirectoryInfo
-> IO (Either GitError GitDirectoryInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitError GitDirectoryInfo
 -> IO (Either GitError GitDirectoryInfo))
-> Either GitError GitDirectoryInfo
-> IO (Either GitError GitDirectoryInfo)
forall a b. (a -> b) -> a -> b
$
            ZonedTime -> GitDirectoryInfo
GitDirectoryInfo
              (ZonedTime -> GitDirectoryInfo)
-> Either GitError ZonedTime -> Either GitError GitDirectoryInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GitErrorCase -> Either GitError ZonedTime)
-> String -> Either GitError ZonedTime
forall {a} {a}.
ISO8601 a =>
(GitErrorCase -> Either a a) -> String -> Either a a
parseTime GitErrorCase -> Either GitError ZonedTime
forall {b}. GitErrorCase -> Either GitError b
onError ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
timestamps)
    ExitCode
_ ->
      Either GitError GitDirectoryInfo
-> IO (Either GitError GitDirectoryInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitError GitDirectoryInfo
 -> IO (Either GitError GitDirectoryInfo))
-> Either GitError GitDirectoryInfo
-> IO (Either GitError GitDirectoryInfo)
forall a b. (a -> b) -> a -> b
$ GitErrorCase -> Either GitError GitDirectoryInfo
forall {b}. GitErrorCase -> Either GitError b
onError (GitErrorCase -> Either GitError GitDirectoryInfo)
-> GitErrorCase -> Either GitError GitDirectoryInfo
forall a b. (a -> b) -> a -> b
$ ExitCode -> String -> String -> GitErrorCase
GitProcessError ExitCode
status String
stdout String
stderr
  where
    parseTime :: (GitErrorCase -> Either a a) -> String -> Either a a
parseTime GitErrorCase -> Either a a
onError String
s = Either a a -> (a -> Either a a) -> Maybe a -> Either a a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GitErrorCase -> Either a a
onError (GitErrorCase -> Either a a) -> GitErrorCase -> Either a a
forall a b. (a -> b) -> a -> b
$ String -> GitErrorCase
GitTimeParseError String
s) a -> Either a a
forall a b. b -> Either a b
Right (Maybe a -> Either a a) -> Maybe a -> Either a a
forall a b. (a -> b) -> a -> b
$ String -> Maybe a
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM String
s