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..c4953c2fba 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -850,19 +850,35 @@ installGHCJS version si archiveFile archiveType destDir = do $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runUnpack + let stackYaml = unpackDir $(mkRelFile "stack.yaml") + + -- On windows we need to copy options files out of the install dir. Argh! + -- This is done before the build, so that if it fails, things fail + -- earlier. + stackPath <- liftIO getExecutablePath + mwindowsInstallDir <- case platform of + Platform _ Cabal.Windows -> do + $logSticky "Querying GHCJS install dir" + liftM Just $ getGhcjsInstallDir menv stackPath stackYaml + _ -> return Nothing + $logSticky "Installing GHCJS (this will take a long time) ..." let destBinDir = destDir Path. $(mkRelDir "bin") - stackPath <- liftIO getExecutablePath createTree destBinDir 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 $(mkRelDir "bin")) + forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do + let dest = destDir $(mkRelDir "bin") filename optionsFile + removeFileIfExists dest + copyFile optionsFile dest $logStickyDone "Installed GHCJS." -- Install the downloaded stack binary distribution @@ -925,7 +941,7 @@ bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) bootGhcjs menv stackYaml = do stackPath <- liftIO getExecutablePath -- Install cabal-install if missing, or if the installed one is old. - mcabal <- getCabalInstallVersion menv stackYaml + mcabal <- getCabalInstallVersion menv stackPath stackYaml shouldInstallCabal <- case mcabal of Nothing -> do $logInfo "No 'cabal' binary found for use with GHCJS. Installing a local copy of 'cabal' from source." @@ -967,9 +983,9 @@ runAndLog mdir name menv args = liftBaseWith $ \restore -> do void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) - => EnvOverride -> Path Abs File -> m (Maybe Version) -getCabalInstallVersion menv stackYaml = do - ebs <- tryProcessStdout Nothing menv "stack" + => EnvOverride -> FilePath -> Path Abs File -> m (Maybe Version) +getCabalInstallVersion menv stackPath stackYaml = do + ebs <- tryProcessStdout Nothing menv stackPath [ "--stack-yaml" , toFilePath stackYaml , "exec" @@ -980,6 +996,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 -> FilePath -> Path Abs File -> m (Path Abs Dir) +getGhcjsInstallDir menv stackPath stackYaml = do + bs <- readProcessStdout Nothing menv stackPath + [ "--stack-yaml" + , toFilePath stackYaml + , "path" + , "--local-install-root" + ] + parseAbsDir $ T.unpack $ T.dropWhileEnd isSpace $ 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 +1114,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