Add pre and post build hooks

Run a program (named "preBuildHook") before doing a package build and
another program (named "postBuildHook") after the package is built.
The exit code from the pre-build hook is passed to the post-build
hook.

The commit includes documentation for the hooks and the security
safeguards implemented to avoid the running of malicious hook
files.

(cherry picked from commit 5f7b47f)

Author: erikd

cabal-install/cabal-install.cabal

@@ -130,6 +130,7 @@ library
         Distribution.Client.GlobalFlags
         Distribution.Client.Haddock
         Distribution.Client.HashValue
+        Distribution.Client.HookAccept
         Distribution.Client.HttpUtils
         Distribution.Client.IndexUtils
         Distribution.Client.IndexUtils.ActiveRepos

cabal-install/src/Distribution/Client/CmdFreeze.hs

@@ -142,6 +142,7 @@ freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do
   (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
     rebuildInstallPlan
       verbosity
+      mempty
       distDirLayout
       cabalDirLayout
       projectConfig

cabal-install/src/Distribution/Client/Errors.hs

@@ -186,6 +186,8 @@ data CabalInstallException
   | MissingPackageList RemoteRepo
   | CmdPathAcceptsNoTargets
   | CmdPathCommandDoesn'tSupportDryRun
+  | HookAcceptUnknown FilePath FilePath String
+  | HookAcceptHashMismatch FilePath FilePath String String
   deriving (Show, Typeable)
 
 exceptionCodeCabalInstall :: CabalInstallException -> Int
@@ -338,6 +340,8 @@ exceptionCodeCabalInstall e = case e of
   MissingPackageList{} -> 7160
   CmdPathAcceptsNoTargets{} -> 7161
   CmdPathCommandDoesn'tSupportDryRun -> 7163
+  HookAcceptUnknown{} -> 7164
+  HookAcceptHashMismatch{} -> 7165
 
 exceptionMessageCabalInstall :: CabalInstallException -> String
 exceptionMessageCabalInstall e = case e of
@@ -857,6 +861,36 @@ exceptionMessageCabalInstall e = case e of
     "The 'path' command accepts no target arguments."
   CmdPathCommandDoesn'tSupportDryRun ->
     "The 'path' command doesn't support the flag '--dry-run'."
+  HookAcceptUnknown hsPath fpath hash ->
+    concat
+      [ "The following file does not appear in the hooks-security file.\n"
+      , "    hook file : "
+      , fpath
+      , "\n"
+      , "    file hash : "
+      , hash
+      , "\n"
+      , "After checking the contents of that file, it should be added to the\n"
+      , "hooks-security file with either AcceptAlways or better yet an AcceptHash.\n"
+      , "The hooks-security file is (probably) located at: "
+      , hsPath
+      ]
+  HookAcceptHashMismatch hsPath fpath expected actual ->
+    concat
+      [ "\nHook file hash mismatch for:\n"
+      , "    hook file    : "
+      , fpath
+      , "\n"
+      , "    expected hash: "
+      , expected
+      , "\n"
+      , "    actual hash  : "
+      , actual
+      , "\n"
+      , "The hook file should be inspected and if deemed ok, the hooks-security file updated.\n"
+      , "The hooks-security file is (probably) located at: "
+      , hsPath
+      ]
 
 instance Exception (VerboseException CabalInstallException) where
   displayException :: VerboseException CabalInstallException -> [Char]

cabal-install/src/Distribution/Client/HashValue.hs

@@ -5,6 +5,7 @@
 module Distribution.Client.HashValue
   ( HashValue
   , hashValue
+  , hashValueFromHex
   , truncateHash
   , showHashValue
   , readFileHashValue
@@ -52,6 +53,11 @@ instance Structured HashValue
 hashValue :: LBS.ByteString -> HashValue
 hashValue = HashValue . SHA256.hashlazy
 
+-- From a base16 encoded Bytestring to a HashValue with `Base16`'s
+-- error passing through.
+hashValueFromHex :: BS.ByteString -> Either String HashValue
+hashValueFromHex bs = HashValue <$> Base16.decode bs
+
 showHashValue :: HashValue -> String
 showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)
 

cabal-install/src/Distribution/Client/HookAccept.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Distribution.Client.HookAccept
+  ( HookAccept (..)
+  , assertHookHash
+  , loadHookHasheshMap
+  , parseHooks
+  ) where
+
+import Distribution.Client.Compat.Prelude
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as BS
+
+import qualified Data.Map.Strict as Map
+
+import Distribution.Client.Config (getConfigFilePath)
+import Distribution.Client.Errors (CabalInstallException (..))
+import Distribution.Client.HashValue (HashValue, hashValueFromHex, readFileHashValue, showHashValue)
+import Distribution.Simple.Setup (Flag (..))
+import Distribution.Simple.Utils (dieWithException)
+import Distribution.Verbosity (normal)
+
+import System.FilePath (takeDirectory, (</>))
+
+data HookAccept
+  = AcceptAlways
+  | AcceptHash HashValue
+  deriving (Eq, Show, Generic)
+
+instance Monoid HookAccept where
+  mempty = AcceptAlways -- Should never be needed.
+  mappend = (<>)
+
+instance Semigroup HookAccept where
+  AcceptAlways <> AcceptAlways = AcceptAlways
+  AcceptAlways <> AcceptHash h = AcceptHash h
+  AcceptHash h <> AcceptAlways = AcceptHash h
+  AcceptHash h <> _ = AcceptHash h
+
+instance Binary HookAccept
+instance Structured HookAccept
+
+assertHookHash :: Map FilePath HookAccept -> FilePath -> IO ()
+assertHookHash m fpath = do
+  actualHash <- readFileHashValue fpath
+  hsPath <- getHooksSecurityFilePath NoFlag
+  case Map.lookup fpath m of
+    Nothing ->
+      dieWithException normal $
+        HookAcceptUnknown hsPath fpath (showHashValue actualHash)
+    Just AcceptAlways -> pure ()
+    Just (AcceptHash expectedHash) ->
+      when (actualHash /= expectedHash) $
+        dieWithException normal $
+          HookAcceptHashMismatch
+            hsPath
+            fpath
+            (showHashValue expectedHash)
+            (showHashValue actualHash)
+
+getHooksSecurityFilePath :: Flag FilePath -> IO FilePath
+getHooksSecurityFilePath configFileFlag = do
+  hfpath <- getConfigFilePath configFileFlag
+  pure $ takeDirectory hfpath </> "hooks-security"
+
+loadHookHasheshMap :: Flag FilePath -> IO (Map FilePath HookAccept)
+loadHookHasheshMap configFileFlag = do
+  hookFilePath <- getHooksSecurityFilePath configFileFlag
+  handleNotExists $ fmap parseHooks (BS.readFile hookFilePath)
+  where
+    handleNotExists :: IO (Map FilePath HookAccept) -> IO (Map FilePath HookAccept)
+    handleNotExists action = catchIO action $ \_ -> return mempty
+
+parseHooks :: ByteString -> Map FilePath HookAccept
+parseHooks = Map.fromList . map parse . cleanUp . BS.lines
+  where
+    cleanUp :: [ByteString] -> [ByteString]
+    cleanUp = filter (not . BS.null) . map rmComments
+
+    rmComments :: ByteString -> ByteString
+    rmComments = fst . BS.breakSubstring "--"
+
+parse :: ByteString -> (FilePath, HookAccept)
+parse bs =
+  case BS.words bs of
+    [fp, "AcceptAlways"] -> (BS.unpack fp, AcceptAlways)
+    [fp, "AcceptHash"] -> buildAcceptHash fp "00"
+    [fp, "AcceptHash", h] -> buildAcceptHash fp h
+    _ -> error $ "Not able to parse:" ++ show bs
+  where
+    buildAcceptHash :: ByteString -> ByteString -> (FilePath, HookAccept)
+    buildAcceptHash fp h =
+      case hashValueFromHex h of
+        Left err -> error $ "Distribution.Client.HookAccept.parse :" ++ err
+        Right hv -> (BS.unpack fp, AcceptHash hv)

cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs

@@ -30,6 +30,7 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
+import Distribution.Client.HookAccept (assertHookHash)
 import Distribution.Client.PackageHash (renderPackageHashInputs)
 import Distribution.Client.ProjectBuilding.Types
 import Distribution.Client.ProjectConfig
@@ -105,7 +106,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
 import qualified Data.List.NonEmpty as NE
 
 import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, removeFile)
 import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
 import System.IO (Handle, IOMode (AppendMode), withFile)
 import System.Semaphore (SemaphoreName (..))
@@ -697,7 +698,46 @@ buildAndInstallUnpackedPackage
           runConfigure
         PBBuildPhase{runBuild} -> do
           noticeProgress ProgressBuilding
+          hooksDir <- (</> "cabalHooks") <$> getCurrentDirectory
+          -- run preBuildHook. If it returns with 0, we assume the build was
+          -- successful. If not, run the build.
+          preBuildHookFile <- canonicalizePath (hooksDir </> "preBuildHook")
+          hookExists <- doesFileExist preBuildHookFile
+          preCode <- if hookExists then do
+            assertHookHash (pkgConfigHookHashes pkgshared) preBuildHookFile
+            rawSystemExitCode
+              verbosity
+              (Just srcdir)
+              preBuildHookFile
+              [ (unUnitId $ installedUnitId rpkg)
+              , (getSymbolicPath srcdir)
+              , (getSymbolicPath builddir)
+              ]
+              Nothing
+              `catchIO` (\_ -> pure (ExitFailure 10))
+          else pure ExitSuccess
+          -- Regardless of whether the preBuildHook exists or not, or whether it returned an
+          -- error or not, we want to run the build command.
+          -- If the preBuildHook downloads a cached version of the build products, the following
+          -- should be a NOOP.
           runBuild
+          -- not sure, if we want to care about a failed postBuildHook?
+          postBuildHookFile <- canonicalizePath (hooksDir </> "postBuildHook")
+          hookExists <- doesFileExist postBuildHookFile
+          when hookExists $ do
+            assertHookHash (pkgConfigHookHashes pkgshared) postBuildHookFile
+            void $
+              rawSystemExitCode
+                verbosity
+                (Just srcdir)
+                postBuildHookFile
+                [ (unUnitId $ installedUnitId rpkg)
+                , (getSymbolicPath srcdir)
+                , (getSymbolicPath builddir)
+                , show preCode
+                ]
+                Nothing
+                `catchIO` (\_ -> pure (ExitFailure 10))
         PBHaddockPhase{runHaddock} -> do
           noticeProgress ProgressHaddock
           runHaddock

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -685,7 +685,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
       } = globalFlags
 
     projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_
-
+    projectConfigHookHashes = mempty -- :: Map FilePath HookAccept
     ConfigFlags
       { configCommonFlags = commonFlags
       , configHcFlavor = projectConfigHcFlavor

cabal-install/src/Distribution/Client/ProjectConfig/Types.hs

@@ -34,6 +34,7 @@ import Distribution.Client.BuildReports.Types
 import Distribution.Client.Dependency.Types
   ( PreSolver
   )
+import Distribution.Client.HookAccept (HookAccept (..))
 import Distribution.Client.Targets
   ( UserConstraint
   )
@@ -228,6 +229,7 @@ data ProjectConfigShared = ProjectConfigShared
   , projectConfigPreferOldest :: Flag PreferOldest
   , projectConfigProgPathExtra :: NubList FilePath
   , projectConfigMultiRepl :: Flag Bool
+  , projectConfigHookHashes :: Map FilePath HookAccept
   -- More things that only make sense for manual mode, not --local mode
   -- too much control!
   -- projectConfigShadowPkgs        :: Flag Bool,

cabal-install/src/Distribution/Client/ProjectOrchestration.hs

@@ -176,6 +176,8 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Distribution.Client.Errors
+import Distribution.Client.HookAccept (loadHookHasheshMap)
+
 import Distribution.Package
 import Distribution.Simple.Command (commandShowOptions)
 import Distribution.Simple.Compiler
@@ -363,13 +365,16 @@ withInstallPlan
     , installedPackages
     }
   action = do
+    hookHashes <- loadHookHasheshMap (projectConfigConfigFile $ projectConfigShared projectConfig)
+
     -- Take the project configuration and make a plan for how to build
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
     (elaboratedPlan, _, elaboratedShared, _, _) <-
       rebuildInstallPlan
         verbosity
+        hookHashes
         distDirLayout
         cabalDirLayout
         projectConfig
@@ -392,13 +397,16 @@ runProjectPreBuildPhase
     , installedPackages
     }
   selectPlanSubset = do
+    hookHashes <- loadHookHasheshMap (projectConfigConfigFile $ projectConfigShared projectConfig)
+
     -- Take the project configuration and make a plan for how to build
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
     (elaboratedPlan, _, elaboratedShared, _, _) <-
       rebuildInstallPlan
         verbosity
+        hookHashes
         distDirLayout
         cabalDirLayout
         projectConfig