From dfbbfedc7e68d3095a37e4359b69eccc27e5398c Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 4 May 2001 14:56:53 +0000 Subject: [PATCH] [project @ 2001-05-04 14:56:53 by simonmar] - only read ~/.ghci if it is owned by the current user and isn't writable by anyone else. - Only read ./.ghci if both . and ./.ghci are owned by the current user and aren't writable by anyone else. I think this is sufficient: we don't need to check .. and ../.. etc. because "." always refers to the same directory while a process is running. - Don't load .so libraries in a package if that package is already linked with GHCi. This stops us re-linking libm, libreadline etc. - Allow packages to be loaded from within GHCi using :set -package NOTE: this will unload all modules currently loaded into the interpreter. I did this to be on the safe side - I think perhaps it isn't necessary, but I haven't thought it through fully yet. - fix CompManager.cmUnload in the process. It was wrong in several ways. MERGE WITH 5.00 --- ghc/compiler/compMan/CompManager.lhs | 18 ++-- ghc/compiler/ghci/InteractiveUI.hs | 149 +++++++++++++++++++++++----------- 2 files changed, 111 insertions(+), 56 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index a571fa7..7cc8a27 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -9,7 +9,7 @@ module CompManager ( cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String]) - cmUnload, -- :: CmState -> IO CmState + cmUnload, -- :: CmState -> DynFlags -> IO CmState cmSetContext, -- :: CmState -> String -> IO CmState @@ -326,15 +326,17 @@ cmInfo cmstate str -- Unload the compilation manager's state: everything it knows about the -- current collection of modules in the Home package. -cmUnload :: CmState -> IO CmState -cmUnload state +cmUnload :: CmState -> DynFlags -> IO CmState +cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags = do -- Throw away the old home dir cache emptyHomeDirCache - -- Throw away the HIT and the HST - return state{ hst=new_hst, hit=new_hit, ui=emptyUI } - where - CmState{ hst=hst, hit=hit } = state - (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit) + + -- Unload everything the linker knows about + new_pls <- CmLink.unload mode dflags [] pls + + -- Start with a fresh CmState, but keep the PersistentCompilerState + new_state <- cmInit mode + return new_state{ pcs=pcs, pls=new_pls } ----------------------------------------------------------------------------- -- The real business of the compilation manager: given a system state and diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index be216e6..fd5a9db 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.64 2001/04/26 11:38:53 qrczak Exp $ +-- $Id: InteractiveUI.hs,v 1.65 2001/05/04 14:56:53 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -20,6 +20,7 @@ import DriverFlags import DriverState import DriverUtil import Linker +import Finder ( flushPackageCache ) import Util import Name ( Name ) import Outputable @@ -27,6 +28,7 @@ import CmdLineOpts ( DynFlag(..), dopt_unset ) import Panic ( GhcException(..) ) import Config +import Posix import Exception import Dynamic #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -115,7 +117,7 @@ interactiveUI cmstate mod cmdline_libs = do -- link in the available packages pkgs <- getPackageInfo initLinker - linkPackages cmdline_libs (reverse pkgs) + linkPackages cmdline_libs pkgs (cmstate, ok, mods) <- case mod of @@ -148,23 +150,31 @@ interactiveUI cmstate mod cmdline_libs = do runGHCi :: GHCi () runGHCi = do - -- read in ./.ghci - dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode)) - case dot_ghci of - Left e -> return () - Right hdl -> fileLoop hdl False + -- Read in ./.ghci. + let file = "./.ghci" + exists <- io (doesFileExist file) + when exists $ do + dir_ok <- io (checkPerms ".") + file_ok <- io (checkPerms file) + when (dir_ok && file_ok) $ do + either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False - -- read in ~/.ghci - home <- io (IO.try (getEnv "HOME")) - case home of - Left e -> return () - Right dir -> do + -- Read in $HOME/.ghci + either_dir <- io (IO.try (getEnv "HOME")) + case either_dir of + Left e -> return () + Right dir -> do cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode)) - case dot_ghci of - Left e -> return () - Right hdl -> fileLoop hdl False + when (dir /= cwd) $ do + let file = dir ++ "/.ghci" + ok <- io (checkPerms file) + either_hdl <- io (IO.try (openFile file ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False -- read commands from stdin #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -177,6 +187,28 @@ runGHCi = do io $ do putStrLn "Leaving GHCi." +-- NOTE: We only read .ghci files if they are owned by the current user, +-- and aren't world writable. Otherwise, we could be accidentally +-- running code planted by a malicious third party. + +checkPerms :: String -> IO Bool +checkPerms name = + handle (\_ -> return False) $ do + st <- getFileStatus name + me <- getRealUserID + if fileOwner st /= me then do + putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!" + return False + else do + let mode = fileMode st + if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) + || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) + then do + putStrLn $ "*** WARNING: " ++ name ++ + " is writable by someone else, IGNORING!" + return False + else return True + fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl prompt = do st <- getGHCiState @@ -380,7 +412,8 @@ loadModule path = timeIt (loadModule' path) loadModule' path = do state <- getGHCiState - cmstate1 <- io (cmUnload (cmstate state)) + dflags <- io (getDynFlags) + cmstate1 <- io (cmUnload (cmstate state) dflags) io (revertCAFs) -- always revert CAFs on load. (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path) let new_state = state{ cmstate = cmstate2, @@ -453,32 +486,31 @@ setOptions "" )) setOptions str = do -- first, deal with the GHCi opts (+s, +t, etc.) - let opts = words str - (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partition isPlus rest1 - - if (not (null rest2)) - then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'")) - else do - - mapM setOpt plus_opts - - -- now, the GHC flags - io (do -- first, static flags - leftovers <- processArgs static_flags minus_opts [] - - -- then, dynamic flags - dyn_flags <- readIORef v_InitDynFlags - writeIORef v_DynFlags dyn_flags - leftovers <- processArgs dynamic_flags leftovers [] - dyn_flags <- readIORef v_DynFlags - writeIORef v_InitDynFlags dyn_flags - - if (not (null leftovers)) - then throwDyn (CmdLineError ("unrecognised flags: " ++ + let (plus_opts, minus_opts) = partition isPlus (words str) + mapM setOpt plus_opts + + -- now, the GHC flags + pkgs_before <- io (readIORef v_Packages) + leftovers <- io (processArgs static_flags minus_opts []) + pkgs_after <- io (readIORef v_Packages) + + -- update things if the users wants more packages + when (pkgs_before /= pkgs_after) $ + newPackages (pkgs_after \\ pkgs_before) + + -- then, dynamic flags + io $ do + dyn_flags <- readIORef v_InitDynFlags + writeIORef v_DynFlags dyn_flags + leftovers <- processArgs dynamic_flags leftovers [] + dyn_flags <- readIORef v_DynFlags + writeIORef v_InitDynFlags dyn_flags + + if (not (null leftovers)) + then throwDyn (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) - else return () - ) + else return () + unsetOptions :: String -> GHCi () unsetOptions str @@ -525,6 +557,19 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" +newPackages new_pkgs = do + state <- getGHCiState + dflags <- io (getDynFlags) + cmstate1 <- io (cmUnload (cmstate state) dflags) + setGHCiState state{ cmstate = cmstate1, target = Nothing } + + io $ do + pkgs <- getPackageInfo + flushPackageCache pkgs + + new_pkg_info <- getPackageDetails new_pkgs + mapM_ (linkPackage False) (reverse new_pkg_info) + ----------------------------------------------------------------------------- -- GHCi monad @@ -602,9 +647,12 @@ showLS (Right nm) = "(dynamic) " ++ nm linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO () linkPackages cmdline_lib_specs pkgs - = do mapM_ linkPackage pkgs + = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ] mapM_ preloadLib cmdline_lib_specs where + -- packages that are already linked into GHCi + loaded = [ "concurrent", "posix", "text", "util" ] + preloadLib lib_spec = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of @@ -626,9 +674,9 @@ linkPackages cmdline_lib_specs pkgs croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.") -linkPackage :: PackageConfig -> IO () +linkPackage :: Bool -> PackageConfig -> IO () -- ignore rts and gmp for now (ToDo; better?) -linkPackage pkg +linkPackage loaded_in_ghci pkg | name pkg `elem` ["rts", "gmp"] = return () | otherwise @@ -638,8 +686,13 @@ linkPackage pkg let dirs = library_dirs pkg let objs = hs_libraries pkg ++ extra_libraries pkg classifieds <- mapM (locateOneObj dirs) objs - let sos_first = filter isRight classifieds - ++ filter (not.isRight) classifieds + + -- Don't load the .so libs if this is a package GHCi is already + -- linked against, because we'll already have the .so linked in. + let (so_libs, obj_libs) = partition isRight classifieds + let sos_first | loaded_in_ghci = obj_libs + | otherwise = so_libs ++ obj_libs + mapM loadClassified sos_first putStr "linking ... " resolveObjs -- 1.7.10.4