testsuite: Add a test for haskell#9334 (attempt 2)

Issue haskell#9334 identifies that `getScriptHash` can return invalid filepaths
on certain platforms. This randomised test attempts to check that the
filepaths it returns are valid.

I have verified that this test readily fails on linux (when the logic
about removing `/` is removed from ScriptUtils).

Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP           #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-module Test.QuickCheck.Instances.Cabal () where
+module Test.QuickCheck.Instances.Cabal ( ShortPath(..) ) where
 
 import Control.Applicative        (liftA2)
 import Data.Bits                  (shiftR)
@@ -56,6 +56,15 @@ import qualified Distribution.Compat.NonEmptySet as NES
 import Control.Applicative (pure, (<$>), (<*>))
 #endif
 
+-------------------------------------------------------------------------------
+-- ShortPath
+-------------------------------------------------------------------------------
+
+newtype ShortPath = ShortPath FilePath deriving (Show)
+
+instance Arbitrary ShortPath where
+  arbitrary = ShortPath <$> arbitraryShortPath
+
 -------------------------------------------------------------------------------
 -- CabalSpecVersion
 -------------------------------------------------------------------------------

cabal-install/cabal-install.cabal

@@ -325,6 +325,7 @@ test-suite unit-tests
       UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
       UnitTests.Distribution.Solver.Modular.WeightedPSQ
       UnitTests.Distribution.Solver.Types.OptionalStanza
+      UnitTests.Distribution.Client.ScriptUtils
       UnitTests.Options
 
     build-depends:

cabal-install/tests/UnitTests.hs

@@ -19,6 +19,7 @@ import qualified UnitTests.Distribution.Client.Store
 import qualified UnitTests.Distribution.Client.Tar
 import qualified UnitTests.Distribution.Client.Targets
 import qualified UnitTests.Distribution.Client.UserConfig
+import qualified UnitTests.Distribution.Client.ScriptUtils
 import qualified UnitTests.Distribution.Solver.Modular.Builder
 import qualified UnitTests.Distribution.Solver.Modular.RetryLog
 import qualified UnitTests.Distribution.Solver.Modular.Solver
@@ -43,6 +44,9 @@ main = do
       , testGroup
           "UnitTests.Distribution.Client.Get"
           UnitTests.Distribution.Client.Get.tests
+      , testGroup
+          "UnitTests.Distribution.Client.ScriptUtils"
+          UnitTests.Distribution.Client.ScriptUtils.tests
       , testGroup
           "UnitTests.Distribution.Client.Glob"
           UnitTests.Distribution.Client.Glob.tests

cabal-install/tests/UnitTests/Distribution/Client/ScriptUtils.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module UnitTests.Distribution.Client.ScriptUtils (tests) where
+
+import Distribution.Client.ScriptUtils
+import Distribution.Client.Config
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck.Instances.Cabal
+import System.FilePath
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+      "ScriptUtils"
+      [ testProperty "valid_script_path" testScriptPath
+      ]
+  ]
+
+-- ------------------------------------------------------------
+
+-- * Unit tests
+
+-- ------------------------------------------------------------
+
+testScriptPath :: ShortPath -> Property
+testScriptPath (ShortPath p) = withMaxSuccess 10000 $ ioProperty $ do
+  hashed_path <- getScriptCacheDirectory p
+  script_build_dir <- defaultScriptBuildsDir
+  return $ and
+    -- 1. Is it a valid path at all
+    [ isValid hashed_path
+    -- 2. Is the computed hashed path in the expected directory?
+    , (script_build_dir </> takeFileName hashed_path) `equalFilePath` hashed_path
+    ]
+