Shorten script-builds paths (#8898)

* Use shorter hash for script-builds directories Using a Base64 hash and truncating it to 26 characters, saves 38 chars, which helps avoid long paths issues on Windows, while still providing 130 bits of hash in order to avoid collisions. Bug #8841 * Use the script cache dir as the dist dir Putting script build products under dist-newstyle within the cache directory is unnecessary because we already control the cache directory and can ensure there are no conflicts. * Use the actual script name in the executable name Previously, the script name was sanitized in final executable name, because the executable name had to match the component name, which only allowed for a limited character set. Now we can use the actual script name in the executable name. This only lets us shorten the component name without losing clarity. * Add changelog entry * Reenable script tests for Windows/ghc-9.4.*
haskell · May 24, 2023 · a482a63 · a482a63
1 parent 5fd439f
commit a482a63
Show file tree

Hide file tree

Showing 28 changed files with 224 additions and 127 deletions.
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -1397,7 +1397,7 @@ checkGhcOptions fieldName getOptions pkg =
   , checkFlags ["-prof"] $
       PackageBuildWarning (OptProf fieldName)
 
-  , checkFlags ["-o"] $
+  , unlessScript . checkFlags ["-o"] $
       PackageBuildWarning (OptO fieldName)
 
   , checkFlags ["-hide-package"] $
@@ -1490,6 +1490,10 @@ checkGhcOptions fieldName getOptions pkg =
     checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
     checkFlags flags = check (any (`elem` flags) all_ghc_options)
 
+    unlessScript :: Maybe PackageCheck -> Maybe PackageCheck
+    unlessScript pc | packageId pkg == fakePackageId = Nothing
+                    | otherwise                      = pc
+
     checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
     checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options)
 

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -205,6 +205,7 @@ library
         async      >= 2.0      && < 2.3,
         array      >= 0.4      && < 0.6,
         base16-bytestring >= 0.1.1 && < 1.1.0.0,
+        base64-bytestring >= 1.0 && < 1.3,
         binary     >= 0.7.3    && < 0.9,
         bytestring >= 0.10.6.0 && < 0.12,
         containers >= 0.5.6.2  && < 0.7,

diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs
@@ -28,7 +28,9 @@ import Distribution.Client.NixStyleOptions
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning.Types
 import Distribution.Client.ScriptUtils
-       (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors)
+       ( AcceptNoTargets(..), TargetContext(..)
+       , updateContextAndWriteProjectFile, withContextAndSelectors
+       , movedExePath )
 import Distribution.Client.Setup                 (GlobalFlags (..))
 import Distribution.Client.TargetProblem         (TargetProblem (..))
 import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)
@@ -170,7 +172,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
 
         bin_file c = case c of
             CD.ComponentExe s
-               | s == selectedComponent -> [bin_file' s]
+               | s == selectedComponent -> [moved_bin_file s]
             CD.ComponentTest s
                | s == selectedComponent -> [bin_file' s]
             CD.ComponentBench s
@@ -194,6 +196,8 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
             then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat
             else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat
 
+        moved_bin_file s = fromMaybe (bin_file' s) (movedExePath selectedComponent distDirLayout elaboratedSharedConfig elab)
+
 -------------------------------------------------------------------------------
 -- Target Problem: the very similar to CmdRun
 -------------------------------------------------------------------------------

diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs
@@ -22,57 +22,56 @@ module Distribution.Client.CmdRun (
 import Prelude ()
 import Distribution.Client.Compat.Prelude hiding (toList)
 
-import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
          ( renderTargetSelector, showTargetSelector,
            renderTargetProblem,
            renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
            targetSelectorFilter, renderListCommaAnd,
            renderListPretty )
-import Distribution.Client.TargetProblem
-         ( TargetProblem (..) )
-
-import Distribution.Client.NixStyleOptions
-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
-import Distribution.Client.Setup
-         ( GlobalFlags(..), ConfigFlags(..) )
 import Distribution.Client.GlobalFlags
          ( defaultGlobalFlags )
-import Distribution.Simple.Flag
-         ( fromFlagOrDefault )
-import Distribution.Simple.Command
-         ( CommandUI(..), usageAlternatives )
-import Distribution.Types.ComponentName
-         ( componentNameRaw )
-import Distribution.Verbosity
-         ( normal, silent )
-import Distribution.Simple.Utils
-         ( wrapText, die', info, notice, safeHead, warn )
+import Distribution.Client.InstallPlan
+         ( toList, foldPlanPackage )
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
          ( ElaboratedConfiguredPackage(..)
          , ElaboratedInstallPlan, binDirectoryFor )
 import Distribution.Client.ProjectPlanning.Types
          ( dataDirsEnvironmentForPlan )
-import Distribution.Client.InstallPlan
-         ( toList, foldPlanPackage )
-import Distribution.Types.UnqualComponentName
-         ( UnqualComponentName, unUnqualComponentName )
+import Distribution.Client.ScriptUtils
+         ( AcceptNoTargets(..), TargetContext(..)
+         , updateContextAndWriteProjectFile, withContextAndSelectors
+         , movedExePath )
+import Distribution.Client.Setup
+         ( GlobalFlags(..), ConfigFlags(..) )
+import Distribution.Client.TargetProblem
+         ( TargetProblem (..) )
+import Distribution.Client.Utils
+         ( occursOnlyOrBefore, giveRTSWarning )
+import Distribution.Simple.Command
+         ( CommandUI(..), usageAlternatives )
+import Distribution.Simple.Flag
+         ( fromFlagOrDefault )
 import Distribution.Simple.Program.Run
          ( runProgramInvocation, ProgramInvocation(..),
            emptyProgramInvocation )
+import Distribution.Simple.Utils
+         ( wrapText, die', info, notice, safeHead, warn )
+import Distribution.Types.ComponentName
+         ( componentNameRaw )
 import Distribution.Types.UnitId
          ( UnitId )
-import Distribution.Client.ScriptUtils
-         ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )
-import Distribution.Client.Utils
-         ( occursOnlyOrBefore, giveRTSWarning )
+import Distribution.Types.UnqualComponentName
+         ( UnqualComponentName, unUnqualComponentName )
+import Distribution.Verbosity
+         ( normal, silent )
 
 import Data.List ( group )
 import qualified Data.Set as Set
-
 import GHC.Environment
          ( getFullArgs )
-
 import System.Directory
          ( doesFileExist )
 import System.FilePath
@@ -226,11 +225,15 @@ runAction flags@NixStyleFlags {..} targetAndArgs globalFlags
         ++ exeName
         ++ ":\n"
         ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
-    let exePath = binDirectoryFor (distDirLayout baseCtx)
-                                  (elaboratedShared buildCtx)
-                                  pkg
-                                  exeName
-               </> exeName
+
+    let defaultExePath = binDirectoryFor
+                            (distDirLayout baseCtx)
+                            (elaboratedShared buildCtx)
+                             pkg
+                             exeName
+                       </> exeName
+        exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg)
+
     let dryRun = buildSettingDryRun (buildSettings baseCtx)
               || buildSettingOnlyDownload (buildSettings baseCtx)
 

diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs
@@ -6,6 +6,7 @@ module Distribution.Client.HashValue (
     hashValue,
     truncateHash,
     showHashValue,
+    showHashValueBase64,
     readFileHashValue,
     hashFromTUF,
     ) where
@@ -17,6 +18,7 @@ import qualified Hackage.Security.Client as Sec
 
 import qualified Crypto.Hash.SHA256         as SHA256
 import qualified Data.ByteString.Base16     as Base16
+import qualified Data.ByteString.Base64     as Base64
 import qualified Data.ByteString.Char8      as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
@@ -55,6 +57,9 @@ hashValue = HashValue . SHA256.hashlazy
 showHashValue :: HashValue -> String
 showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)
 
+showHashValueBase64 :: HashValue -> String
+showHashValueBase64 (HashValue digest) = BS.unpack (Base64.encode digest)
+
 -- | Hash the content of a file. Uses SHA256.
 --
 readFileHashValue :: FilePath -> IO HashValue

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -31,6 +31,7 @@ module Distribution.Client.ProjectConfig (
     readProjectLocalFreezeConfig,
     reportParseResult,
     showProjectConfig,
+    withGlobalConfig,
     withProjectOrGlobalConfig,
     writeProjectLocalExtraConfig,
     writeProjectLocalFreezeConfig,
@@ -507,6 +508,15 @@ renderBadProjectRoot = \case
   BadProjectRootDirFile dir file ->
     "The given project directory/file combination '" <> dir </> file <> "' does not exist."
 
+withGlobalConfig
+    :: Verbosity                  -- ^ verbosity
+    -> Flag FilePath              -- ^ @--cabal-config@
+    -> (ProjectConfig -> IO a)    -- ^ with global
+    -> IO a
+withGlobalConfig verbosity gcf with = do
+    globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
+    with globalConfig
+
 withProjectOrGlobalConfig
     :: Verbosity                  -- ^ verbosity
     -> Flag Bool                  -- ^ whether to ignore local project (--ignore-project flag)