Commit 93e8ae26 authored by dterei's avatar dterei
Browse files

Fix :issafe command (#7172).

parent 2b5b178f
...@@ -91,6 +91,7 @@ module GHC ( ...@@ -91,6 +91,7 @@ module GHC (
findModule, lookupModule, findModule, lookupModule,
#ifdef GHCI #ifdef GHCI
isModuleTrusted, isModuleTrusted,
moduleTrustReqs,
setContext, getContext, setContext, getContext,
getNamesInScope, getNamesInScope,
getRdrNamesInScope, getRdrNamesInScope,
...@@ -1335,6 +1336,11 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool ...@@ -1335,6 +1336,11 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env -> isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
-- | EXPERIMENTAL: DO NOT USE. -- | EXPERIMENTAL: DO NOT USE.
-- --
-- Set the monad GHCi lifts user statements into. -- Set the monad GHCi lifts user statements into.
......
...@@ -61,6 +61,7 @@ module HscMain ...@@ -61,6 +61,7 @@ module HscMain
, hscTcRcLookupName , hscTcRcLookupName
, hscTcRnGetInfo , hscTcRnGetInfo
, hscCheckSafe , hscCheckSafe
, hscGetSafe
#ifdef GHCI #ifdef GHCI
, hscIsGHCiMonad , hscIsGHCiMonad
, hscGetModuleInterface , hscGetModuleInterface
...@@ -1023,6 +1024,21 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do ...@@ -1023,6 +1024,21 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
errs <- getWarnings errs <- getWarnings
return $ isEmptyBag errs return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId])
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
good <- isEmptyBag `fmap` getWarnings
clearWarnings -- don't want them printed...
let pkgs' | Just p <- self = p:pkgs
| otherwise = pkgs
return (good, pkgs')
-- | Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
hscCheckSafe' dflags m l = do hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l (tw, pkgs) <- isModSafe m l
...@@ -1031,10 +1047,6 @@ hscCheckSafe' dflags m l = do ...@@ -1031,10 +1047,6 @@ hscCheckSafe' dflags m l = do
True | isHomePkg m -> return (Nothing, pkgs) True | isHomePkg m -> return (Nothing, pkgs)
| otherwise -> return (Just $ modulePackageId m, pkgs) | otherwise -> return (Just $ modulePackageId m, pkgs)
where where
-- Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the
-- modules own package be trusted and a list of other packages required to
-- be trusted (these later ones haven't been checked)
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
isModSafe m l = do isModSafe m l = do
iface <- lookup' m iface <- lookup' m
...@@ -1080,6 +1092,8 @@ hscCheckSafe' dflags m l = do ...@@ -1080,6 +1092,8 @@ hscCheckSafe' dflags m l = do
-- trustworthy modules, modules in the home package are trusted but -- trustworthy modules, modules in the home package are trusted but
-- otherwise we check the package trust flag. -- otherwise we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
packageTrusted _ _ _ packageTrusted _ _ _
| not (packageTrustOn dflags) = True | not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True packageTrusted Sf_Safe False _ = True
......
...@@ -33,7 +33,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), ...@@ -33,7 +33,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
handleSourceError ) handleSourceError )
import HsImpExp import HsImpExp
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs, hsc_IC, import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName ) setInteractivePrintName )
import Module import Module
import Name import Name
...@@ -1487,48 +1487,34 @@ isSafeModule m = do ...@@ -1487,48 +1487,34 @@ isSafeModule m = do
(ghcError $ CmdLineError $ "can't load interface file for module: " ++ (ghcError $ CmdLineError $ "can't load interface file for module: " ++
(GHC.moduleNameString $ GHC.moduleName m)) (GHC.moduleNameString $ GHC.moduleName m))
let iface' = fromJust iface (msafe, pkgs) <- GHC.moduleTrustReqs m
let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
trust = showPpr dflags $ getSafeMode $ GHC.mi_trust iface' pkg = if packageTrusted dflags m then "trusted" else "untrusted"
pkgT = packageTrusted dflags m (good, bad) = tallyPkgs dflags pkgs
pkg = if pkgT then "trusted" else "untrusted"
(good', bad') = tallyPkgs dflags $
map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface'
(good, bad) = case GHC.mi_trust_pkg iface' of
True | pkgT -> (modulePackageId m:good', bad')
True -> (good', modulePackageId m:bad')
False -> (good', bad')
-- print info to user...
liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
liftIO $ putStrLn $ "Package Trust: " liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
++ (if packageTrustOn dflags then "On" else "Off") when (not $ null good)
when (packageTrustOn dflags && not (null good))
(liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
(intercalate ", " $ map packageIdString good)) (intercalate ", " $ map packageIdString good))
case msafe && null bad of
case goodTrust (getSafeMode $ GHC.mi_trust iface') of True -> liftIO $ putStrLn $ mname ++ " is trusted!"
True | (null bad || not (packageTrustOn dflags)) -> False -> do
liftIO $ putStrLn $ mname ++ " is trusted!" when (not $ null bad)
(liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
True -> do ++ (intercalate ", " $ map packageIdString bad))
liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
++ (intercalate ", " $ map packageIdString bad)
liftIO $ putStrLn $ mname ++ " is NOT trusted!" liftIO $ putStrLn $ mname ++ " is NOT trusted!"
False -> liftIO $ putStrLn $ mname ++ " is NOT trusted!"
where where
goodTrust t = t `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
mname = GHC.moduleNameString $ GHC.moduleName m mname = GHC.moduleNameString $ GHC.moduleName m
packageTrusted dflags md packageTrusted dflags md
| thisPackage dflags == modulePackageId md = True | thisPackage dflags == modulePackageId md = True
| otherwise = trusted $ getPackageDetails (pkgState dflags) | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)
(modulePackageId md)
tallyPkgs dflags deps = partition part deps tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
| otherwise = partition part deps
where state = pkgState dflags where state = pkgState dflags
part pkg = trusted $ getPackageDetails state pkg part pkg = trusted $ getPackageDetails state pkg
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment