diff --git a/Stackage/Build.hs b/Stackage/Build.hs index e25d414a..1a9bbfb2 100644 --- a/Stackage/Build.hs +++ b/Stackage/Build.hs @@ -41,11 +41,11 @@ defaultBuildSettings = BuildSettings , excludedPackages = empty , testWorkerThreads = 4 , flags = Set.fromList $ words "blaze_html_0_5" + , allowedPackage = const $ Right () } build :: BuildSettings -> IO () build settings' = do - putStrLn "Creating a build plan" ii <- getInstallInfo settings' let root' = sandboxRoot settings' diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs index 37240db0..1c42245a 100644 --- a/Stackage/InstallInfo.hs +++ b/Stackage/InstallInfo.hs @@ -24,14 +24,19 @@ dropExcluded bs m0 = getInstallInfo :: BuildSettings -> IO InstallInfo getInstallInfo settings = do + putStrLn "Loading Haskell Platform" hp <- loadHaskellPlatform settings let allPackages' | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp) | otherwise = stablePackages settings allPackages = dropExcluded settings allPackages' let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp) + + putStrLn "Loading package database" pdb <- loadPackageDB settings totalCore allPackages - final <- narrowPackageDB pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages + + putStrLn "Narrowing package database" + final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages putStrLn "Printing build plan to build-plan.log" writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs index e65f56af..5619136f 100644 --- a/Stackage/LoadDatabase.hs +++ b/Stackage/LoadDatabase.hs @@ -71,12 +71,13 @@ loadPackageDB settings core deps = do _ -> case Tar.entryContent e of Tar.NormalFile bs _ -> do - let (deps', hasTests, buildTools') = parseDeps bs + let (deps', hasTests, buildTools', mgpd) = parseDeps bs return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo { piVersion = v , piDeps = deps' , piHasTests = hasTests , piBuildTools = buildTools' + , piGPD = mgpd } _ -> return pdb @@ -88,8 +89,8 @@ loadPackageDB settings core deps = do , mconcat $ map (go gpd . snd) $ condTestSuites gpd , mconcat $ map (go gpd . snd) $ condBenchmarks gpd ], not $ null $ condTestSuites gpd - , Set.fromList $ map depName $ allBuildInfo gpd) - _ -> (mempty, defaultHasTestSuites, Set.empty) + , Set.fromList $ map depName $ allBuildInfo gpd, Just gpd) + _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing) where allBuildInfo gpd = concat [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs index ac434956..cf344abb 100644 --- a/Stackage/NarrowDatabase.hs +++ b/Stackage/NarrowDatabase.hs @@ -1,17 +1,27 @@ module Stackage.NarrowDatabase where +import Control.Monad.Trans.Writer import qualified Data.Map as Map import qualified Data.Set as Set import Prelude hiding (pi) import Stackage.Types +import Stackage.Util +import System.Exit (exitFailure) -- | Narrow down the database to only the specified packages and all of -- their dependencies. -narrowPackageDB :: PackageDB +narrowPackageDB :: BuildSettings + -> PackageDB -> Set (PackageName, Maintainer) -> IO (Map PackageName BuildInfo) -narrowPackageDB (PackageDB pdb) = - loop Map.empty . Set.map (\(name, maintainer) -> ([], name, maintainer)) +narrowPackageDB settings (PackageDB pdb) packageSet = do + (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet + if Set.null errs + then return res + else do + putStrLn "Build plan requires some disallowed packages" + mapM_ putStrLn $ Set.toList errs + exitFailure where loop result toProcess = case Set.minView toProcess of @@ -29,6 +39,16 @@ narrowPackageDB (PackageDB pdb) = , biMaintainer = maintainer , biDeps = piDeps pi } result + case piGPD pi of + Nothing -> return () + Just gpd -> + case allowedPackage settings gpd of + Left msg -> tell $ Set.singleton $ concat + [ packageVersionString (p, piVersion pi) + , ": " + , msg + ] + Right () -> return () loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi addDep users result maintainer toProcess p = case Map.lookup p result of diff --git a/Stackage/Types.hs b/Stackage/Types.hs index 1879be2d..db959552 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -11,6 +11,7 @@ import Data.Version as X (Version) import Distribution.Package as X (PackageIdentifier (..), PackageName (..)) import Distribution.Version as X (VersionRange (..)) +import Distribution.PackageDescription (GenericPackageDescription) newtype PackageDB = PackageDB (Map PackageName PackageInfo) deriving (Show, Eq) @@ -29,6 +30,7 @@ data PackageInfo = PackageInfo , piDeps :: Map PackageName VersionRange , piHasTests :: Bool , piBuildTools :: Set PackageName + , piGPD :: Maybe GenericPackageDescription } deriving (Show, Eq) @@ -81,4 +83,11 @@ data BuildSettings = BuildSettings -- ^ How many threads to spawn for running test suites. , flags :: Set String -- ^ Compile flags which should be turned on. + , allowedPackage :: GenericPackageDescription -> Either String () + -- ^ Checks if a package is allowed into the distribution. By default, we + -- allow all packages in, though this could be used to filter out certain + -- untrusted packages, or packages with an unacceptable license. + -- + -- Returns a reason for stripping in Left, or Right if the package is + -- allowed. } diff --git a/Stackage/Util.hs b/Stackage/Util.hs index 5ab4148a..1cfd8919 100644 --- a/Stackage/Util.hs +++ b/Stackage/Util.hs @@ -8,7 +8,7 @@ import Data.List (stripPrefix) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Version (showVersion) -import Distribution.Text (simpleParse) +import Distribution.Text (simpleParse, display) import Distribution.Version (thisVersion) import Stackage.Types import System.Directory (doesDirectoryExist, @@ -16,6 +16,22 @@ import System.Directory (doesDirectoryExist, import System.Directory (getAppUserDataDirectory) import System.Environment (getEnvironment) import System.FilePath (()) +import qualified Distribution.Package as P +import qualified Distribution.PackageDescription as PD +import Distribution.License (License (..)) + +-- | Allow only packages with permissive licenses. +allowPermissive :: [String] -- ^ list of explicitly allowed packages + -> PD.GenericPackageDescription + -> Either String () +allowPermissive allowed gpd + | P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right () + | otherwise = + case PD.license $ PD.packageDescription gpd of + BSD3 -> Right () + MIT -> Right () + PublicDomain -> Right () + l -> Left $ "Non-permissive license: " ++ display l identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer) identsToRanges = diff --git a/app/stackage.hs b/app/stackage.hs index 094643a0..cec57672 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -2,6 +2,7 @@ import Stackage.Types import Stackage.Build (build, defaultBuildSettings) import Stackage.Init (stackageInit) +import Stackage.Util (allowPermissive) import System.Environment (getArgs, getProgName) import Data.Set (fromList) import System.IO (hFlush, stdout) @@ -10,16 +11,26 @@ data BuildArgs = BuildArgs { noClean :: Bool , excluded :: [String] , noPlatform :: Bool + , onlyPermissive :: Bool + , allowed :: [String] } parseBuildArgs :: [String] -> IO BuildArgs parseBuildArgs = - loop $ BuildArgs False [] False + loop BuildArgs + { noClean = False + , excluded = [] + , noPlatform = False + , onlyPermissive = False + , allowed = [] + } where loop x [] = return x loop x ("--no-clean":rest) = loop x { noClean = True } rest loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest loop x ("--no-platform":rest) = loop x { noPlatform = True } rest + loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest + loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest loop _ (y:_) = error $ "Did not understand argument: " ++ y main :: IO () @@ -32,6 +43,10 @@ main = do { cleanBeforeBuild = not noClean , excludedPackages = fromList $ map PackageName excluded , requireHaskellPlatform = not noPlatform + , allowedPackage = + if onlyPermissive + then allowPermissive allowed + else const $ Right () } ["init"] -> do putStrLn "Note: init isn't really ready for prime time use." @@ -49,5 +64,5 @@ main = do putStrLn "Available commands:" putStrLn " update Download updated Stackage databases. Automatically calls init." putStrLn " init Initialize your cabal file to use Stackage" - putStrLn " build [--no-clean] [--no-platform] [--exclude package...]" + putStrLn " build [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package]" putStrLn " Build the package databases (maintainers only)"