Avoid unpacking ghc to /tmp #996

Also gives a good error message letting you know that directories now exist which won't be used by stack Also removes readInNull utility. I think "exitFailure" should be mentioned upfront.
commercialhaskell · Aug 9, 2016 · d2173e4 · d2173e4
1 parent daf3de5
commit d2173e4
Show file tree

Hide file tree

Showing 6 changed files with 103 additions and 85 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
@@ -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
@@ -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