diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -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 diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -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 diff --git a/Stackage/Curator/RevDeps.hs b/Stackage/Curator/RevDeps.hs new file mode 100644 --- /dev/null +++ b/Stackage/Curator/RevDeps.hs @@ -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 diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs --- a/Stackage/Curator/UploadDocs.hs +++ b/Stackage/Curator/UploadDocs.hs @@ -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) diff --git a/Stackage/DiffPlans.hs b/Stackage/DiffPlans.hs --- a/Stackage/DiffPlans.hs +++ b/Stackage/DiffPlans.hs @@ -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" diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -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) diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs --- a/Stackage/PackageDescription.hs +++ b/Stackage/PackageDescription.hs @@ -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 diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -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 diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -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. diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -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 diff --git a/Stackage/ShowBuildPlan.hs b/Stackage/ShowBuildPlan.hs --- a/Stackage/ShowBuildPlan.hs +++ b/Stackage/ShowBuildPlan.hs @@ -15,6 +15,7 @@ , setShellCommands , abstractCommands , simpleCommands + , ToInstall (..) , getBuildPlan , toSimpleText , toShellScript diff --git a/Stackage/Types.hs b/Stackage/Types.hs --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -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 diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -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 diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -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