Avoid MAX_PATH for precompiled cache #3649

ChangeLog.md

@@ -11,6 +11,9 @@ Behaviour changes:
 Other enhancements:
 
 Bug fixes:
+* 1.6.1 introduced a change that made some precompiled cache files use
+  longer paths, sometimes causing builds to fail on windows. This has been
+  fixed. See [#3649](https://github.com/commercialhaskell/stack/issues/3649)
 
 
 ## v1.6.3

src/Stack/Build/Cache.hs

@@ -32,6 +32,7 @@ module Stack.Build.Cache
     , BuildCache(..)
     ) where
 
+import           Stack.Constants
 import           Stack.Prelude
 import           Crypto.Hash (hashWith, SHA256(..))
 import           Control.Monad.Trans.Maybe
@@ -254,6 +255,14 @@ precompiledCacheFile loc copts installedPackageIDs = do
             PLRepo r -> Just $ T.unpack (repoCommit r) ++ repoSubdirs r
 
   forM mpkgRaw $ \pkgRaw -> do
+    platformRelDir <- platformGhcRelDir
+    let precompiledDir =
+              view stackRootL ec
+          </> $(mkRelDir "precompiled")
+          </> platformRelDir
+          </> compiler
+          </> cabal
+
     pkg <-
       case parseRelDir pkgRaw of
         Just x -> return x
@@ -263,7 +272,6 @@ precompiledCacheFile loc copts installedPackageIDs = do
                  $ B64URL.encode
                  $ TE.encodeUtf8
                  $ T.pack pkgRaw
-    platformRelDir <- platformGhcRelDir
 
     -- In Cabal versions 1.22 and later, the configure options contain the
     -- installed package IDs, which is what we need for a unique hash.
@@ -274,13 +282,19 @@ precompiledCacheFile loc copts installedPackageIDs = do
     hashPath <- parseRelFile $ S8.unpack $ B64URL.encode
               $ Mem.convert $ hashWith SHA256 $ Store.encode input
 
-    return $ view stackRootL ec
-         </> $(mkRelDir "precompiled")
-         </> platformRelDir
-         </> compiler
-         </> cabal
-         </> pkg
-         </> hashPath
+    let longPath = precompiledDir </> pkg </> hashPath
+
+    -- See #3649 - shorten the paths on windows if MAX_PATH will be
+    -- violated. Doing this only when necessary allows use of existing
+    -- precompiled packages.
+    case maxPathLength of
+      Nothing -> return longPath
+      Just maxPath
+        | length (toFilePath longPath) > maxPath -> do
+            shortPkg <- shaPath pkg
+            shortHash <- shaPath hashPath
+            return $ precompiledDir </> shortPkg </> shortHash
+        | otherwise -> return longPath
 
 -- | Write out information about a newly built package
 writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)

src/Stack/Constants.hs

@@ -1,6 +1,7 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- | Constants used throughout the project.
 
@@ -32,6 +33,7 @@ module Stack.Constants
     ,minTerminalWidth
     ,maxTerminalWidth
     ,defaultTerminalWidth
+    ,maxPathLength
     )
     where
 
@@ -241,3 +243,12 @@ maxTerminalWidth = 200
 -- automatically detect it and when the user doesn't supply one.
 defaultTerminalWidth :: Int
 defaultTerminalWidth = 100
+
+-- | Maximum length to use in paths. Is only a 'Just' value on windows,
+-- corresponding to MAX_PATH.
+maxPathLength :: Maybe Int
+#ifdef mings32_HOST_OS
+maxPathLength = Just 260
+#else
+maxPathLength = Nothing
+#endif

src/Stack/Types/Config.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFoldable #-}
@@ -9,17 +9,18 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | The Config type.
 
@@ -131,6 +132,7 @@ module Stack.Types.Config
   ,platformGhcRelDir
   ,platformGhcVerOnlyRelDir
   ,useShaPathOnWindows
+  ,shaPath
   ,workDirL
   -- * Command-specific types
   -- ** Eval
@@ -176,6 +178,7 @@ module Stack.Types.Config
   ) where
 
 import           Control.Monad.Writer (tell)
+import           Crypto.Hash (hashWith, SHA1(..))
 import           Stack.Prelude
 import           Data.Aeson.Extended
                  (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
@@ -184,6 +187,7 @@ import           Data.Aeson.Extended
                   jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,
                   FromJSONKeyFunction (FromJSONKeyTextParser))
 import           Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
+import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
 import qualified Data.ByteString.Char8 as S8
 import           Data.List (stripPrefix)
 import           Data.List.NonEmpty (NonEmpty)
@@ -231,11 +235,6 @@ import           System.Process.Read (EnvOverride, findExecutable)
 -- Re-exports
 import           Stack.Types.Config.Build as X
 
-#ifdef mingw32_HOST_OS
-import           Crypto.Hash (hashWith, SHA1(..))
-import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
-#endif
-
 -- | The top-level Stackage configuration.
 data Config =
   Config {configStackRoot           :: !(Path Abs Dir)
@@ -1372,11 +1371,27 @@ platformGhcVerOnlyRelDirStr = do
 useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
 useShaPathOnWindows =
 #ifdef mingw32_HOST_OS
-    parseRelDir . S8.unpack . S8.take 8 . Mem.convertToBase Mem.Base16 . hashWith SHA1 . encodeUtf8 . T.pack . toFilePath
+    shaPath
 #else
     return
 #endif
 
+shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)
+shaPath
+    = parsePath . S8.unpack . S8.take 8
+    . Mem.convertToBase Mem.Base16 . hashWith SHA1
+    . encodeUtf8 . T.pack . toFilePath
+
+-- TODO: Move something like this into the path package. Consider
+-- subsuming path-io's 'AnyPath'?
+class IsPath b t where
+  parsePath :: MonadThrow m => FilePath -> m (Path b t)
+
+instance IsPath Abs Dir where parsePath = parseAbsDir
+instance IsPath Rel Dir where parsePath = parseRelDir
+instance IsPath Abs File where parsePath = parseAbsFile
+instance IsPath Rel File where parsePath = parseRelFile
+
 compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
 compilerVersionDir = do
     compilerVersion <- view actualCompilerVersionL