b49a2de · stackage · git.iko.soy

git.iko.soy/stackage

--only-permissive and --allow

commitb49a2de303c13c583f058eff4f0ccdf96a96bca6 authorMichael Snoyman <michael@snoyman.com> dateTue 18 Dec 2012, 12:20 (14 years ago) parent66e9032

7 files changed+77−11

compare with master

unifiedsplit

Stackage/Build.hs+1−1 Stackage/InstallInfo.hs+6−1 Stackage/LoadDatabase.hs+4−3 Stackage/NarrowDatabase.hs+23−3 Stackage/Types.hs+9 Stackage/Util.hs+17−1 app/stackage.hs+17−2

Stackage/Build.hs+1−1

@@ -41,11 +41,11 @@ defaultBuildSettings = BuildSettings

4141 , excludedPackages = empty

4242 , testWorkerThreads = 4

4343 , flags = Set.fromList $ words "blaze_html_0_5"

44+ , allowedPackage = const $ Right ()

4445 }

4546

4647build :: BuildSettings -> IO ()

4748build settings' = do

48− putStrLn "Creating a build plan"

4949 ii <- getInstallInfo settings'

5050

5151 let root' = sandboxRoot settings'

Stackage/InstallInfo.hs+6−1

@@ -24,14 +24,19 @@ dropExcluded bs m0 =

2424

2525getInstallInfo :: BuildSettings -> IO InstallInfo

2626getInstallInfo settings = do

27+ putStrLn "Loading Haskell Platform"

2728 hp <- loadHaskellPlatform settings

2829 let allPackages'

2930 | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)

3031 | otherwise = stablePackages settings

3132 allPackages = dropExcluded settings allPackages'

3233 let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)

34+

35+ putStrLn "Loading package database"

3336 pdb <- loadPackageDB settings totalCore allPackages

34− final <- narrowPackageDB pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages

37+

38+ putStrLn "Narrowing package database"

39+ final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages

3540

3641 putStrLn "Printing build plan to build-plan.log"

3742 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final

Stackage/LoadDatabase.hs+4−3

@@ -71,12 +71,13 @@ loadPackageDB settings core deps = do

7171 _ ->

7272 case Tar.entryContent e of

7373 Tar.NormalFile bs _ -> do

74− let (deps', hasTests, buildTools') = parseDeps bs

74+ let (deps', hasTests, buildTools', mgpd) = parseDeps bs

7575 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo

7676 { piVersion = v

7777 , piDeps = deps'

7878 , piHasTests = hasTests

7979 , piBuildTools = buildTools'

80+ , piGPD = mgpd

8081 }

8182 _ -> return pdb

8283

@@ -88,8 +89,8 @@ loadPackageDB settings core deps = do

8889 , mconcat $ map (go gpd . snd) $ condTestSuites gpd

8990 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd

9091 ], not $ null $ condTestSuites gpd

91− , Set.fromList $ map depName $ allBuildInfo gpd)

92− _ -> (mempty, defaultHasTestSuites, Set.empty)

92+ , Set.fromList $ map depName $ allBuildInfo gpd, Just gpd)

93+ _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing)

9394 where

9495 allBuildInfo gpd = concat

9596 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd

Stackage/NarrowDatabase.hs+23−3

@@ -1,17 +1,27 @@

11module Stackage.NarrowDatabase where

3+import Control.Monad.Trans.Writer

34import qualified Data.Map as Map

45import qualified Data.Set as Set

56import Prelude hiding (pi)

67import Stackage.Types

8+import Stackage.Util

9+import System.Exit (exitFailure)

710

811-- | Narrow down the database to only the specified packages and all of

912-- their dependencies.

10−narrowPackageDB :: PackageDB

13+narrowPackageDB :: BuildSettings

14+ -> PackageDB

1115 -> Set (PackageName, Maintainer)

1216 -> IO (Map PackageName BuildInfo)

13−narrowPackageDB (PackageDB pdb) =

14− loop Map.empty . Set.map (\(name, maintainer) -> ([], name, maintainer))

17+narrowPackageDB settings (PackageDB pdb) packageSet = do

18+ (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet

19+ if Set.null errs

20+ then return res

21+ else do

22+ putStrLn "Build plan requires some disallowed packages"

23+ mapM_ putStrLn $ Set.toList errs

24+ exitFailure

1525 where

1626 loop result toProcess =

1727 case Set.minView toProcess of

@@ -29,6 +39,16 @@ narrowPackageDB (PackageDB pdb) =

2939 , biMaintainer = maintainer

3040 , biDeps = piDeps pi

3141 } result

42+ case piGPD pi of

43+ Nothing -> return ()

44+ Just gpd ->

45+ case allowedPackage settings gpd of

46+ Left msg -> tell $ Set.singleton $ concat

47+ [ packageVersionString (p, piVersion pi)

48+ , ": "

49+ , msg

50+ ]

51+ Right () -> return ()

3252 loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi

3353 addDep users result maintainer toProcess p =

3454 case Map.lookup p result of

Stackage/Types.hs+9

@@ -11,6 +11,7 @@ import Data.Version as X (Version)

1111import Distribution.Package as X (PackageIdentifier (..),

1212 PackageName (..))

1313import Distribution.Version as X (VersionRange (..))

14+import Distribution.PackageDescription (GenericPackageDescription)

1415

1516newtype PackageDB = PackageDB (Map PackageName PackageInfo)

1617 deriving (Show, Eq)

@@ -29,6 +30,7 @@ data PackageInfo = PackageInfo

2930 , piDeps :: Map PackageName VersionRange

3031 , piHasTests :: Bool

3132 , piBuildTools :: Set PackageName

33+ , piGPD :: Maybe GenericPackageDescription

3234 }

3335 deriving (Show, Eq)

3436

@@ -81,4 +83,11 @@ data BuildSettings = BuildSettings

8183 -- ^ How many threads to spawn for running test suites.

8284 , flags :: Set String

8385 -- ^ Compile flags which should be turned on.

86+ , allowedPackage :: GenericPackageDescription -> Either String ()

87+ -- ^ Checks if a package is allowed into the distribution. By default, we

88+ -- allow all packages in, though this could be used to filter out certain

89+ -- untrusted packages, or packages with an unacceptable license.

90+ --

91+ -- Returns a reason for stripping in Left, or Right if the package is

92+ -- allowed.

8493 }

Stackage/Util.hs+17−1

@@ -8,7 +8,7 @@ import Data.List (stripPrefix)

88import qualified Data.Map as Map

99import qualified Data.Set as Set

1010import Data.Version (showVersion)

11−import Distribution.Text (simpleParse)

11+import Distribution.Text (simpleParse, display)

1212import Distribution.Version (thisVersion)

1313import Stackage.Types

1414import System.Directory (doesDirectoryExist,

@@ -16,6 +16,22 @@ import System.Directory (doesDirectoryExist,

1616import System.Directory (getAppUserDataDirectory)

1717import System.Environment (getEnvironment)

1818import System.FilePath ((</>))

19+import qualified Distribution.Package as P

20+import qualified Distribution.PackageDescription as PD

21+import Distribution.License (License (..))

22+

23+-- | Allow only packages with permissive licenses.

24+allowPermissive :: [String] -- ^ list of explicitly allowed packages

25+ -> PD.GenericPackageDescription

26+ -> Either String ()

27+allowPermissive allowed gpd

28+ | P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right ()

29+ | otherwise =

30+ case PD.license $ PD.packageDescription gpd of

31+ BSD3 -> Right ()

32+ MIT -> Right ()

33+ PublicDomain -> Right ()

34+ l -> Left $ "Non-permissive license: " ++ display l

1935

2036identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer)

2137identsToRanges =

app/stackage.hs+17−2

@@ -2,6 +2,7 @@

22import Stackage.Types

33import Stackage.Build (build, defaultBuildSettings)

44import Stackage.Init (stackageInit)

5+import Stackage.Util (allowPermissive)

56import System.Environment (getArgs, getProgName)

67import Data.Set (fromList)

78import System.IO (hFlush, stdout)

@@ -10,16 +11,26 @@ data BuildArgs = BuildArgs

1011 { noClean :: Bool

1112 , excluded :: [String]

1213 , noPlatform :: Bool

14+ , onlyPermissive :: Bool

15+ , allowed :: [String]

1316 }

1417

1518parseBuildArgs :: [String] -> IO BuildArgs

1619parseBuildArgs =

17− loop $ BuildArgs False [] False

20+ loop BuildArgs

21+ { noClean = False

22+ , excluded = []

23+ , noPlatform = False

24+ , onlyPermissive = False

25+ , allowed = []

26+ }

1827 where

1928 loop x [] = return x

2029 loop x ("--no-clean":rest) = loop x { noClean = True } rest

2130 loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest

2231 loop x ("--no-platform":rest) = loop x { noPlatform = True } rest

32+ loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest

33+ loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest

2334 loop _ (y:_) = error $ "Did not understand argument: " ++ y

2435

2536main :: IO ()

@@ -32,6 +43,10 @@ main = do

3243 { cleanBeforeBuild = not noClean

3344 , excludedPackages = fromList $ map PackageName excluded

3445 , requireHaskellPlatform = not noPlatform

46+ , allowedPackage =

47+ if onlyPermissive

48+ then allowPermissive allowed

49+ else const $ Right ()

3550 }

3651 ["init"] -> do

3752 putStrLn "Note: init isn't really ready for prime time use."

@@ -49,5 +64,5 @@ main = do

4964 putStrLn "Available commands:"

5065 putStrLn " update Download updated Stackage databases. Automatically calls init."

5166 putStrLn " init Initialize your cabal file to use Stackage"

52− putStrLn " build [--no-clean] [--no-platform] [--exclude package...]"

67+ putStrLn " build [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package]"

5368 putStrLn " Build the package databases (maintainers only)"