Commit 77d85a4a authored by dterei's avatar dterei

SafeHaskell: Transitively check safety when compiling a module.

While we previously checked the safety of safe imported modules we
didn't do this check transitively. This can be a problem when we depend
on a trustworthy module in a package that is no longer trusted, so we
should fail compilation. We already stored in an interface file the
transitive list of packages a module depends on. Now we extend that list
to include a flag saying if we depend on that package being trusted as
well.
parent 8ebe525b
......@@ -637,7 +637,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps
--
if pkg /= this_pkg
then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
......
......@@ -717,12 +717,14 @@ pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
dep_finsts = finsts })
= vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
ptext (sLit "package dependencies:") <+> fsep (map ppr pkgs),
ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs),
ptext (sLit "orphans:") <+> fsep (map ppr orphs),
ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
]
where
ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
ppr_pkg (pkg,trust_req) = ppr pkg <>
(if trust_req then text "*" else empty)
ppr_boot True = text "[boot]"
ppr_boot False = empty
......
......@@ -185,8 +185,13 @@ mkDependencies
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
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = sortBy stablePackageIdCmp pkgs,
dep_pkgs = dep_pkgs',
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
-- sort to get into canonical order
......@@ -598,7 +603,7 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
dep_pkgs = sortBy stablePackageIdCmp (dep_pkgs d),
dep_pkgs = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
\end{code}
......@@ -1182,7 +1187,7 @@ checkDependencies hsc_env summary iface
else
return upToDate
| otherwise
-> if pkg `notElem` prev_dep_pkgs
-> if pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
......
......@@ -299,7 +299,7 @@ link' dflags batch_attempt_linking hpt
home_mod_infos = eltsUFM hpt
-- the packages we depend on
pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
-- the linkables to link
linkables = map (expectJust "link".hm_linkable) home_mod_infos
......
......@@ -144,10 +144,9 @@ import UniqFM ( emptyUFM )
import UniqSupply ( initUs_ )
import Bag
import Exception
-- import MonadUtils
import Control.Monad
-- import System.IO
import Data.Maybe ( catMaybes )
import Data.IORef
\end{code}
#include "HsVersions.h"
......@@ -821,12 +820,18 @@ checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags hsc_env tcg_env
= do
imps <- mapM condense imports'
mapM_ checkSafe imps
return tcg_env
pkgs <- mapM checkSafe imps
pkgTransitiveOK pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
where
imp_info = tcg_imports tcg_env -- ImportAvails
imports = imp_mods imp_info -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
......@@ -840,7 +845,6 @@ checkSafeImports dflags hsc_env tcg_env
= liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1
(text "Module" <+> ppr m1 <+> (text $ "is imported"
++ " both as a safe and unsafe import!"))
| otherwise
= return v1
......@@ -852,15 +856,19 @@ checkSafeImports dflags hsc_env tcg_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
return iface
isHomePkg :: Module -> Bool
isHomePkg m
| thisPackage dflags == modulePackageId m = True
| otherwise = False
-- | Check the package a module resides in is trusted.
-- Modules in the home package are trusted but otherwise
-- we check the packages trust flag.
packageTrusted :: Module -> Bool
packageTrusted m
| thisPackage dflags == modulePackageId m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
| isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
-- Is a module trusted? Return Nothing if True, or a String
-- if it isn't, containing the reason it isn't
isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc)
......@@ -887,16 +895,34 @@ checkSafeImports dflags hsc_env tcg_env
text ") the module resides in isn't trusted."
else text "The module itself isn't safe."
checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc ()
checkSafe (_, _, False) = return ()
-- Here we check the transitive package trust requirements are OK still.
pkgTransitiveOK :: [PackageId] -> Hsc ()
pkgTransitiveOK pkgs = do
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required"
<> text " to be trusted but it isn't!"
checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = do
module_safe <- isModSafe m l
case module_safe of
Nothing -> return ()
Nothing -> return pkg
Just s -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
$ text ppr m <+> text "can't be safely imported!"
$ ppr m <+> text "can't be safely imported!"
<+> s
where pkg | isHomePkg m = Nothing
| otherwise = Just (modulePackageId m)
--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------
......
......@@ -1435,7 +1435,7 @@ type IsBootInterface = Bool
data Dependencies
= Deps { dep_mods :: [(ModuleName, IsBootInterface)]
-- ^ Home-package module dependencies
, dep_pkgs :: [PackageId]
, dep_pkgs :: [(PackageId, Bool)]
-- ^ External package dependencies
, dep_orphs :: [Module]
-- ^ Orphan modules (whether home or external pkg),
......
......@@ -366,8 +366,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
cg_tycons = alg_tycons,
cg_binds = all_tidy_binds,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
cg_hpc_info = hpc_info,
cg_dep_pkgs = map fst $ dep_pkgs deps,
cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks },
ModDetails { md_types = tidy_type_env,
......
......@@ -53,6 +53,34 @@ import qualified Data.Map as Map
%* *
%************************************************************************
Note [Trust Transitive Property]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
So there is an interesting design question in regards to transitive trust
checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
of modules and packages, some packages it requires to be trusted as its using
-XTrustworthy modules from them. Now if I have a module A that doesn't use safe
haskell at all and simply imports B, should A inherit all the the trust
requirements from B? Should A now also require that a package p is trusted since
B required it?
We currently say no but I saying yes also makes sense. The difference is, if a
module M that doesn't use SafeHaskell imports a module N that does, should all
the trusted package requirements be dropped since M didn't declare that it cares
about Safe Haskell (so -XSafe is more strongly associated with the module doing
the importing) or should it be done still since the author of the module N that
uses Safe Haskell said they cared (so -XSafe is more strongly associated with
the module that was compiled that used it).
Going with yes is a simpler semantics we think and harder for the user to stuff
up but it does mean that SafeHaskell will affect users who don't care about
SafeHaskell as they might grab a package from Cabal which uses safe haskell (say
network) and that packages imports -XTrustworthy modules from another package
(say bytestring), so requires that package is trusted. The user may now get
compilation errors in code that doesn't do anything with Safe Haskell simply
because they are using the network package. They will have to call 'ghc-pkg
trust network' to get everything working. Due to this invasive nature of going
with yes we have gone with no for now.
\begin{code}
rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage)
......@@ -211,8 +239,8 @@ rnImportDecl this_mod implicit_prelude
-- 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` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) )
([], pkg : dep_pkgs deps)
ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) )
([], (pkg, False) : dep_pkgs deps)
-- True <=> import M ()
import_all = case imp_details of
......@@ -225,11 +253,18 @@ rnImportDecl this_mod implicit_prelude
|| (implicit_prelude && safeImplicitImpsReq dflags)
imports = ImportAvails {
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')],
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = dependent_pkgs
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')],
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = map fst $ dependent_pkgs,
-- 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]
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else []
}
-- Complain if we import a deprecated module
......
......@@ -613,6 +613,16 @@ data ImportAvails
-- ^ Packages needed by the module being compiled, whether directly,
-- or via other modules in this package, or via modules imported
-- from other packages.
imp_trust_pkgs :: [PackageId],
-- ^ This is strictly a subset of imp_dep_pkgs and records the
-- packages the current module needs to trust for Safe Haskell
-- compilation to succeed. A package is required to be trusted if
-- we are dependent on a trustworthy module in that package.
-- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool)
-- 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.
imp_orphs :: [Module],
-- ^ Orphan modules below us in the import tree (and maybe including
......@@ -630,25 +640,29 @@ 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_orphs = [],
imp_finsts = [] }
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_trust_pkgs = [],
imp_orphs = [],
imp_finsts = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
(ImportAvails { imp_mods = mods1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_trust_pkgs = tpkgs1,
imp_orphs = orphs1, imp_finsts = finsts1 })
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_trust_pkgs = tpkgs2,
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_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_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) )
......
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