Merge pull request #2003 from commercialhaskell/hotfix/2000-dont-delete-ssh

v1.0.4.3 hotfix for deletion of ~/.ssh

Author: borsboom

ChangeLog.md

@@ -1,5 +1,12 @@
 # Changelog
 
+## 1.0.4.3
+
+Bug fixes
+
+* Don't delete contents of ~/.ssh when using `stack clean --full` with Docker
+  enabled [#2000](https://github.com/commercialhaskell/stack/issues/2000)
+
 ## 1.0.4.2
 
 Build with path-io-1.0.0. There are no changes in behaviour from 1.0.4,

src/Stack/Docker.hs

@@ -260,8 +260,6 @@ runContainerAndExit getCmdArgs
        <*> hIsTerminalDevice stderr
        <*> (parseAbsDir =<< getHomeDirectory)
      isStdoutTerminal <- asks getTerminal
-     let sshDir = homeDir </> sshRelDir
-     sshDirExists <- doesDirExist sshDir
      let dockerHost = lookup "DOCKER_HOST" env
          dockerCertPath = lookup "DOCKER_CERT_PATH" env
          bamboo = lookup "bamboo_buildKey" env
@@ -309,6 +307,19 @@ runContainerAndExit getCmdArgs
      liftIO
        (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)
            mapM_ (ensureDir) [sandboxHomeDir, stackRoot])
+     -- Since $HOME is now mounted in the same place in the container we can
+     -- just symlink $HOME/.ssh to the right place for the stack docker user
+     let sshDir = homeDir </> sshRelDir
+     sshDirExists <- doesDirExist sshDir
+     sshSandboxDirExists <-
+         liftIO
+             (Files.fileExist
+                 (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)))
+     when (sshDirExists && not sshSandboxDirExists)
+         (liftIO
+             (Files.createSymbolicLink
+                 (toFilePathNoTrailingSep sshDir)
+                 (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))
      containerID <- (trim . decodeUtf8) <$> readDockerProcess
        envOverride
        (concat
@@ -320,17 +331,14 @@ runContainerAndExit getCmdArgs
           ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
           ,"-e","PATH=" ++ T.unpack newPathEnv
           ,"-e","PWD=" ++ toFilePathNoTrailingSep pwd
+          ,"-v",toFilePathNoTrailingSep homeDir ++ ":" ++ toFilePathNoTrailingSep homeDir
           ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot
           ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot
           ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir
           ,"-w",toFilePathNoTrailingSep pwd]
          ,case muserEnv of
             Nothing -> []
             Just userEnv -> ["-e","USER=" ++ userEnv]
-         ,if sshDirExists
-          then ["-v",toFilePathNoTrailingSep sshDir ++ ":" ++
-                     toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)]
-          else []
          ,case msshAuthSock of
             Nothing -> []
             Just sshAuthSock ->

stack.cabal

@@ -1,5 +1,5 @@
 name:                stack
-version:             1.0.4.2
+version:             1.0.4.3
 synopsis:            The Haskell Tool Stack
 description:         Please see the README.md for usage information, and
                      the wiki on Github for more details.  Also, note that