diff --git a/ChangeLog.md b/ChangeLog.md index a38429e76f..e7187e4c4a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -27,6 +27,8 @@ Other enhancements: * Perform some subprocesses during setup concurrently, slightly speeding up most commands. [#2346](https://github.com/commercialhaskell/stack/pull/2346) * Support for absolute file path in `url` field of `setup-info` or `--ghc-bindist` +* `stack setup` no longer unpacks to the system temp dir on posix systems. + [#996](https://github.com/commercialhaskell/stack/issues/996) Bug fixes: diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 10d7222da0..f4a8216dc2 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -33,12 +33,10 @@ import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logDebug, - logInfo, logWarn) + logInfo, logWarn, logError) import Control.Monad.Reader (asks) import Control.Monad.Trans.Control - import Data.Aeson.Extended -import Data.Store.VersionTagged import qualified Data.ByteString.Lazy as L import Data.Conduit (($$), (=$)) import Data.Conduit.Binary (sinkHandle, @@ -49,38 +47,32 @@ import Data.IORef import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set -import Data.Monoid +import Data.Store.Version +import Data.Store.VersionTagged +import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Unsafe (unsafeTail) - import Data.Traversable (forM) - import Data.Typeable (Typeable) - import Network.HTTP.Download -import Path (mkRelDir, parent, - parseRelDir, toFilePath, - parseAbsFile, ()) +import Path (mkRelDir, parent, parseRelDir, toFilePath, parseAbsFile, ()) import Path.IO import Prelude -- Fix AMP warning import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName -import Stack.Types.Version import Stack.Types.StackT +import Stack.Types.Version import System.FilePath (takeBaseName, (<.>)) -import System.IO (IOMode (ReadMode, WriteMode), - withBinaryFile) -import System.Process.Read (EnvOverride, - doesExecutableExist, readInNull, - tryProcessStdout) -import System.Process.Run (Cmd(..), callProcessInheritStderrStdout) -import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) -import Data.Store.Version +import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile) +import System.Process.Read (EnvOverride, ReadProcessException(..), doesExecutableExist, readProcessNull, tryProcessStdout) +import System.Process.Run (Cmd(..), callProcessInheritStderrStdout) +import System.Exit (exitFailure) -- | Populate the package index caches and return them. populateCache @@ -258,7 +250,7 @@ updateIndexGit menv indexName' index gitUrl = do acfDir = suDir repoName repoExists <- doesDirExist acfDir unless repoExists - (readInNull suDir "git" menv cloneArgs Nothing) + (readProcessNull (Just suDir) menv "git" cloneArgs) $logSticky "Fetching package index ..." let runFetch = callProcessInheritStderrStdout (Cmd (Just acfDir) "git" menv ["fetch","--tags","--depth=1"]) @@ -267,19 +259,26 @@ updateIndexGit menv indexName' index gitUrl = do $logWarn (T.pack (show ex)) $logStickyDone "Failed to fetch package index, retrying." removeDirRecur acfDir - readInNull suDir "git" menv cloneArgs Nothing + readProcessNull (Just suDir) menv "git" cloneArgs $logSticky "Fetching package index ..." runFetch $logStickyDone "Fetched package index." - when (indexGpgVerify index) - (readInNull acfDir "git" menv ["tag","-v","current-hackage"] - (Just (T.unlines ["Signature verification failed. " - ,"Please ensure you've set up your" - ,"GPG keychain to accept the D6CF60FD signing key." - ,"For more information, see:" - ,"https://github.com/fpco/stackage-update#readme"]))) - + when (indexGpgVerify index) $ do + result <- C.try $ readProcessNull (Just acfDir) menv "git" ["tag","-v","current-hackage"] + case result of + Left ex -> do + $logError (T.pack (show ex)) + case ex of + ReadProcessException{} -> $logError $ T.unlines + ["Signature verification failed. " + ,"Please ensure you've set up your" + ,"GPG keychain to accept the D6CF60FD signing key." + ,"For more information, see:" + ,"https://github.com/fpco/stackage-update#readme"] + _ -> return () + liftIO exitFailure + Right () -> return () -- generate index archive when commit id differs from cloned repo tarId <- getTarCommitId (toFilePath tarFile) cloneId <- getCloneCommitId acfDir @@ -300,9 +299,8 @@ updateIndexGit menv indexName' index gitUrl = do deleteCache indexName' $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile) let tarFileTmp = toFilePath tarFile ++ ".tmp" - readInNull acfDir - "git" menv ["archive","--format=tar","-o",tarFileTmp,"current-hackage"] - Nothing + readProcessNull (Just acfDir) menv + "git" ["archive","--format=tar","-o",tarFileTmp,"current-hackage"] tarFileTmpPath <- parseAbsFile tarFileTmp renameFile tarFileTmpPath tarFile diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index f76311266a..e7d3830ec5 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -12,7 +12,7 @@ module Stack.PrettyPrint -- * Color utils -- | These are preferred to colors directly, so that we can -- encourage consistency of color meanings. - , errorRed, goodGreen + , errorRed, goodGreen, shellMagenta , displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc @@ -71,6 +71,9 @@ errorRed = dullred goodGreen :: AnsiDoc -> AnsiDoc goodGreen = green +shellMagenta :: AnsiDoc -> AnsiDoc +shellMagenta = magenta + displayTargetPkgId :: PackageIdentifier -> AnsiDoc displayTargetPkgId = cyan . display diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 0b8ad69faa..66227440b1 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} module Stack.Setup ( setupEnv @@ -49,6 +50,7 @@ import Data.Monoid import Data.Ord (comparing) import Data.Set (Set) import qualified Data.Set as Set +import Data.String import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -75,6 +77,7 @@ import Stack.Constants (distRelativeDir, stackProgName) import Stack.Exec (defaultEnvSettings) import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath) +import Stack.PrettyPrint import Stack.Setup.Installed import Stack.Types.Build import Stack.Types.Compiler @@ -87,7 +90,7 @@ import Stack.Types.StackT import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath) -import System.Exit (ExitCode (ExitSuccess)) +import System.Exit (ExitCode (..), exitFailure) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP import System.Process (rawSystem) @@ -650,15 +653,19 @@ downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader en -> SetupInfo -> DownloadInfo -> Tool - -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ()) + -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> m ()) -> m Tool downloadAndInstallTool programsDir si downloadInfo tool installer = do ensureDir programsDir (file, at) <- downloadFromInfo programsDir downloadInfo tool dir <- installDir programsDir tool + tempDir <- tempInstallDir programsDir tool + ignoringAbsence (removeDirRecur tempDir) + ensureDir tempDir unmarkInstalled programsDir tool - installer si file at dir + installer si file at tempDir dir markInstalled programsDir tool + ignoringAbsence (removeDirRecur tempDir) return tool downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) @@ -801,14 +808,15 @@ data ArchiveType | TarGz | SevenZ -installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, HasTerminal env) => Version -> SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir + -> Path Abs Dir -> m () -installGHCPosix version _ archiveFile archiveType destDir = do +installGHCPosix version _ archiveFile archiveType tempDir destDir = do platform <- asks getPlatform menv0 <- getMinimalEnvOverride menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0)) @@ -834,33 +842,50 @@ installGHCPosix version _ archiveFile archiveType destDir = do $logDebug $ "make: " <> T.pack makeTool $logDebug $ "tar: " <> T.pack tarTool - withSystemTempDir "stack-setup" $ \root -> do - dir <- - liftM (root ) $ - parseRelDir $ - "ghc-" ++ versionString version - - $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."] - $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) - readInNull root tarTool menv [compOpt : "xf", toFilePath archiveFile] Nothing + dir <- + liftM (tempDir ) $ + parseRelDir $ + "ghc-" ++ versionString version + + let runStep step wd cmd args = do + result <- try (readProcessNull (Just wd) menv cmd args) + case result of + Right _ -> return () + Left ex -> do + $logError (T.pack (show (ex :: ReadProcessException))) + $prettyError $ + hang 2 + ("Error encountered while" <+> step <+> "GHC with" <> line <> + shellMagenta (fromString (unwords (cmd : args))) <> line <> + -- TODO: Figure out how to insert \ in the appropriate spots + -- hang 2 (shellMagenta (fillSep (fromString cmd : map fromString args))) <> line <> + "run in " <> display wd) <> line <> line <> + "The following directories may now contain files, but won't be used by stack:" <> line <> + " -" <+> display tempDir <> line <> + " -" <+> display destDir <> line + liftIO exitFailure + + $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."] + $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) + runStep "unpacking" tempDir tarTool [compOpt : "xf", toFilePath archiveFile] - $logSticky "Configuring GHC ..." - readInNull dir (toFilePath $ dir $(mkRelFile "configure")) - menv ["--prefix=" ++ toFilePath destDir] Nothing + $logSticky "Configuring GHC ..." + runStep "configuring" dir (toFilePath $ dir $(mkRelFile "configure")) ["--prefix=" ++ toFilePath destDir] - $logSticky "Installing GHC ..." - readInNull dir makeTool menv ["install"] Nothing + $logSticky "Installing GHC ..." + runStep "installing" dir makeTool ["install"] - $logStickyDone $ "Installed GHC." - $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) + $logStickyDone $ "Installed GHC." + $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir + -> Path Abs Dir -> m () -installGHCJS si archiveFile archiveType destDir = do +installGHCJS si archiveFile archiveType _tempDir destDir = do platform <- asks getPlatform menv0 <- getMinimalEnvOverride -- This ensures that locking is disabled for the invocations of @@ -869,7 +894,7 @@ installGHCJS si archiveFile archiveType destDir = do menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0))) $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) - -- NOTE: this is a bit of a hack - instead of using a temp + -- NOTE: this is a bit of a hack - instead of using the temp -- directory, leave the unpacked source tarball in the destination -- directory. This way, the absolute paths in the wrapper scripts -- will point to executables that exist in @@ -899,7 +924,7 @@ installGHCJS si archiveFile archiveType destDir = do return $ do ignoringAbsence (removeDirRecur destDir) ignoringAbsence (removeDirRecur unpackDir) - readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing + readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile] innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir @@ -940,19 +965,19 @@ installDockerStackExe -> Path Abs File -> ArchiveType -> Path Abs Dir + -> Path Abs Dir -> m () -installDockerStackExe _ archiveFile _ destDir = do +installDockerStackExe _ archiveFile _ _tempDir destDir = do (_,tarTool) <- checkDependencies $ (,) <$> checkDependency "gzip" <*> checkDependency "tar" menv <- getMinimalEnvOverride ensureDir destDir - readInNull - destDir - tarTool + readProcessNull + (Just destDir) menv + tarTool ["xf", toFilePath archiveFile, "--strip-components", "1"] - Nothing ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m) => EnvOverride -> CompilerVersion -> Bool -> m () @@ -1108,8 +1133,9 @@ installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, -> Path Abs File -> ArchiveType -> Path Abs Dir + -> Path Abs Dir -> m () -installGHCWindows version si archiveFile archiveType destDir = do +installGHCWindows version si archiveFile archiveType _tempDir destDir = do tarComponent <- parseRelDir $ "ghc-" ++ versionString version withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) @@ -1120,8 +1146,9 @@ installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m -> Path Abs File -> ArchiveType -> Path Abs Dir + -> Path Abs Dir -> m () -installMsys2Windows osKey si archiveFile archiveType destDir = do +installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do $logError $ T.pack $ diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index d77187e714..e3dc881ef9 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -17,6 +17,7 @@ module Stack.Setup.Installed , ExtraDirs (..) , extraDirs , installDir + , tempInstallDir ) where import Control.Applicative @@ -187,3 +188,11 @@ installDir :: (MonadReader env m, MonadThrow m) installDir programsDir tool = do reldir <- parseRelDir $ toolString tool return $ programsDir reldir + +tempInstallDir :: (MonadReader env m, MonadThrow m) + => Path Abs Dir + -> Tool + -> m (Path Abs Dir) +tempInstallDir programsDir tool = do + reldir <- parseRelDir $ toolString tool ++ ".temp" + return $ programsDir reldir diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 34532351bf..73e23c3f3f 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -28,7 +28,6 @@ module System.Process.Read ,envSearchPath ,preProcess ,readProcessNull - ,readInNull ,ReadProcessException (..) ,augmentPath ,augmentPathMap @@ -153,26 +152,6 @@ readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch readProcessNull wd menv name args = sinkProcessStdout wd menv name args CL.sinkNull --- | Run the given command in the given directory. If it exits with anything --- but success, print an error and then call 'exitWith' to exit the program. -readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Path Abs Dir -- ^ Directory to run in - -> FilePath -- ^ Command to run - -> EnvOverride - -> [String] -- ^ Command line arguments - -> Maybe Text -- ^ Optional additional error message - -> m () -readInNull wd cmd menv args errMsg = do - result <- try (readProcessNull (Just wd) menv cmd args) - case result of - Left ex -> do - $logError (T.pack (show ex)) - case ex of - ReadProcessException{} -> forM_ errMsg $logError - _ -> return () - liftIO exitFailure - Right () -> return () - -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)