Use short SHA for install paths on windows #1145

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") </>

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,19 +851,31 @@ 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
     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 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

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