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 ...@@ -637,7 +637,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_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 if pkg /= this_pkg
then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
......
...@@ -717,12 +717,14 @@ pprDeps :: Dependencies -> SDoc ...@@ -717,12 +717,14 @@ pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
dep_finsts = finsts }) dep_finsts = finsts })
= vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods), = 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 "orphans:") <+> fsep (map ppr orphs),
ptext (sLit "family instance modules:") <+> fsep (map ppr finsts) ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
] ]
where where
ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot 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 True = text "[boot]"
ppr_boot False = empty ppr_boot False = empty
......
...@@ -185,8 +185,13 @@ mkDependencies ...@@ -185,8 +185,13 @@ mkDependencies
pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
| otherwise = 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, 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_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
-- sort to get into canonical order -- sort to get into canonical order
...@@ -598,7 +603,7 @@ getOrphanHashes hsc_env mods = do ...@@ -598,7 +603,7 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies sortDependencies :: Dependencies -> Dependencies
sortDependencies d sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods 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_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) } dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
\end{code} \end{code}
...@@ -1182,7 +1187,7 @@ checkDependencies hsc_env summary iface ...@@ -1182,7 +1187,7 @@ checkDependencies hsc_env summary iface
else else
return upToDate return upToDate
| otherwise | otherwise
-> if pkg `notElem` prev_dep_pkgs -> if pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $ then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <> text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <> text " is from package " <> quotes (ppr pkg) <>
......
...@@ -299,7 +299,7 @@ link' dflags batch_attempt_linking hpt ...@@ -299,7 +299,7 @@ link' dflags batch_attempt_linking hpt
home_mod_infos = eltsUFM hpt home_mod_infos = eltsUFM hpt
-- the packages we depend on -- 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 -- the linkables to link
linkables = map (expectJust "link".hm_linkable) home_mod_infos linkables = map (expectJust "link".hm_linkable) home_mod_infos
......
...@@ -144,10 +144,9 @@ import UniqFM ( emptyUFM ) ...@@ -144,10 +144,9 @@ import UniqFM ( emptyUFM )
import UniqSupply ( initUs_ ) import UniqSupply ( initUs_ )
import Bag import Bag
import Exception import Exception
-- import MonadUtils
import Control.Monad import Control.Monad
-- import System.IO import Data.Maybe ( catMaybes )
import Data.IORef import Data.IORef
\end{code} \end{code}
#include "HsVersions.h" #include "HsVersions.h"
...@@ -821,12 +820,18 @@ checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv ...@@ -821,12 +820,18 @@ checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags hsc_env tcg_env checkSafeImports dflags hsc_env tcg_env
= do = do
imps <- mapM condense imports' imps <- mapM condense imports'
mapM_ checkSafe imps pkgs <- mapM checkSafe imps
return tcg_env 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 where
imp_info = tcg_imports tcg_env -- ImportAvails imp_info = tcg_imports tcg_env -- ImportAvails
imports = imp_mods imp_info -- ImportedMods imports = imp_mods imp_info -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!" condense (_, []) = panic "HscMain.condense: Pattern match failure!"
...@@ -840,7 +845,6 @@ checkSafeImports dflags hsc_env tcg_env ...@@ -840,7 +845,6 @@ checkSafeImports dflags hsc_env tcg_env
= liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1 = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1
(text "Module" <+> ppr m1 <+> (text $ "is imported" (text "Module" <+> ppr m1 <+> (text $ "is imported"
++ " both as a safe and unsafe import!")) ++ " both as a safe and unsafe import!"))
| otherwise | otherwise
= return v1 = return v1
...@@ -852,15 +856,19 @@ checkSafeImports dflags hsc_env tcg_env ...@@ -852,15 +856,19 @@ checkSafeImports dflags hsc_env tcg_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
return iface return iface
isHomePkg :: Module -> Bool
isHomePkg m
| thisPackage dflags == modulePackageId m = True
| otherwise = False
-- | Check the package a module resides in is trusted. -- | Check the package a module resides in is trusted.
-- Modules in the home package are trusted but otherwise -- Modules in the home package are trusted but otherwise
-- we check the packages trust flag. -- we check the packages trust flag.
packageTrusted :: Module -> Bool packageTrusted :: Module -> Bool
packageTrusted m packageTrusted m
| thisPackage dflags == modulePackageId m = True | isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags) | otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m) (modulePackageId m)
-- Is a module trusted? Return Nothing if True, or a String -- Is a module trusted? Return Nothing if True, or a String
-- if it isn't, containing the reason it isn't -- if it isn't, containing the reason it isn't
isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc) isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc)
...@@ -887,16 +895,34 @@ checkSafeImports dflags hsc_env tcg_env ...@@ -887,16 +895,34 @@ checkSafeImports dflags hsc_env tcg_env
text ") the module resides in isn't trusted." text ") the module resides in isn't trusted."
else text "The module itself isn't safe." else text "The module itself isn't safe."
checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc () -- Here we check the transitive package trust requirements are OK still.
checkSafe (_, _, False) = return () 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 checkSafe (m, l, True ) = do
module_safe <- isModSafe m l module_safe <- isModSafe m l
case module_safe of case module_safe of
Nothing -> return () Nothing -> return pkg
Just s -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l 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 <+> s
where pkg | isHomePkg m = Nothing
| otherwise = Just (modulePackageId m)
-------------------------------------------------------------- --------------------------------------------------------------
-- Simplifiers -- Simplifiers
-------------------------------------------------------------- --------------------------------------------------------------
......
...@@ -1435,7 +1435,7 @@ type IsBootInterface = Bool ...@@ -1435,7 +1435,7 @@ type IsBootInterface = Bool
data Dependencies data Dependencies
= Deps { dep_mods :: [(ModuleName, IsBootInterface)] = Deps { dep_mods :: [(ModuleName, IsBootInterface)]
-- ^ Home-package module dependencies -- ^ Home-package module dependencies
, dep_pkgs :: [PackageId] , dep_pkgs :: [(PackageId, Bool)]
-- ^ External package dependencies -- ^ External package dependencies
, dep_orphs :: [Module] , dep_orphs :: [Module]
-- ^ Orphan modules (whether home or external pkg), -- ^ Orphan modules (whether home or external pkg),
......
...@@ -366,8 +366,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ...@@ -366,8 +366,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
cg_tycons = alg_tycons, cg_tycons = alg_tycons,
cg_binds = all_tidy_binds, cg_binds = all_tidy_binds,
cg_foreign = foreign_stubs, cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps, cg_dep_pkgs = map fst $ dep_pkgs deps,
cg_hpc_info = hpc_info, cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks }, cg_modBreaks = modBreaks },
ModDetails { md_types = tidy_type_env, ModDetails { md_types = tidy_type_env,
......
...@@ -53,6 +53,34 @@ import qualified Data.Map as Map ...@@ -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} \begin{code}
rnImports :: [LImportDecl RdrName] rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage)
...@@ -211,8 +239,8 @@ rnImportDecl this_mod implicit_prelude ...@@ -211,8 +239,8 @@ rnImportDecl this_mod implicit_prelude
-- Imported module is from another package -- Imported module is from another package
-- Dump the dependent modules -- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages -- Add the package imp_mod comes from to the dependent packages
ASSERT2( not (pkg `elem` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) ) ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) )
([], pkg : dep_pkgs deps) ([], (pkg, False) : dep_pkgs deps)
-- True <=> import M () -- True <=> import M ()
import_all = case imp_details of import_all = case imp_details of
...@@ -225,11 +253,18 @@ rnImportDecl this_mod implicit_prelude ...@@ -225,11 +253,18 @@ rnImportDecl this_mod implicit_prelude
|| (implicit_prelude && safeImplicitImpsReq dflags) || (implicit_prelude && safeImplicitImpsReq dflags)
imports = ImportAvails { imports = ImportAvails {
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')], imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')],
imp_orphs = orphans, imp_orphs = orphans,
imp_finsts = finsts, imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods, imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = dependent_pkgs 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 -- Complain if we import a deprecated module
......
...@@ -613,6 +613,16 @@ data ImportAvails ...@@ -613,6 +613,16 @@ data ImportAvails
-- ^ Packages needed by the module being compiled, whether directly, -- ^ Packages needed by the module being compiled, whether directly,
-- or via other modules in this package, or via modules imported -- or via other modules in this package, or via modules imported
-- from other packages. -- 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], imp_orphs :: [Module],
-- ^ Orphan modules below us in the import tree (and maybe including -- ^ Orphan modules below us in the import tree (and maybe including
...@@ -630,25 +640,29 @@ mkModDeps deps = foldl add emptyUFM deps ...@@ -630,25 +640,29 @@ mkModDeps deps = foldl add emptyUFM deps
add env elt@(m,_) = addToUFM env m elt add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM, imp_dep_mods = emptyUFM,
imp_dep_pkgs = [], imp_dep_pkgs = [],
imp_orphs = [], imp_trust_pkgs = [],
imp_finsts = [] } imp_orphs = [],
imp_finsts = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails plusImportAvails
(ImportAvails { imp_mods = mods1, (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 }) imp_orphs = orphs1, imp_finsts = finsts1 })
(ImportAvails { imp_mods = mods2, (ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_trust_pkgs = tpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 }) imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2, imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2,
imp_finsts = finsts1 `unionLists` finsts2 } imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
where where
plus_mod_dep (m1, boot1) (m2, boot2) plus_mod_dep (m1, boot1) (m2, boot2)
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr 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