Commit 9279efc8 authored by dterei's avatar dterei
Browse files

SafeHaskell: Fix trust check for when safe module imports

trustworthy module in the same package.
parent feb45a49
......@@ -169,7 +169,8 @@ deSugar hsc_env
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo
mg_vect_info = noVectInfo,
mg_trust_pkg = imp_trust_own_pkg imports
}
; return (msgs, Just mod_guts)
}}}
......
......@@ -389,8 +389,9 @@ instance Binary ModIface where
mi_rules = rules,
mi_orphan_hash = orphan_hash,
mi_vect_info = vect_info,
mi_hpc = hpc_info,
mi_trust = trust }) = do
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg }) = do
put_ bh mod
put_ bh is_boot
put_ bh iface_hash
......@@ -412,6 +413,7 @@ instance Binary ModIface where
put_ bh vect_info
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
get bh = do
mod_name <- get bh
......@@ -435,6 +437,7 @@ instance Binary ModIface where
vect_info <- get bh
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
......@@ -458,6 +461,7 @@ instance Binary ModIface where
mi_vect_info = vect_info,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
......
......@@ -669,6 +669,7 @@ pprModIface iface
, pprVectInfo (mi_vect_info iface)
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
]
where
pp_boot | mi_boot iface = ptext (sLit "[boot]")
......@@ -756,6 +757,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
pprTrustInfo :: IfaceTrustInfo -> SDoc
pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust
pprTrustPkg :: Bool -> SDoc
pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg
instance Outputable Warnings where
ppr = pprWarns
......
......@@ -123,18 +123,19 @@ mkIface :: HscEnv
-- to write it
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info }
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info,
mg_trust_pkg = self_trust }
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env
fix_env warns hpc_info dir_imp_mods mod_details
this_mod is_boot used_names deps rdr_env fix_env
warns hpc_info dir_imp_mods self_trust mod_details
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
......@@ -159,12 +160,15 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
let hpc_info = emptyHpcInfo other_hpc_info
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names deps rdr_env
fix_env warns hpc_info (imp_mods imports) mod_details
fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) mod_details
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
TcGblEnv{ tcg_mod = mod,
......@@ -182,30 +186,31 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- add in safe haskell 'package needs to be safe' bool
sorted_pkgs = sortBy stablePackageIdCmp pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
sorted_pkgs = sortBy stablePackageIdCmp pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = dep_pkgs',
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
-- sort to get into canonical order
-- NB. remember to use lexicographic ordering
-- sort to get into canonical order
-- NB. remember to use lexicographic ordering
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods
-> ImportedMods -> Bool
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods
dir_imp_mods pkg_trust_req
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
......@@ -271,6 +276,7 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_hash_fn = deliberatelyOmitted "hash_fn",
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
......
......@@ -873,9 +873,9 @@ checkSafeImports dflags hsc_env tcg_env
-- that their package is trusted. For trustworthy modules,
-- modules in the home package are trusted but otherwise
-- we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Module -> Bool
packageTrusted Sf_Safe _ = True
packageTrusted _ m
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted Sf_Safe False _ = True
packageTrusted _ _ m
| isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
......@@ -894,11 +894,12 @@ checkSafeImports dflags hsc_env tcg_env
-- got iface, check trust
Just iface' -> do
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
-- check module is trusted
safeM = trust `elem` [Sf_Safe, Sf_Trustworthy,
Sf_TrustworthyWithSafeLanguage]
-- check package is trusted
safeP = packageTrusted trust m
safeP = packageTrusted trust trust_own_pkg m
if safeM && safeP
then return Nothing
else return $ Just $ if safeM
......@@ -1393,7 +1394,8 @@ mkModGuts mod binds = ModGuts {
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo,
mg_inst_env = emptyInstEnv,
mg_fam_inst_env = emptyFamInstEnv
mg_fam_inst_env = emptyFamInstEnv,
mg_trust_pkg = False
}
\end{code}
......
......@@ -687,8 +687,15 @@ data ModIface
-- The 'OccName' is the parent of the name, if it has one.
mi_hpc :: !AnyHpcUsage,
-- ^ True if this program uses Hpc at any point in the program.
mi_trust :: !IfaceTrustInfo
mi_trust :: !IfaceTrustInfo,
-- ^ Safe Haskell Trust information for this module.
mi_trust_pkg :: !Bool
-- ^ Do we require the package this module resides in be trusted
-- to trust this module? This is used for the situation where a
-- module is Safe (so doesn't require the package be trusted
-- itself) but imports some trustworthy modules from its own
-- package (which does require its own package be trusted).
-- See Note [RnNames . Trust Own Package]
}
-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
......@@ -767,9 +774,12 @@ data ModGuts
mg_inst_env :: InstEnv,
-- ^ Class instance environment from /home-package/ modules (including
-- this one); c.f. 'tcg_inst_env'
mg_fam_inst_env :: FamInstEnv
mg_fam_inst_env :: FamInstEnv,
-- ^ Type-family instance enviroment for /home-package/ modules
-- (including this one); c.f. 'tcg_fam_inst_env'
mg_trust_pkg :: Bool
-- ^ Do we need to trust our own package for Safe Haskell?
-- See Note [RnNames . Trust Own Package]
}
-- The ModGuts takes on several slightly different forms:
......@@ -862,7 +872,8 @@ emptyModIface mod
mi_fix_fn = emptyIfaceFixCache,
mi_hash_fn = emptyIfaceHashCache,
mi_hpc = False,
mi_trust = noIfaceTrustInfo
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False
}
\end{code}
......
......@@ -171,6 +171,8 @@ rnImportDecl this_mod implicit_prelude
orph_iface = mi_orphan iface
has_finsts = mi_finsts iface
deps = mi_deps iface
trust = getSafeMode $ mi_trust iface
trust_pkg = mi_trust_pkg iface
filtered_exports = filter not_this_mod (mi_exports iface)
not_this_mod (mod,_) = mod /= this_mod
......@@ -220,7 +222,13 @@ rnImportDecl this_mod implicit_prelude
pkg = modulePackageId (mi_module iface)
(dependent_mods, dependent_pkgs)
-- Does this import mean we now require our own pkg
-- to be trusted? See Note [Trust Own Package]
ptrust = trust == Sf_Trustworthy
|| trust == Sf_TrustworthyWithSafeLanguage
|| trust_pkg
(dependent_mods, dependent_pkgs, pkg_trust_req)
| pkg == thisPackage dflags =
-- Imported module is from the home package
-- Take its dependent modules and add imp_mod itself
......@@ -233,14 +241,15 @@ rnImportDecl this_mod implicit_prelude
-- know if any of them depended on CM.hi-boot, in
-- which case we should do the hi-boot consistency
-- check. See LoadIface.loadHiBootInterface
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps, ptrust)
| otherwise =
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) )
([], (pkg, False) : dep_pkgs deps)
ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps))
, ppr pkg <+> ppr (dep_pkgs deps) )
([], (pkg, False) : dep_pkgs deps, False)
-- True <=> import M ()
import_all = case imp_details of
......@@ -261,10 +270,14 @@ rnImportDecl this_mod implicit_prelude
-- Add in the imported modules trusted package
-- requirements. ONLY do this though if we import the
-- module as a safe import.
-- see Note [Trust Transitive Property]
-- See Note [Tracking Trust Transitively]
-- and Note [Trust Transitive Property]
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else []
else [],
-- Do we require our own pkg to be trusted?
-- See Note [Trust Own Package]
imp_trust_own_pkg = pkg_trust_req
}
-- Complain if we import a deprecated module
......
......@@ -338,7 +338,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
mg_foreign = NoStubs,
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo
mg_vect_info = noVectInfo,
mg_trust_pkg = False
} } ;
tcCoreDump mod_guts ;
......
......@@ -623,12 +623,19 @@ data ImportAvails
-- where True for the bool indicates the package is required to be
-- trusted is the more logical design, doing so complicates a lot
-- of code not concerned with Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
imp_orphs :: [Module],
imp_trust_own_pkg :: Bool,
-- ^ Do we require that our own package is trusted?
-- This is to handle efficiently the case where a Safe module imports
-- a Trustworthy module that resides in the same package as it.
-- See Note [RnNames . Trust Own Package]
imp_orphs :: [Module],
-- ^ Orphan modules below us in the import tree (and maybe including
-- us for imported modules)
imp_finsts :: [Module]
imp_finsts :: [Module]
-- ^ Family instance modules below us in the import tree (and maybe
-- including us for imported modules)
}
......@@ -640,34 +647,41 @@ mkModDeps deps = foldl add emptyUFM deps
add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_trust_pkgs = [],
imp_orphs = [],
imp_finsts = [] }
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_trust_pkgs = [],
imp_trust_own_pkg = False,
imp_orphs = [],
imp_finsts = [] }
-- | Union two ImportAvails
--
-- This function is a key part of Import handling, basically
-- for each import we create a seperate ImportAvails structure
-- and then union them all together with this function.
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
(ImportAvails { imp_mods = mods1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_trust_pkgs = tpkgs1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1,
imp_orphs = orphs1, imp_finsts = finsts1 })
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_trust_pkgs = tpkgs2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2,
imp_trust_own_pkg = tself1 || tself2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
where
plus_mod_dep (m1, boot1) (m2, boot2)
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-- Check mod-names match
(m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-- Check mod-names match
(m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
\end{code}
%************************************************************************
......
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