--only-permissive and --allow

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'

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

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

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

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.
     }

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 =

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)"