[commit: ghc] master: Don't perform permission checks for scripts named with -ghci-script (#6017) (a6f2c85)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a6f2c852d49313fa8acea2deb3741ab86c6ef995/ghc

>---------------------------------------------------------------

commit a6f2c852d49313fa8acea2deb3741ab86c6ef995
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Mar 20 21:47:22 2014 +0000

    Don't perform permission checks for scripts named with -ghci-script (#6017)
    
    The user explicitly requested this script on the command-line, so it's
    unnecessary to require that the script is also owned by the user.
    Also, it is currently impossible to make a GHCi wrapper that invokes a
    custom script without first making a copy of the script to circumvent
    the permissions check, which seems wrong.


>---------------------------------------------------------------

a6f2c852d49313fa8acea2deb3741ab86c6ef995
 ghc/InteractiveUI.hs |   26 ++++++++++++++++++--------
 ghc/ghc-bin.cabal.in |    1 +
 2 files changed, 19 insertions(+), 8 deletions(-)

diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 1476f95..b41c2db 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -455,13 +455,18 @@ runGHCi paths maybe_exprs = do
    canonicalizePath' fp = liftM Just (canonicalizePath fp)
                 `catchIO` \_ -> return Nothing
 
-   sourceConfigFile :: FilePath -> GHCi ()
-   sourceConfigFile file = do
+   sourceConfigFile :: (FilePath, Bool) -> GHCi ()
+   sourceConfigFile (file, check_perms) = do
      exists <- liftIO $ doesFileExist file
      when exists $ do
-       dir_ok  <- liftIO $ checkPerms (getDirectory file)
-       file_ok <- liftIO $ checkPerms file
-       when (dir_ok && file_ok) $ do
+       perms_ok <-
+         if not check_perms
+            then return True
+            else do
+              dir_ok  <- liftIO $ checkPerms (getDirectory file)
+              file_ok <- liftIO $ checkPerms file
+              return (dir_ok && file_ok)
+       when perms_ok $ do
          either_hdl <- liftIO $ tryIO (openFile file ReadMode)
          case either_hdl of
            Left _e   -> return ()
@@ -479,9 +484,14 @@ runGHCi paths maybe_exprs = do
   setGHCContextFromGHCiState
 
   when (read_dot_files) $ do
-    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
-    mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
-    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
+    mcfgs0 <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
+    let mcfgs1 = zip mcfgs0 (repeat True)
+              ++ zip (ghciScripts dflags) (repeat False)
+         -- False says "don't check permissions".  We don't
+         -- require that a script explicitly added by
+         -- -ghci-script is owned by the current user. (#6017)
+    mcfgs <- liftIO $ mapM (\(f, b) -> (,b) <$> canonicalizePath' f) mcfgs1
+    mapM_ sourceConfigFile $ nub $ [ (f,b) | (Just f, b) <- mcfgs ]
         -- nub, because we don't want to read .ghci twice if the
         -- CWD is $HOME.
 
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 561c55c..68338f3 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -48,6 +48,7 @@ Executable ghc
         Extensions: ForeignFunctionInterface,
                     UnboxedTuples,
                     FlexibleInstances,
+                    TupleSections,
                     MagicHash
 
     Extensions: CPP, PatternGuards, NondecreasingIndentation