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.*

(cherry picked from commit a482a63)

# Conflicts:
#	cabal-install/src/Distribution/Client/CmdRun.hs
#	cabal-install/src/Distribution/Client/ProjectConfig.hs

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -1385,7 +1385,7 @@ checkGhcOptions fieldName getOptions pkg =
   , checkFlags ["-prof"] $
       PackageBuildWarning (OptProf fieldName)
 
-  , checkFlags ["-o"] $
+  , unlessScript . checkFlags ["-o"] $
       PackageBuildWarning (OptO fieldName)
 
   , checkFlags ["-hide-package"] $
@@ -1478,6 +1478,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)
 

cabal-install/cabal-install.cabal

@@ -204,6 +204,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,

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
 -------------------------------------------------------------------------------

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

@@ -22,22 +22,15 @@ 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 )
+<<<<<<< HEAD
 import Distribution.Simple.Flag
          ( fromFlagOrDefault )
 import Distribution.Simple.Command
@@ -48,25 +41,58 @@ import Distribution.Verbosity
          ( normal, silent )
 import Distribution.Simple.Utils
          ( wrapText, die', info, notice, safeHead )
+=======
+import Distribution.Client.InstallPlan
+         ( toList, foldPlanPackage )
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+import Distribution.Client.ProjectOrchestration
+>>>>>>> a482a63c1 (Shorten script-builds paths (#8898))
 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 )
+<<<<<<< HEAD
 import Distribution.Client.ScriptUtils
          ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )
+=======
+import Distribution.Types.UnqualComponentName
+         ( UnqualComponentName, unUnqualComponentName )
+import Distribution.Verbosity
+         ( normal, silent )
+>>>>>>> a482a63c1 (Shorten script-builds paths (#8898))
 
 import Data.List (group)
 import qualified Data.Set as Set
+<<<<<<< HEAD
+=======
+import GHC.Environment
+         ( getFullArgs )
+>>>>>>> a482a63c1 (Shorten script-builds paths (#8898))
 import System.Directory
          ( doesFileExist )
 import System.FilePath
@@ -216,11 +242,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)
 

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

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

@@ -31,6 +31,7 @@ module Distribution.Client.ProjectConfig (
     readProjectLocalFreezeConfig,
     reportParseResult,
     showProjectConfig,
+    withGlobalConfig,
     withProjectOrGlobalConfig,
     writeProjectLocalExtraConfig,
     writeProjectLocalFreezeConfig,
@@ -462,6 +463,27 @@ renderBadProjectRoot :: BadProjectRoot -> String
 renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =
     "The given project file '" ++ projectFile ++ "' does not exist."
 
+<<<<<<< HEAD
+=======
+  BadProjectRootDir dir ->
+    "The given project directory '" <> dir <> "' does not exist."
+
+  BadProjectRootAbsoluteFile file ->
+    "The given project file '" <> file <> "' does not exist."
+
+  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
+
+>>>>>>> a482a63c1 (Shorten script-builds paths (#8898))
 withProjectOrGlobalConfig
     :: Verbosity                  -- ^ verbosity
     -> Flag Bool                  -- ^ whether to ignore local project (--ignore-project flag)