SafeHaskell: Transitively check safety when compiling a module.
authorDavid Terei <davidterei@gmail.com>
Sun, 12 Jun 2011 03:20:32 +0000 (20:20 -0700)
committerDavid Terei <davidterei@gmail.com>
Sat, 18 Jun 2011 03:40:34 +0000 (20:40 -0700)
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.

compiler/ghci/Linker.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/DriverPipeline.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/rename/RnNames.lhs
compiler/typecheck/TcRnTypes.lhs

index ef349eb..90ec0b3 100644 (file)
@@ -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)
index 219ab6a..daa0bb0 100644 (file)
@@ -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
 
index e6d7bea..2ec14e4 100644 (file)
@@ -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) <>
index 4eca870..c7bc823 100644 (file)
@@ -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
index 1ffed43..46d46fb 100644 (file)
@@ -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
 --------------------------------------------------------------
index 5ff7107..1edce70 100644 (file)
@@ -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),
index b3f1a06..c3be64b 100644 (file)
@@ -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,
index d2ad9af..d841ad8 100644 (file)
@@ -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
index 78b2f32..46a322a 100644 (file)
@@ -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) )