stackage-curator 0.14.4.1 → 0.14.5
raw patch · 17 files changed
+151/−31 lines, 17 files
Files
- ChangeLog.md +6/−0
- Stackage/BuildConstraints.hs +5/−0
- Stackage/BuildPlan.hs +3/−3
- Stackage/Curator/RevDeps.hs +26/−0
- Stackage/Curator/UploadDocs.hs +1/−1
- Stackage/DiffPlans.hs +2/−3
- Stackage/GhcPkg.hs +2/−0
- Stackage/PackageDescription.hs +6/−2
- Stackage/PackageIndex.hs +16/−7
- Stackage/PerformBuild.hs +45/−7
- Stackage/ServerBundle.hs +2/−2
- Stackage/ShowBuildPlan.hs +1/−0
- Stackage/Types.hs +17/−3
- Stackage/UpdateBuildPlan.hs +1/−0
- app/stackage.hs +12/−0
- stackage-curator.cabal +2/−1
- test/Stackage/BuildPlanSpec.hs +4/−2
ChangeLog.md view
@@ -1,3 +1,9 @@+## 0.14.5++* Add support for the `hide` field [yesodweb/wai#579](https://github.com/yesodweb/wai/issues/579)+* `list-revdeps` command [#28](https://github.com/fpco/stackage-curator/issues/28)+* Support for newer classy-prelude (fixes some char enc bugs)+ ## 0.14.4.1 * A few missing fixes
Stackage/BuildConstraints.hs view
@@ -22,6 +22,7 @@ import Data.Aeson import Data.Aeson.Internal ((<?>), JSONPathElement (Key)) import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Yaml (decodeEither', decodeFileEither) import Distribution.Package (Dependency (..)) import qualified Distribution.System@@ -125,6 +126,8 @@ , cfGhcMajorVersion :: Maybe (Int, Int) , cfTreatAsNonCore :: Set PackageName , cfTellMeWhenItsReleased :: Map PackageName Version+ , cfHide :: Set PackageName+ -- ^ Packages which should be hidden after registering } instance FromJSON ConstraintFile where@@ -148,6 +151,7 @@ cfTreatAsNonCore <- getPackages o "treat-as-non-core" <|> return mempty cfTellMeWhenItsReleased <- (fmap mconcat $ o .: "tell-me-when-its-released" >>= mapM toNameVerMap) <?> Key "tell-me-when-its-released"+ cfHide <- Set.map PackageName <$> o .:? "hide" .!= mempty return ConstraintFile {..} where goFlagMap = Map.mapKeysWith const FlagName@@ -222,6 +226,7 @@ pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags pcConfigureArgs = fromMaybe mempty $ lookup name cfConfigureArgs pcSkipBuild = name `member` cfSkippedBuilds+ pcHide = name `member` cfHide bcGithubUsers = cfGithubUsers bcBuildToolOverrides = cfBuildToolOverrides
Stackage/BuildPlan.hs view
@@ -30,12 +30,12 @@ -- | Make a build plan given these package set and build constraints. newBuildPlan :: MonadIO m- => Text -- ^ all-cabal-hashes repo commit+ => Either SomeException Text -- ^ all-cabal-hashes repo commit -> Map PackageName PackagePlan -- ^ latest allowed plans -> Map PackageName Version -- ^ latest package version available -> BuildConstraints -> m BuildPlan-newBuildPlan allCabalHashesCommit packagesOrig packagesLatest bc@BuildConstraints {..} = liftIO $ do+newBuildPlan eallCabalHashesCommit packagesOrig packagesLatest bc@BuildConstraints {..} = liftIO $ do let newReleased = mapMaybe checkReleased $ mapToList bcTellMeWhenItsReleased checkReleased (name, expectedVersion) = case lookup name packagesLatest of@@ -78,7 +78,7 @@ , bpPackages = packages , bpGithubUsers = bcGithubUsers , bpBuildToolOverrides = bcBuildToolOverrides- , bpAllCabalHashesCommit = Just allCabalHashesCommit+ , bpAllCabalHashesCommit = either (const Nothing) Just eallCabalHashesCommit } where SystemInfo {..} = bcSystemInfo
+ Stackage/Curator/RevDeps.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Stackage.Curator.RevDeps+ ( listRevDeps+ ) where++import Stackage.Prelude+import Data.Yaml (decodeFileEither)+import Control.Monad.State.Strict (execState, get, put)++listRevDeps :: FilePath+ -> Bool -- ^ deep revdeps+ -> PackageName -- ^ package to check+ -> IO ()+listRevDeps planFile deep pkg0 = do+ BuildPlan {..} <- decodeFileEither planFile >>= either throwIO return+ let go pkg = do+ visited <- get+ unless (pkg `member` visited) $ do+ put $ insertSet pkg visited+ case lookup pkg bpPackages of+ Nothing -> return ()+ Just PackagePlan {..} -> mapM_ go ppUsers+ let pkgs = execState (go pkg0) (asSet mempty)+ mapM_ (putStrLn . unPackageName) pkgs
Stackage/Curator/UploadDocs.hs view
@@ -189,7 +189,7 @@ -- Sink to a Document and then use blaze-html to render to avoid using -- XML rendering rules (e.g., empty elements) upload' True key $ sourceLazy (renderHtml $ toHtml doc)- | any (F.hasExtension $ fromString fp) $ words "css js png svg gif" = void $ getName fp+ | any (F.hasExtension $ fromString fp) $ words "css js png gif" = void $ getName fp | otherwise = upload' True key $ sourceFile fp where Just suffix = F.stripPrefix (fromString input F.</> "") (fromString fp)
Stackage/DiffPlans.hs view
@@ -8,6 +8,7 @@ import Data.Text (justifyLeft) import Data.Yaml (decodeFileEither) import Network.HTTP.Client+import Network.HTTP.Simple (httpSink) import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.Prelude @@ -88,10 +89,8 @@ getLTS :: String -> IO FilePath getLTS lts = do createDirectoryIfMissing True tmpDir- man <- newManager tlsManagerSettings req <- parseUrlThrow $ ltsRepo <> lts <> ".yaml"- res <- httpLbs req man- writeFile fName $ responseBody res+ runResourceT $ httpSink req $ const $ sinkFile fName return fName where fName = tmpDir <> lts <> ".yaml"
Stackage/GhcPkg.hs view
@@ -28,10 +28,12 @@ -> IO (Map PackageName Version) -- ^ packages remaining in the database after cleanup setupPackageDatabase mdb docDir log' toInstall onUnregister = do registered1 <- getRegisteredPackages flags+ log' "Unregistering packages with version mismatch\n" forM_ registered1 $ \pi'@(PackageIdentifier name version) -> case lookup name toInstall of Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi' _ -> return ()+ log' "\nUnregistering packages which are now broken in the database\n" broken <- getBrokenPackages flags forM_ broken $ unregisterPackage log' onUnregister docDir flags foldMap (\(PackageIdentifier name version) -> singletonMap name version)
Stackage/PackageDescription.hs view
@@ -40,11 +40,15 @@ $ map (fromString . fst) $ spdCondExecutables spd , sdCabalVersion = Option $ Max <$> spdCabalVersion spd- , sdPackages = unionsWith (<>) $ flip map (spdSetupDeps spd)+ , sdPackages = unionsWith (<>) $ maybe [] (map $ \(Dependency x y) -> singletonMap x DepInfo { diComponents = setFromList [minBound..maxBound] , diRange = simplifyVersionRange y- }+ }) (spdSetupDeps spd)+ , sdSetupDeps =+ case spdSetupDeps spd of+ Nothing -> Nothing+ Just deps -> Just $ setFromList $ map (\(Dependency x _) -> x) deps } when (ccIncludeTests cc) $ forM_ (spdCondTestSuites spd) $ tellTree cc CompTestSuite . snd
Stackage/PackageIndex.hs view
@@ -38,7 +38,7 @@ import Distribution.System (Arch, OS) import Stackage.Prelude import Stackage.GithubPings-import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)+import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory) import qualified Data.ByteString.Base16 as B16 import qualified Crypto.Hash.SHA256 as SHA256@@ -54,16 +54,25 @@ getPackageIndexPath :: MonadIO m => m FilePath getPackageIndexPath = liftIO $ do stackRoot <- getAppUserDataDirectory "stack"- let tarball = stackRoot </> "indices" </> "Hackage" </> "00-index.tar"- return tarball+ let tarballs =+ [ stackRoot </> "indices" </> "Hackage" </> "01-index.tar"+ , stackRoot </> "indices" </> "Hackage" </> "00-index.tar"+ ]+ loop [] = error $ "tarballs not found: " ++ show tarballs+ loop (x:xs) = do+ exists <- doesFileExist x+ if exists+ then return x+ else loop xs+ loop tarballs -- | Get the Git commit of the all-cabal-hashes repo at its current state-getAllCabalHashesCommit :: MonadIO m => m Text+getAllCabalHashesCommit :: MonadIO m => m (Either SomeException Text) getAllCabalHashesCommit = liftIO $ do stackRoot <- getAppUserDataDirectory "stack" let dir = stackRoot </> "indices" </> "Hackage" </> "git-update" </> "all-cabal-hashes" cp = (proc "git" ["rev-list", "-n", "1", "current-hackage"]) { cwd = Just dir }- withCheckedProcessCleanup cp $ \ClosedStream out ClosedStream ->+ tryAny $ withCheckedProcessCleanup cp $ \ClosedStream out ClosedStream -> out $$ takeWhileCE (/= 10) =$ decodeUtf8C =$ foldC -- | A cabal file with name and version parsed from the filepath, and the@@ -92,7 +101,7 @@ , spdCondExecutables :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] , spdCondTestSuites :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] , spdCondBenchmarks :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)]- , spdSetupDeps :: [Dependency]+ , spdSetupDeps :: Maybe [Dependency] , spdPackageFlags :: Map FlagName Bool , spdGithubPings :: Set Text , spdCabalVersion :: Maybe Version@@ -151,7 +160,7 @@ , spdCondExecutables = map (fmap $ mapCondTree simpleExe) $ condExecutables gpd , spdCondTestSuites = map (fmap $ mapCondTree simpleTest) $ condTestSuites gpd , spdCondBenchmarks = map (fmap $ mapCondTree simpleBench) $ condBenchmarks gpd- , spdSetupDeps = maybe [] setupDepends $ setupBuildInfo $ packageDescription gpd+ , spdSetupDeps = fmap setupDepends $ setupBuildInfo $ packageDescription gpd , spdPackageFlags = let getFlag MkFlag {..} = (flagName, flagDefault) in mapFromList $ map getFlag $ genPackageFlags gpd
Stackage/PerformBuild.hs view
@@ -408,8 +408,21 @@ : "-global-package-db" : (case pbDatabase pb of Nothing -> rest- Just db -> ("-package-db=" ++ pack db) : rest)+ Just db -> ("-package-db=" ++ pack db) : setupPackages ++ rest) + setupPackages :: [Text]+ setupPackages =+ case sdSetupDeps $ ppDesc $ piPlan sbPackageInfo of+ Nothing -> []+ Just pkgs -> "-hide-all-packages" : map (("-package=" ++) . display) (setToList pkgs)++ ghcPkgArgs :: [Text] -> [Text]+ ghcPkgArgs rest =+ "--no-user-package-db"+ : (case pbDatabase pb of+ Nothing -> rest+ Just db -> ("--package-db=" ++ pack db) : rest)+ configArgs = ($ []) $ execWriter $ do tell' "--package-db=clear" tell' "--package-db=global"@@ -497,7 +510,7 @@ ] return True | otherwise -> return False- when toBuild $ withConfiged $ \_childDir cabal -> do+ when toBuild $ withConfiged $ \childDir cabal -> do deletePreviousResults pb pident log' $ "Building " ++ namever@@ -505,8 +518,11 @@ log' $ "Copying/registering " ++ namever cabal ["copy"]- withMVar sbRegisterMutex $ const $+ withMVar sbRegisterMutex $ const $ do cabal ["register"]+ when pcHide $ do+ log' $ "Hiding " ++ namever+ runIn childDir getOutH "ghc-pkg" $ ghcPkgArgs ["hide", namever] savePreviousResult pb Build pident True @@ -621,8 +637,7 @@ ] else do outH <- getOutH- hPutStrLn outH $ "Test suite not built: " ++ test- hFlush outH+ hPut outH $ encodeUtf8 $ "Test suite not built: " ++ pack test savePreviousResult pb Test pident $ either (const False) (const True) eres case (eres, pcTests) of@@ -756,12 +771,14 @@ where go :: ResultType -> IO (Map PackageName (Version, PrevResult)) go rt = do- allResults <-+ exists <- doesDirectoryExist dir+ allResults <- if exists then runResourceT $ sourceDirectory dir $$ filterMC (liftIO . doesFileExist) =$ mapMC (liftIO . toMap) =$ foldlC (unionWith union) mempty+ else return mempty fmap concat $ mapM (uncurry removeDupes) $ mapToList allResults where dir = pbPrevResDir pb </> show rt@@ -803,7 +820,8 @@ -- | Remove all previous results to avoid a broken cache removePreviousResults :: PerformBuild -> ResultType -> PackageName -> IO () removePreviousResults pb rt name =- runResourceT+ whenM (doesDirectoryExist dir)+ $ runResourceT $ sourceDirectory dir $$ filterC isOurPackage =$ filterMC (liftIO . doesFileExist)@@ -981,6 +999,12 @@ loop buildStates0 = do buildStates1 <- foldM step' buildStates0 (mapToList allInfos)+ when False $ putStrLn $ concat+ [ "Debugging: added "+ , tshow $ length buildStates1 - length buildStates0+ , " keys, new keys == "+ , tshow (map display $ keys $ buildStates1 `Map.difference` buildStates0)+ ] case (keys $ buildStates1 `difference` buildStates0, keys $ allInfos `Map.difference` buildStates1) of -- Added new build states, and no infos are unaccounted for, so -- we're done@@ -990,13 +1014,27 @@ -- packages, so loop (_:_, _:_) -> loop buildStates1 + ([], []) -> processBuildStates buildStates1++ {- FIXME make this testing more robust+ (_:_, _:_) -> loop buildStates1+ -- Did not add any build states, but somehow all the infos are -- accounted for. This is logically impossible, print an error. ([], []) -> do putStrLn $ "\n\ncalculatePackageMap: Solved all packages, but no change in build states" mapM_ print $ mapToList buildStates1 putStrLn $ "\n\nPreviously missing packages:" ++ tshow (map display $ keys $ allInfos `Map.difference` buildStates0)+ putStrLn $ concat+ [ "length allInfos: "+ , tshow $ length allInfos+ , ", length buildStates1: "+ , tshow $ length buildStates1+ , ", length buildStates0: "+ , tshow $ length buildStates0+ ] error "FIXME"+ -} -- Did not add any build states, and we still have some infos -- unaccounted for. That indicates some kind of cyclic dependency.
Stackage/ServerBundle.hs view
@@ -164,10 +164,10 @@ $$ filterMC (liftIO . doesDirectoryExist) =$ mapC takeFileName =$ sinkList- writeFile (dir </> "index.html") $ mkIndex+ writeFile (dir </> "index.html") $ encodeUtf8 $ pack $ mkIndex (unpack <$> msnapid) dirs- writeFile (dir </> "style.css") styleCss+ writeFile (dir </> "style.css") $ encodeUtf8 $ pack styleCss return dirs mkIndex :: Maybe String -> [String] -> String
Stackage/ShowBuildPlan.hs view
@@ -15,6 +15,7 @@ , setShellCommands , abstractCommands , simpleCommands+ , ToInstall (..) , getBuildPlan , toSimpleText , toShellScript
Stackage/Types.hs view
@@ -254,6 +254,9 @@ -- ^ Don't even bother building this library, useful when dealing with -- OS-specific packages. See: -- https://github.com/fpco/stackage-curator/issues/3+ , pcHide :: !Bool+ -- ^ Hide this package after registering, useful for avoiding+ -- module name conflicts } deriving (Show, Eq) instance ToJSON PackageConstraints where@@ -273,6 +276,7 @@ , "library-profiling" .= pcEnableLibProfile , "skip-build" .= pcSkipBuild , "configure-args" .= pcConfigureArgs+ , "hide" .= pcHide ] where addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer@@ -291,6 +295,7 @@ pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") pcSkipBuild <- o .:? "skip-build" .!= False pcConfigureArgs <- o .:? "configure-args" .!= mempty+ pcHide <- o .:? "hide" .!= False return PackageConstraints {..} data TestState = ExpectSuccess@@ -374,18 +379,20 @@ -- ^ modules exported by the library , sdCabalVersion :: Option (Max Version) -- ^ minimum acceptable Cabal version+ , sdSetupDeps :: Maybe (Set PackageName) } deriving (Show, Eq) instance Monoid SimpleDesc where- mempty = SimpleDesc mempty mempty mempty mempty mempty- mappend (SimpleDesc a b c d e) (SimpleDesc w x y z e') = SimpleDesc+ mempty = SimpleDesc mempty mempty mempty mempty mempty mempty+ mappend (SimpleDesc a b c d e f) (SimpleDesc w x y z e' f') = SimpleDesc (Map.unionWith (<>) a w) (Map.unionWith (<>) b x) (c <> y) (d <> z) (e <> e')+ (f <> f') instance ToJSON SimpleDesc where- toJSON SimpleDesc {..} = object $ addCabalVersion+ toJSON SimpleDesc {..} = object $ addSetupDeps $ addCabalVersion [ "packages" .= Map.mapKeysWith const unPackageName sdPackages , "tools" .= Map.mapKeysWith const unExeName sdTools , "provided-exes" .= sdProvidedExes@@ -396,6 +403,10 @@ case sdCabalVersion of Option (Just (Max v)) -> ("cabal-version" .= display v) : rest Option Nothing -> rest+ addSetupDeps rest =+ case sdSetupDeps of+ Just deps -> ("setup-deps" .= map display (Set.toList deps)) : rest+ Nothing -> rest instance FromJSON SimpleDesc where parseJSON = withObject "SimpleDesc" $ \o -> do sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")@@ -405,6 +416,9 @@ sdCabalVersion <- o .:? "cabal-version" >>= maybe (return $ Option Nothing) (either (fail . show) (return . Option . Just . Max) . simpleParse)+ sdSetupDeps <- o .:? "setup-deps" >>= maybe+ (return Nothing)+ (either (fail . show) (return . Just . Set.fromList) . mapM simpleParse) return SimpleDesc {..} data DepInfo = DepInfo
Stackage/UpdateBuildPlan.hs view
@@ -42,6 +42,7 @@ , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC , pcEnableLibProfile = maybe True pcEnableLibProfile moldPC , pcSkipBuild = maybe False pcSkipBuild moldPC+ , pcHide = maybe False pcHide moldPC } where moldBP = lookup name bpPackages
app/stackage.hs view
@@ -9,6 +9,7 @@ import Options.Applicative.Simple (simpleOptions, simpleVersion, addCommand) import Paths_stackage_curator (version) import Stackage.CompleteBuild+import Stackage.Curator.RevDeps import Stackage.Curator.UploadIndex import Stackage.DiffPlans import Stackage.InstallBuild@@ -73,6 +74,8 @@ <*> pure (T.pack "package-index/")) addCommand "upload-docs" "Upload documentation to an S3 bucket" id (uploadDocs' <$> target <*> bundleFile)+ addCommand "list-revdeps" "List reverse dependencies" id+ (listRevDeps <$> planFile <*> deepRevDeps <*> revDepPackage) makeBundle' = makeBundle <$> planFile@@ -333,3 +336,12 @@ switch (long "html" <> short 'h' <> help "Wrap the output in HTML <ul>/<li> tags")++ deepRevDeps =+ switch+ (long "deep" <>+ help "List deep reverse dependencies, not just immediate users")++ revDepPackage = argument packageRead+ (metavar "PACKAGE-NAME" +++ help "Package to list reverse deps for")
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.14.4.1+version: 0.14.5 synopsis: Tools for curating Stackage bundles description: Please see <http://www.stackage.org/package/stackage-curator> for a description and documentation. homepage: https://github.com/fpco/stackage-curator@@ -34,6 +34,7 @@ Stackage.Upload Stackage.PerformBuild Stackage.CompleteBuild+ Stackage.Curator.RevDeps Stackage.Curator.UploadDocs Stackage.Curator.UploadIndex Stackage.ShowBuildPlan
test/Stackage/BuildPlanSpec.hs view
@@ -125,14 +125,16 @@ ,pcBenches = Don'tBuild ,pcFlagOverrides = mempty ,pcEnableLibProfile = False- ,pcSkipBuild = False}+ ,pcSkipBuild = False+ ,pcHide = False} ,ppDesc = SimpleDesc {sdPackages = deps ,sdTools = mempty ,sdProvidedExes = mempty ,sdModules = mempty- ,sdCabalVersion = mempty}}+ ,sdCabalVersion = mempty+ ,sdSetupDeps = Nothing}} -- | This exact version is required. thisV :: [Int] -> VersionRange