b49a2de · stackage · git.iko.soy

Stackage/Build.hs+1−1

compare with master

unifiedsplit

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

41 , excludedPackages = empty

42 , testWorkerThreads = 4

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

44+ , allowedPackage = const $ Right ()

44 }

45 }

45

46

46build :: BuildSettings -> IO ()

47build :: BuildSettings -> IO ()

47build settings' = do

48build settings' = do

48− putStrLn "Creating a build plan"

49 ii <- getInstallInfo settings'

50

51 let root' = sandboxRoot settings'

Stackage/InstallInfo.hs+6−1

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

24

25getInstallInfo :: BuildSettings -> IO InstallInfo

26getInstallInfo settings = do

27+ putStrLn "Loading Haskell Platform"

27 hp <- loadHaskellPlatform settings

28 hp <- loadHaskellPlatform settings

28 let allPackages'

29 let allPackages'

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

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

30 | otherwise = stablePackages settings

31 | otherwise = stablePackages settings

31 allPackages = dropExcluded settings allPackages'

32 allPackages = dropExcluded settings allPackages'

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

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

34+

35+ putStrLn "Loading package database"

33 pdb <- loadPackageDB settings totalCore allPackages

36 pdb <- loadPackageDB settings totalCore allPackages

37+

38+ putStrLn "Narrowing package database"

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

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

35

40

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

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

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

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

Stackage/LoadDatabase.hs+4−3

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

71 _ ->

72 case Tar.entryContent e of

73 Tar.NormalFile bs _ -> do

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

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

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

76 { piVersion = v

77 , piDeps = deps'

78 , piHasTests = hasTests

79 , piBuildTools = buildTools'

80+ , piGPD = mgpd

80 }

81 }

81 _ -> return pdb

82 _ -> return pdb

82

83

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

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

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

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

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

90 ], not $ null $ condTestSuites gpd

91 ], not $ null $ condTestSuites gpd

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

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

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

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

93 where

94 where

94 allBuildInfo gpd = concat

95 allBuildInfo gpd = concat

95 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd

96 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd

Stackage/NarrowDatabase.hs+23−3

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

1module Stackage.NarrowDatabase where

2

3+import Control.Monad.Trans.Writer

3import qualified Data.Map as Map

4import qualified Data.Map as Map

4import qualified Data.Set as Set

5import qualified Data.Set as Set

5import Prelude hiding (pi)

6import Prelude hiding (pi)

6import Stackage.Types

7import Stackage.Types

8+import Stackage.Util

9+import System.Exit (exitFailure)

7

10

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

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

9-- their dependencies.

12-- their dependencies.

10−narrowPackageDB :: PackageDB

13+narrowPackageDB :: BuildSettings

14+ -> PackageDB

11 -> Set (PackageName, Maintainer)

15 -> Set (PackageName, Maintainer)

12 -> IO (Map PackageName BuildInfo)

16 -> IO (Map PackageName BuildInfo)

13−narrowPackageDB (PackageDB pdb) =

17+narrowPackageDB settings (PackageDB pdb) packageSet = do

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

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

15 where

25 where

16 loop result toProcess =

26 loop result toProcess =

17 case Set.minView toProcess of

27 case Set.minView toProcess of

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

29 , biMaintainer = maintainer

39 , biMaintainer = maintainer

30 , biDeps = piDeps pi

40 , biDeps = piDeps pi

31 } result

41 } 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 ()

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

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

33 addDep users result maintainer toProcess p =

53 addDep users result maintainer toProcess p =

34 case Map.lookup p result of

54 case Map.lookup p result of

Stackage/Types.hs+9

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

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

12 PackageName (..))

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

14+import Distribution.PackageDescription (GenericPackageDescription)

14

15

15newtype PackageDB = PackageDB (Map PackageName PackageInfo)

16newtype PackageDB = PackageDB (Map PackageName PackageInfo)

16 deriving (Show, Eq)

17 deriving (Show, Eq)

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

29 , piDeps :: Map PackageName VersionRange

30 , piDeps :: Map PackageName VersionRange

30 , piHasTests :: Bool

31 , piHasTests :: Bool

31 , piBuildTools :: Set PackageName

32 , piBuildTools :: Set PackageName

33+ , piGPD :: Maybe GenericPackageDescription

32 }

34 }

33 deriving (Show, Eq)

35 deriving (Show, Eq)

34

36

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

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

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

82 , flags :: Set String

84 , flags :: Set String

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

85 -- ^ 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.

84 }

93 }

Stackage/Util.hs+17−1

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

8import qualified Data.Map as Map

9import qualified Data.Set as Set

10import Data.Version (showVersion)

11−import Distribution.Text (simpleParse)

11+import Distribution.Text (simpleParse, display)

12import Distribution.Version (thisVersion)

13import Stackage.Types

14import System.Directory (doesDirectoryExist,

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

16import System.Directory (getAppUserDataDirectory)

17import System.Environment (getEnvironment)

18import 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

19

35

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

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

21identsToRanges =

37identsToRanges =

app/stackage.hs+17−2

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

2import Stackage.Types

3import Stackage.Build (build, defaultBuildSettings)

4import Stackage.Init (stackageInit)

5+import Stackage.Util (allowPermissive)

5import System.Environment (getArgs, getProgName)

6import System.Environment (getArgs, getProgName)

6import Data.Set (fromList)

7import Data.Set (fromList)

7import System.IO (hFlush, stdout)

8import System.IO (hFlush, stdout)

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

10 { noClean :: Bool

11 { noClean :: Bool

11 , excluded :: [String]

12 , excluded :: [String]

12 , noPlatform :: Bool

13 , noPlatform :: Bool

14+ , onlyPermissive :: Bool

15+ , allowed :: [String]

13 }

16 }

14

17

15parseBuildArgs :: [String] -> IO BuildArgs

18parseBuildArgs :: [String] -> IO BuildArgs

16parseBuildArgs =

19parseBuildArgs =

17− loop $ BuildArgs False [] False

20+ loop BuildArgs

21+ { noClean = False

22+ , excluded = []

23+ , noPlatform = False

24+ , onlyPermissive = False

25+ , allowed = []

26+ }

18 where

27 where

19 loop x [] = return x

28 loop x [] = return x

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

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

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

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

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

31 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

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

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

24

35

25main :: IO ()

36main :: IO ()

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

32 { cleanBeforeBuild = not noClean

43 { cleanBeforeBuild = not noClean

33 , excludedPackages = fromList $ map PackageName excluded

44 , excludedPackages = fromList $ map PackageName excluded

34 , requireHaskellPlatform = not noPlatform

45 , requireHaskellPlatform = not noPlatform

46+ , allowedPackage =

47+ if onlyPermissive

48+ then allowPermissive allowed

49+ else const $ Right ()

35 }

50 }

36 ["init"] -> do

51 ["init"] -> do

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

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

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

49 putStrLn "Available commands:"

64 putStrLn "Available commands:"

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

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

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

66 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]"

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

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