WIP: SetupHooks: error on invalid rule locations

Cabal-hooks/src/Distribution/Simple/SetupHooks.hs

@@ -575,6 +575,8 @@ addRuleMonitors mons = Writer.tell ( [], mons )
 registerAction :: Action -> FreshT Action ActionId Identity ActionId
 registerAction = register ( ActionId 1 ) ( \ ( ActionId i ) -> ActionId ( i + 1 ) )
 
+--------------------------------------------------------------------------------
+
 -- | Find a file in the given search directories.
 findFileInDirs :: FilePath -> [FilePath] -> IO (Maybe Location)
 findFileInDirs file dirs =
@@ -583,3 +585,4 @@ findFileInDirs file dirs =
       [ (path, file)
       | path <- nub dirs
       ]
+  -- SetupHooks TODO: put this inside RulesT in order to declare monitored files/dirs

Cabal/src/Distribution/Simple/SetupHooks/Errors.hs

@@ -15,6 +15,9 @@ module Distribution.Simple.SetupHooks.Errors
   ( SetupHooksException (..)
   , CannotApplyComponentDiffReason (..)
   , IllegalComponentDiffReason (..)
+  , InvalidRuleLocations (..)
+  , InvalidRuleInputLocationReason (..)
+  , InvalidRuleOutputLocationReason (..)
   , BadHooksExecutableArgs (..)
   , setupHooksExceptionCode
   , setupHooksExceptionMessage
@@ -62,6 +65,28 @@ data SetupHooksException
       Rule
       (NE.NonEmpty Rule.Location)
       -- ^ missing outputs
+  | InvalidLocations
+     (NE.NonEmpty InvalidRuleLocations)
+  deriving (Show)
+
+data InvalidRuleLocations
+  = InvalidRuleLocations
+  { invalidRuleLocationsRule :: Rule
+  , invalidRuleInputLocations :: [(Location, InvalidRuleInputLocationReason)]
+  , invalidRuleOutputLocations :: [(Location, InvalidRuleOutputLocationReason)]
+  } -- invariant: at least one of the lists is non-empty
+
+  deriving (Show)
+
+data InvalidRuleInputLocationReason
+  = InputLocationOutsidePackage
+  | InputLocationNotRelative
+  deriving (Show)
+
+data InvalidRuleOutputLocationReason
+  = OutputLocationOutsidePackage
+  | OutputLocationOutsideDesignatedDir
+  | OutputLocationNotRelative
   deriving (Show)
 
 data CannotApplyComponentDiffReason
@@ -98,6 +123,7 @@ setupHooksExceptionCode = \case
   CyclicRuleDependencies{} -> 9077
   CantFindSourceForRuleDependencies{} -> 1071
   MissingRuleOutputs{} -> 3498
+  InvalidLocations{} -> 7717
   MissingHooksExecutableArg{} -> 7982
 
 setupHooksExceptionMessage :: SetupHooksException -> String
@@ -148,6 +174,28 @@ setupHooksExceptionMessage = \case
             ""
         | otherwise =
             "s"
+  InvalidLocations badRules ->
+    unlines $
+      ("Pre-build rules contain invalid " ++ what ++ " locations :")
+      : map showBadRule badRulesL
+    where
+      badRulesL = NE.toList badRules
+      what
+        | badInputs && badOutputs
+        = "input and output"
+        | badInputs
+        = "input"
+        | otherwise
+        = "output"
+      badInputs = any (not . null . invalidRuleInputLocations) badRulesL
+      badOutputs = any (not . null . invalidRuleOutputLocations) badRulesL
+      showBadRule r =
+        unlines $
+          [ "  - rule dependency " ++ locPath loc ++ " " ++ invalidRuleInputLocationReason rea
+          | (loc, rea) <- invalidRuleInputLocations r ]
+          ++
+          [ "  - rule output " ++ locPath loc ++ " " ++ invalidRuleOutputLocationReason rea
+          | (loc, rea) <- invalidRuleOutputLocations r ]
   MissingHooksExecutableArg ->
     "Missing argument to Hooks executable.\n\
     \Expected hook type as an argument."
@@ -162,6 +210,17 @@ showLocs (x : xs) = '[' : ' ' : locPath x ++ showl xs
     showl [] = " ]"
     showl (y : ys) = ',' : ' ' : locPath y ++ showl ys
 
+invalidRuleInputLocationReason :: InvalidRuleInputLocationReason -> String
+invalidRuleInputLocationReason = \ case
+  InputLocationOutsidePackage -> "lies outside the package structure"
+  InputLocationNotRelative -> "is not a relative path"
+
+invalidRuleOutputLocationReason :: InvalidRuleOutputLocationReason -> String
+invalidRuleOutputLocationReason = \ case
+  OutputLocationOutsidePackage -> "lies outside the package structure"
+  OutputLocationOutsideDesignatedDir -> "lies outside the designated output directories (autogen, build)"
+  OutputLocationNotRelative -> "is not a relative path"
+
 cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int
 cannotApplyComponentDiffCode = \case
   MismatchedComponentTypes{} -> 9491

Cabal/src/Distribution/Simple/SetupHooks/Internal.hs

@@ -118,7 +118,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import System.Directory (doesFileExist)
-import System.FilePath ((<.>), (</>))
+import System.FilePath ((<.>), (</>), isAbsolute, splitDirectories, normalise)
 
 --------------------------------------------------------------------------------
 -- SetupHooks
@@ -854,8 +854,7 @@ applyComponentDiff verbosity comp (ComponentDiff diff)
 --------------------------------------------------------------------------------
 -- Running pre-processors and code generators
 
--- | Run all preprocessors and code generators specified in
--- 'SetupHooks'.
+-- | Run a collection of fine-grained build rules.
 --
 -- This function should only be called internally within @Cabal@, as it is used
 -- to implement the (legacy) Setup.hs interface. The build tool
@@ -872,8 +871,15 @@ executeRules
 executeRules verbosity lbi tgtInfo rulesFromInputs inputs = do
   let (actionFromId, getRulesAndMonitors) = computeRules inputs rulesFromInputs
   -- Get all the rules, and create a build graph out of them.
-  allRules <- zip [0 ..] . fst <$> getRulesAndMonitors
+  (badRules, allRules0) <- partitionEithers
+                         . map normaliseRule
+                         . fst
+                         <$> getRulesAndMonitors
+  -- Throw an error if any rule input/outputs are invalid, e.g.
+  -- refer to files outside of the project.
+  for_ (NE.nonEmpty badRules) $ errorOut . InvalidLocations
   let
+    allRules = zip [1..] allRules0
     (ruleGraph, ruleFromVertex, vertexFromRuleId) =
       Graph.graphFromEdges
         [ (rule, rId, getRuleDependencies rule)
@@ -922,10 +928,9 @@ executeRules verbosity lbi tgtInfo rulesFromInputs inputs = do
     -- any rules at all; just throw an error right off the bat.
     r : rs ->
       let getRule ((ru, _, _), js) = (ru, fmap (fmap (\(rv, _, _) -> rv)) js)
-       in dieWithException verbosity $
-            SetupHooksException $
-              CyclicRuleDependencies $
-                fmap getRule (r NE.:| rs)
+       in errorOut $
+            CyclicRuleDependencies $
+              fmap getRule (r NE.:| rs)
     -- Otherwise, run all the demanded rules in dependency order (in one go).
     -- (Fine-grained running of rules should happen in cabal-install or HLS,
     -- not in the Cabal library.)
@@ -963,22 +968,24 @@ executeRules verbosity lbi tgtInfo rulesFromInputs inputs = do
               missingRuleDeps <- filterM missingDep deps
               case NE.nonEmpty missingRuleDeps of
                 Just missingDeps ->
-                  dieWithException verbosity $
-                    SetupHooksException $
-                      CantFindSourceForRuleDependencies r missingDeps
+                  errorOut $
+                    CantFindSourceForRuleDependencies r missingDeps
                 -- Dependencies OK: run the associated action.
                 Nothing -> do
                   execRule deps reslts
                   -- Throw an error if running the action did not result in
                   -- the generation of outputs that we expected it to.
                   missingRuleResults <- filterM missingDep $ NE.toList reslts
                   for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
-                    dieWithException verbosity $
-                      SetupHooksException $
-                        MissingRuleOutputs r missingResults
+                    errorOut $
+                      MissingRuleOutputs r missingResults
+
+  -- SetupHooks TODO: if running the rules has rendered some rules out-of-date,
+  -- should we then re-run the rules (until we reach a fix point)?
   where
     clbi = targetCLBI tgtInfo
     compAutogenDir = autogenComponentModulesDir lbi clbi
+    errorOut err = dieWithException verbosity $ SetupHooksException err
 
 -- | Does the rule output the given location?
 ruleOutputsLocation :: Rule -> Location -> Bool
@@ -988,6 +995,61 @@ ruleOutputsLocation (Rule{results = rs}) fp = any (== fp) rs
 missingDep :: Location -> IO Bool
 missingDep (base, fp) = not <$> doesFileExist (base </> fp)
 
+normaliseRule :: Rule -> Either InvalidRuleLocations Rule
+normaliseRule r@( Rule { dependencies = deps, results = reslts })
+  | null badDeps && null badResults
+  = Right $
+    r { dependencies = deps'
+      , results      = reslts' }
+  | otherwise
+  = Left $
+    InvalidRuleLocations
+      { invalidRuleLocationsRule = r
+      , invalidRuleInputLocations = badDeps
+      , invalidRuleOutputLocations = badResults }
+  where
+    deps'   = map normaliseLocation deps
+    reslts' = fmap normaliseLocation reslts
+    badDeps = mapMaybe (\ l -> (l,) <$> badInputLocationMaybe l) deps'
+    badResults = mapMaybe (\ l -> (l,) <$> badOutputLocationMaybe l) $ NE.toList reslts'
+
+badInputLocationMaybe :: Location -> Maybe InvalidRuleInputLocationReason
+badInputLocationMaybe (base, _)
+  | isAbsolute base
+  = Just $ InputLocationNotRelative
+  | pathGoesBackwards base
+  = Just $ InputLocationOutsidePackage
+  | otherwise
+  = Nothing
+
+badOutputLocationMaybe :: Location -> Maybe InvalidRuleOutputLocationReason
+badOutputLocationMaybe (base, _)
+  | isAbsolute base
+  = Just $ OutputLocationNotRelative
+  | pathGoesBackwards base
+  = Just $ OutputLocationOutsidePackage
+  -- SetupHooks TODO: check whether the path lies inside
+  -- a valid output directory such as 'autogenComponentModulesDir'.
+  -- (NB: this will require passing in additional arguments to the function.)
+  | otherwise
+  = Nothing
+
+-- | Does the given relative path go backwards outside of the base directory
+-- it starts in?
+pathGoesBackwards :: FilePath -> Bool
+-- SetupHooks TODO: this does not account for symlinks, but
+-- using 'canonicalizePath' seems overkill.
+pathGoesBackwards fp = go 0 (splitDirectories fp)
+  where
+    go :: Int -> [FilePath] -> Bool
+    go i [] = i < 0
+    go i (".." : rest) = go (i-1) rest
+    go i ("." : rest)  = go i rest
+    go i (_ : rest)    = go (i+1) rest
+
+normaliseLocation :: Location -> Location
+normaliseLocation (base, fp) = (normalise base, fp)
+
 --------------------------------------------------------------------------------
 -- Compatibility with HookedBuildInfo.
 --