Don't use system temp dir for stack setup #996

+ remove readInNull utility. I think "exitFailure" should be mentioned upfront.
commercialhaskell · Aug 9, 2016 · e872d8e · e872d8e
1 parent 83ef330
commit e872d8e
Show file tree

Hide file tree

Showing 5 changed files with 62 additions and 70 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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)