From da3e43af86a1fb217088e2054f53469e112fd24d Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Thu, 15 Oct 2015 23:47:09 -0700 Subject: [PATCH] Use short SHA for install paths on windows #1145 --- src/Stack/Constants.hs | 21 +------------- src/Stack/Setup.hs | 31 +++++++++++++++++--- src/Stack/Types/Config.hs | 59 ++++++++++++++++++++++++++++----------- 3 files changed, 70 insertions(+), 41 deletions(-) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 2dfb4b48e0..878329bde7 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -52,13 +51,6 @@ import Prelude import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName -#ifdef mingw32_HOST_OS -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text.Encoding as T -#endif -- | Extensions for anything that can be a Haskell module. haskellModuleExts :: [Text] @@ -217,18 +209,7 @@ distRelativeDir = do parseRelDir $ packageIdentifierString (PackageIdentifier cabalPackageName cabalPkgVer) - -#ifdef mingw32_HOST_OS - -- This is an attempt to shorten path to stack build artifacts dir on Windows to - -- decrease our chances of hitting 260 symbol path limit. - -- The idea is to calculate SHA1 hash from concatenated platform and cabal strings, - -- encode with base 16 and take first 8 symbols of it. - let concatenatedText = T.pack . toFilePath $ platform cabal - sha1 = SHA1.hash $ T.encodeUtf8 concatenatedText - platformAndCabal <- parseRelDir . B8.unpack . B.take 8 $ Base16.encode sha1 -#else - let platformAndCabal = platform cabal -#endif + platformAndCabal <- useShaPathOnWindows (platform cabal) return $ workDirRel $(mkRelDir "dist") diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 52e779a451..a882f7f4ff 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -825,6 +825,7 @@ installGHCJS version si archiveFile archiveType destDir = do -- install cabal-install. This lets us also fix the version of -- cabal-install used. let unpackDir = destDir Path. $(mkRelDir "src") + stackYaml = unpackDir $(mkRelFile "stack.yaml") tarComponent <- parseRelDir ("ghcjs-" ++ versionString version) runUnpack <- case platform of Platform _ Cabal.Windows -> return $ do @@ -850,6 +851,13 @@ installGHCJS version si archiveFile archiveType destDir = do $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runUnpack + -- On windows we need to copy options files out of the install dir. Argh! + mwindowsInstallDir <- case platform of + Platform _ Cabal.Windows -> do + $logSticky "Querying GHCJS install dir" + liftM Just $ getGhcjsInstallDir menv stackYaml + _ -> return Nothing + $logSticky "Installing GHCJS (this will take a long time) ..." let destBinDir = destDir Path. $(mkRelDir "bin") stackPath <- liftIO getExecutablePath @@ -857,12 +865,17 @@ installGHCJS version si archiveFile archiveType destDir = do runAndLog (Just unpackDir) stackPath menv [ "--install-ghc" , "--stack-yaml" - , toFilePath (unpackDir $(mkRelFile "stack.yaml")) + , toFilePath stackYaml , "--local-bin-path" , toFilePath destBinDir , "install" - , "-v" ] + forM_ mwindowsInstallDir $ \dir -> do + (_, files) <- listDirectory (dir Path. $(mkRelDir "bin")) + forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do + let dest = destDir filename optionsFile + removeFileIfExists dest + copyFile optionsFile dest $logStickyDone "Installed GHCJS." -- Install the downloaded stack binary distribution @@ -980,6 +993,17 @@ getCabalInstallVersion menv stackYaml = do Left _ -> return Nothing Right bs -> Just <$> parseVersion (T.encodeUtf8 (T.dropWhileEnd isSpace (T.decodeUtf8 bs))) +getGhcjsInstallDir :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) + => EnvOverride -> Path Abs File -> m (Path Abs Dir) +getGhcjsInstallDir menv stackYaml = do + bs <- readProcessStdout Nothing menv "stack" + [ "--stack-yaml" + , toFilePath stackYaml + , "path" + , "--local-install-root" + ] + parseAbsDir $ T.unpack $ T.concat $ T.lines $ T.decodeUtf8 $ bs + -- | Check if given processes appear to be present, throwing an exception if -- missing. checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env) @@ -1087,10 +1111,9 @@ withUnpackedTarball7z name si archiveFile archiveType srcDir destDir = do Just x -> parseAbsFile $ T.unpack x run7z <- setup7z si let tmpName = (FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp" + createTree (parent destDir) withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do let absSrcDir = tmpDir srcDir - removeTreeIfExists absSrcDir - removeFileIfExists tarFile removeTreeIfExists destDir run7z (parent archiveFile) archiveFile run7z tmpDir tarFile diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index c3d16814e1..e923c26da9 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} @@ -35,7 +36,6 @@ import Data.List (stripPrefix) import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map - import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid @@ -61,6 +61,10 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Process.Read (EnvOverride) +#ifdef mingw32_HOST_OS +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString.Base16 as B16 +#endif -- | The top-level Stackage configuration. data Config = @@ -904,15 +908,6 @@ platformOnlyRelDir = do platform <- asks getPlatform parseRelDir (Distribution.Text.display platform) --- | Relative directory for the platform identifier -platformVariantRelDir - :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) - => m (Path Rel Dir) -platformVariantRelDir = do - platform <- asks getPlatform - ghcVariant <- asks getGHCVariant - parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) - -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) configShakeFilesDir = liftM ( $(mkRelDir "shake")) configProjectWorkDir @@ -931,20 +926,50 @@ snapshotsDir = do -- | Installation root for dependencies installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootDeps = do - snapshots <- snapshotsDir - bc <- asks getBuildConfig - name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc - ghc <- compilerVersionDir - return $ snapshots name ghc + config <- asks getConfig + -- TODO: also useShaPathOnWindows here, once #1173 is resolved. + psc <- platformSnapAndCompilerRel + return $ configStackRoot config $(mkRelDir "snapshots") psc -- | Installation root for locals installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootLocal = do bc <- asks getBuildConfig + psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel + return $ configProjectWorkDir bc $(mkRelDir "install") psc + +-- | Path for platform followed by snapshot name followed by compiler +-- name. +platformSnapAndCompilerRel + :: (MonadReader env m, HasPlatform env, HasEnvConfig env, MonadThrow m) + => m (Path Rel Dir) +platformSnapAndCompilerRel = do + bc <- asks getBuildConfig + platform <- platformVariantRelDir name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir - platform <- platformVariantRelDir - return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc + useShaPathOnWindows (platform name ghc) + +-- | Relative directory for the platform identifier +platformVariantRelDir + :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) + => m (Path Rel Dir) +platformVariantRelDir = do + platform <- asks getPlatform + ghcVariant <- asks getGHCVariant + parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) + +-- | This is an attempt to shorten stack paths on Windows to decrease our +-- chances of hitting 260 symbol path limit. The idea is to calculate +-- SHA1 hash of the path used on other architectures, encode with base +-- 16 and take first 8 symbols of it. +useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir) +useShaPathOnWindows = +#ifdef mingw32_HOST_OS + parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath +#else + return +#endif compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) compilerVersionDir = do