Handle unset HOME environment variable more gracefully

Test Plan:
  * Validate
  * try `env -i ghc`
  * try `env -i runghc HelloWorld.hs`

Reviewers: austin

Subscribers: thomie, ezyang

Differential Revision: https://phabricator.haskell.org/D1971

GHC Trac Issues: #11678

3 files changed, 17 insertions, 8 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ce51d3e066..2e8af7daa2 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1046,9 +1046,10 @@ opt_i dflags = sOpt_i (settings dflags)
 -- | The directory for this version of ghc in the user's app directory
 -- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
 --
-versionedAppDir :: DynFlags -> IO FilePath
+versionedAppDir :: DynFlags -> MaybeT IO FilePath
 versionedAppDir dflags = do
-  appdir <- getAppUserDataDirectory (programName dflags)
+  -- Make sure we handle the case the HOME isn't set (see #11678)
+  appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags)
   return $ appdir </> versionedFilePath dflags
 
 -- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when
@@ -4334,7 +4335,7 @@ interpretPackageEnv dflags = do
 
     namedEnvPath :: String -> MaybeT IO FilePath
     namedEnvPath name = do
-     appdir <- liftMaybeT $ versionedAppDir dflags
+     appdir <- versionedAppDir dflags
      return $ appdir </> "environments" </> name
 
     probeEnvName :: String -> MaybeT IO FilePath
@@ -4394,7 +4395,7 @@ interpretPackageEnv dflags = do
     findLocalEnvFile :: MaybeT IO FilePath
     findLocalEnvFile = do
         curdir  <- liftMaybeT getCurrentDirectory
-        homedir <- liftMaybeT getHomeDirectory
+        homedir <- tryMaybeT getHomeDirectory
         let probe dir | isDrive dir || dir == homedir
                       = mzero
             probe dir = do
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index decd7a1019..2655c451d8 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -384,11 +384,11 @@ resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig d
 -- NB: This logic is reimplemented in Cabal, so if you change it,
 -- make sure you update Cabal.  (Or, better yet, dump it in the
 -- compiler info so Cabal can use the info.)
-resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
+resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
   dir <- versionedAppDir dflags
   let pkgconf = dir </> "package.conf.d"
-  exist <- doesDirectoryExist pkgconf
-  return $ if exist then Just pkgconf else Nothing
+  exist <- tryMaybeT $ doesDirectoryExist pkgconf
+  if exist then return pkgconf else mzero
 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
 
 readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 83dc9b6864..a736e3dd2e 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -14,11 +14,13 @@ module Maybes (
         whenIsJust,
         expectJust,
 
-        MaybeT(..), liftMaybeT
+        -- * MaybeT
+        MaybeT(..), liftMaybeT, tryMaybeT
     ) where
 
 import Control.Monad
 import Control.Monad.Trans.Maybe
+import Control.Exception (catch, SomeException(..))
 import Data.Maybe
 
 infixr 4 `orElse`
@@ -65,6 +67,12 @@ orElse = flip fromMaybe
 liftMaybeT :: Monad m => m a -> MaybeT m a
 liftMaybeT act = MaybeT $ Just `liftM` act
 
+-- | Try performing an 'IO' action, failing on error.
+tryMaybeT :: IO a -> MaybeT IO a
+tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler
+  where
+    handler (SomeException _) = return Nothing
+
 {-
 ************************************************************************
 *                                                                      *