tools: add reserve --commit option

Add the `--commit` option to the `reserve` command.  When given, it
commits the reservation, so that the user only needs to push and
make a pull request.

Author: frasertweedale

code/hsec-tools/app/Command/Reserve.hs

@@ -2,12 +2,17 @@
 
 module Command.Reserve where
 
-import Control.Monad (unless)
+import Control.Monad (unless, when)
 import Data.Maybe (fromMaybe)
 import System.Exit (die)
 import System.FilePath ((</>), (<.>))
 
-import Security.Advisories.Git (getRepoRoot)
+import Security.Advisories.Git
+  ( add
+  , commit
+  , explainGitError
+  , getRepoRoot
+  )
 import Security.Advisories.HsecId
   ( placeholder
   , printHsecId
@@ -30,8 +35,11 @@ data IdMode
   -- ^ Use the next available ID.  This option is more likely to
   -- result in conflicts when submitting advisories or reservations.
 
-runReserveCommand :: Maybe FilePath -> IdMode -> IO ()
-runReserveCommand mPath idMode = do
+data CommitFlag = Commit | DoNotCommit
+  deriving (Eq)
+
+runReserveCommand :: Maybe FilePath -> IdMode -> CommitFlag -> IO ()
+runReserveCommand mPath idMode commitFlag = do
   let
     path = fromMaybe "." mPath
   repoPath <- getRepoRoot path >>= \case
@@ -52,3 +60,12 @@ runReserveCommand mPath idMode = do
     fileName = printHsecId hsid <.> "md"
     filePath = advisoriesPath </> dirNameReserved </> fileName
   writeFile filePath ""  -- write empty file
+
+  when (commitFlag == Commit) $ do
+    let msg = printHsecId hsid <> ": reserve id"
+    add repoPath [filePath] >>= \case
+      Left e -> die $ "Failed to update Git index: " <> explainGitError e
+      Right _ -> pure ()
+    commit repoPath msg >>= \case
+      Left e -> die $ "Failed to create Git commit: " <> explainGitError e
+      Right _ -> pure ()

code/hsec-tools/app/Main.hs

@@ -57,6 +57,12 @@ commandReserve =
         , ("auto",        Command.Reserve.IdModeAuto)
         ]
         ( long "id-mode" <> help "How to assign IDs" )
+  <*> flag
+        Command.Reserve.DoNotCommit -- default value
+        Command.Reserve.Commit      -- active value
+        ( long "commit"
+        <> help "Commit the reservation file"
+        )
   <**> helper
 
 commandCheck :: Parser (IO ())

code/hsec-tools/src/Security/Advisories/Git.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
 {-|
 
 Helpers for deriving advisory metadata from a Git repo.
@@ -6,8 +8,11 @@ Helpers for deriving advisory metadata from a Git repo.
 module Security.Advisories.Git
   ( AdvisoryGitInfo(..)
   , GitError(..)
+  , explainGitError
   , getAdvisoryGitInfo
   , getRepoRoot
+  , add
+  , commit
   )
   where
 
@@ -29,6 +34,19 @@ data GitError
   | GitTimeParseError String -- ^ unable to parse this input as a datetime
   deriving (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)
@@ -46,6 +64,36 @@ getRepoRoot path = do
   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