From e872d8eb4f18c30330808d48f0a00dcc095833f4 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Mon, 8 Aug 2016 19:25:48 -0700 Subject: [PATCH] Don't use system temp dir for stack setup #996 + remove readInNull utility. I think "exitFailure" should be mentioned upfront. --- ChangeLog.md | 2 ++ src/Stack/PackageIndex.hs | 62 ++++++++++++++++++-------------------- src/Stack/PrettyPrint.hs | 5 ++- src/Stack/Setup.hs | 42 ++++++++++++++++---------- src/System/Process/Read.hs | 21 ------------- 5 files changed, 62 insertions(+), 70 deletions(-) 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 5b9147c1d1..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 @@ -89,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) @@ -846,23 +847,33 @@ installGHCPosix version _ archiveFile archiveType tempDir destDir = do parseRelDir $ "ghc-" ++ versionString version - errMsg <- fmap Just $ displayAnsiIfPossible $ - "Error encountered while installing GHC." <> line <> line <> - "The following directories may now contain files, but won't be used by stack:" <> line <> - -- TODO: pretty-print utilities for this - " -" <+> display tempDir <> line <> - " -" <+> display destDir <> line + 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) - readInNull tempDir tarTool menv [compOpt : "xf", toFilePath archiveFile] errMsg + runStep "unpacking" tempDir tarTool [compOpt : "xf", toFilePath archiveFile] $logSticky "Configuring GHC ..." - readInNull dir (toFilePath $ dir $(mkRelFile "configure")) - menv ["--prefix=" ++ toFilePath destDir] errMsg + runStep "configuring" dir (toFilePath $ dir $(mkRelFile "configure")) ["--prefix=" ++ toFilePath destDir] $logSticky "Installing GHC ..." - readInNull dir makeTool menv ["install"] errMsg + runStep "installing" dir makeTool ["install"] $logStickyDone $ "Installed GHC." $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) @@ -913,7 +924,7 @@ installGHCJS si archiveFile archiveType _tempDir 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 @@ -962,12 +973,11 @@ installDockerStackExe _ archiveFile _ _tempDir destDir = do (,) <$> 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 () 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)