diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 0.14.0 + +* Move stackage-types into this package +* Move stackage-build-plan into this package +* Start building benchmarks [stackage#1372](https://github.com/fpco/stackage/issues/1372) +* Add cabal-from-head +* Include cabal file size and hash info + ## 0.13.3 Move away from outdated stackage-metadata diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -111,6 +111,7 @@ , cfSkippedTests :: Set PackageName , cfSkippedBuilds :: Set PackageName , cfExpectedTestFailures :: Set PackageName + , cfExpectedBenchFailures :: Set PackageName , cfExpectedHaddockFailures :: Set PackageName , cfSkippedBenchmarks :: Set PackageName , cfPackages :: Map Maintainer (Vector Dependency) @@ -127,6 +128,8 @@ cfSkippedTests <- getPackages o "skipped-tests" cfSkippedBuilds <- getPackages o "skipped-builds" <|> return mempty cfExpectedTestFailures <- getPackages o "expected-test-failures" + cfExpectedBenchFailures <- getPackages o "expected-benchmark-failures" + <|> pure mempty -- backwards compat cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" cfSkippedLibProfiling <- getPackages o "skipped-profiling" @@ -196,7 +199,10 @@ | name `member` cfSkippedTests = Don'tBuild | name `member` cfExpectedTestFailures = ExpectFailure | otherwise = ExpectSuccess - pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks + pcBenches + | name `member` cfSkippedBenchmarks = Don'tBuild + | name `member` cfExpectedBenchFailures = ExpectFailure + | otherwise = ExpectSuccess pcHaddocks | name `member` cfExpectedHaddockFailures = ExpectFailure diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -133,6 +133,7 @@ where name = spdName spd ppVersion = spdVersion spd + ppCabalFileInfo = Just $ spdCabalFileInfo spd ppGithubPings = applyGithubMapping bc $ spdGithubPings spd ppConstraints = onlyRelevantFlags $ bcPackageConstraints bc name ppUsers = mempty -- must be filled in later @@ -152,7 +153,7 @@ ccCompilerVersion = siGhcVersion ccFlags = flags ccIncludeTests = pcTests ppConstraints /= Don'tBuild - ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints + ccIncludeBenchmarks = pcBenches ppConstraints /= Don'tBuild SystemInfo {..} = bcSystemInfo bc diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -48,6 +48,7 @@ -- | Flags passed in from the command line. data BuildFlags = BuildFlags { bfEnableTests :: !Bool + , bfEnableBenches :: !Bool , bfEnableHaddock :: !Bool , bfDoUpload :: !Bool , bfEnableLibProfile :: !Bool @@ -70,9 +71,10 @@ -> [Dependency] -- ^ additional constraints -> [PackageName] -- ^ newly added packages -> [PackageName] -- ^ newly expected test failures + -> [PackageName] -- ^ newly expected bench failures -> [PackageName] -- ^ newly expected haddock failures -> IO () -createPlan target dest constraints addPackages expectTestFailures expectHaddockFailures = do +createPlan target dest constraints addPackages expectTestFailures expectBenchFailures expectHaddockFailures = do man <- newManager tlsManagerSettings putStrLn $ "Creating plan for: " ++ tshow target bc <- @@ -96,6 +98,7 @@ plan <- planFromConstraints $ flip (foldr expectHaddockFailure) expectHaddockFailures $ flip (foldr expectTestFailure) expectTestFailures + $ flip (foldr expectBenchFailure) expectBenchFailures $ flip (foldr addPackage) addPackages $ setConstraints constraints bc @@ -107,6 +110,7 @@ addPackage name bc = bc { bcPackages = insertSet name $ bcPackages bc } expectTestFailure = tweak $ \pc -> pc { pcTests = ExpectFailure } + expectBenchFailure = tweak $ \pc -> pc { pcBenches = ExpectFailure } expectHaddockFailure = tweak $ \pc -> pc { pcHaddocks = ExpectFailure } tweak f name bc = bc @@ -403,6 +407,7 @@ -> Target -> Maybe Int -- ^ jobs -> Bool -- ^ skip tests? + -> Bool -- ^ skip benches? -> Bool -- ^ skip haddock? -> Bool -- ^ skip hoogle? -> Bool -- ^ enable library profiling? @@ -410,11 +415,12 @@ -> Bool -- ^ verbose? -> Bool -- ^ allow-newer? -> Bool -- ^ no rebuild cabal? + -> Bool -- ^ cabal from head? -> IO () makeBundle - planFile docmapFile bundleFile target mjobs skipTests skipHaddocks skipHoogle + planFile docmapFile bundleFile target mjobs skipTests skipBenches skipHaddocks skipHoogle enableLibraryProfiling enableExecutableDynamic verbose allowNewer - noRebuildCabal + noRebuildCabal cabalFromHead = do plan <- decodeFileEither planFile >>= either throwM return jobs <- maybe getNumCapabilities return mjobs @@ -429,6 +435,7 @@ , pbJobs = jobs , pbGlobalInstall = False , pbEnableTests = not skipTests + , pbEnableBenches = not skipBenches , pbEnableHaddock = not skipHaddocks , pbEnableLibProfiling = enableLibraryProfiling , pbEnableExecDyn = enableExecutableDynamic @@ -436,6 +443,7 @@ , pbAllowNewer = allowNewer , pbBuildHoogle = not skipHoogle , pbNoRebuildCabal = noRebuildCabal + , pbCabalFromHead = cabalFromHead } putStrLn "Performing build" diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -29,6 +29,7 @@ , ifJobs :: !Int , ifGlobalInstall :: !Bool , ifEnableTests :: !Bool + , ifEnableBenches :: !Bool , ifEnableHaddock :: !Bool , ifEnableLibProfiling :: !Bool , ifEnableExecDyn :: !Bool @@ -53,6 +54,7 @@ , pbJobs = ifJobs , pbGlobalInstall = ifGlobalInstall , pbEnableTests = ifEnableTests + , pbEnableBenches = ifEnableBenches , pbEnableHaddock = ifEnableHaddock , pbEnableLibProfiling = ifEnableLibProfiling , pbEnableExecDyn = ifEnableExecDyn @@ -60,6 +62,7 @@ , pbAllowNewer = ifSkipCheck , pbBuildHoogle = ifBuildHoogle , pbNoRebuildCabal = ifNoRebuildCabal + , pbCabalFromHead = False } -- | Install stackage from an existing build plan. diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -33,15 +33,21 @@ import Distribution.ParseUtils (PError) import Distribution.System (Arch, OS) import Stackage.Prelude +import Stackage.Types (CabalFileInfo (..)) import Stackage.GithubPings import System.Directory (doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing) import System.FilePath (takeDirectory) import qualified Data.Binary as Bin (Binary) +import Data.Binary.Orphans () import qualified Data.Binary.Tagged as Bin import qualified Data.ByteString.Base16 as B16 import qualified Crypto.Hash.SHA256 as SHA256 import Language.Haskell.Extension (Extension, Language, KnownExtension) import Data.Proxy +import Crypto.Hash (MD5 (..), SHA1 (..), SHA256 (..), + SHA512 (..), Skein512_512 (..), hashlazy, + Digest, HashAlgorithm, digestToHexByteString) +import qualified Crypto.Hash.SHA1 as SHA1 -- | Name of the 00-index.tar downloaded from Hackage. getPackageIndexPath :: MonadIO m => m FilePath @@ -77,6 +83,7 @@ data SimplifiedPackageDescription = SimplifiedPackageDescription { spdName :: PackageName , spdVersion :: Version + , spdCabalFileInfo :: CabalFileInfo , spdCondLibrary :: Maybe (CondTree ConfVar [Dependency] SimplifiedComponentInfo) , spdCondExecutables :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] , spdCondTestSuites :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] @@ -124,10 +131,32 @@ instance Bin.HasStructuralInfo FlagName -- END orphans -gpdToSpd :: GenericPackageDescription -> SimplifiedPackageDescription -gpdToSpd gpd = SimplifiedPackageDescription +gpdToSpd :: LByteString -- ^ raw cabal file contents + -> GenericPackageDescription -> SimplifiedPackageDescription +gpdToSpd raw gpd = SimplifiedPackageDescription { spdName = name , spdVersion = version + , spdCabalFileInfo = CabalFileInfo + { cfiSize = length raw + , cfiHashes = + let go :: (Show ha, HashAlgorithm ha) => ha -> (Text, Text) + go constr = (tshow constr, unwrap constr (hashlazy raw)) + unwrap :: ha -> Digest ha -> Text + unwrap _ = decodeUtf8 . digestToHexByteString + in mapFromList + [ go SHA1 + , go SHA256 + , go SHA512 + , go Skein512_512 + , go MD5 + , ("GitSHA1", decodeUtf8 $ B16.encode $ SHA1.hashlazy $ concat + [ "blob " + , fromStrict $ encodeUtf8 $ tshow $ length raw + , "\0" + , raw + ]) + ] + } , spdCondLibrary = fmap (mapCondTree simpleLib) $ condLibrary gpd , spdCondExecutables = map (fmap $ mapCondTree simpleExe) $ condExecutables gpd , spdCondTestSuites = map (fmap $ mapCondTree simpleTest) $ condTestSuites gpd @@ -183,7 +212,7 @@ when (name /= name' || version /= version') $ throwM $ MismatchedNameVersion fp name name' version version' - return $ gpdToSpd gpd + return $ gpdToSpd lbs gpd gpdFromLBS :: MonadThrow m => FilePath diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -77,6 +77,7 @@ , pbGlobalInstall :: Bool -- ^ Register packages in the global database , pbEnableTests :: Bool + , pbEnableBenches :: Bool , pbEnableHaddock :: Bool , pbEnableLibProfiling :: Bool , pbEnableExecDyn :: Bool @@ -90,6 +91,9 @@ , pbNoRebuildCabal :: !Bool -- ^ Ignore new Cabal version from the plan and use whatever's in the -- database. Useful for testing pre-release GHCs + , pbCabalFromHead :: !Bool + -- ^ Used for testing Cabal itself: grab the most recent version of Cabal + -- from Github master } data PackageInfo = PackageInfo @@ -292,9 +296,12 @@ where libComps = setFromList [CompLibrary, CompExecutable] testComps = insertSet CompTestSuite libComps + benchComps = insertSet CompBenchmark libComps + thisIsCabal = pname == PackageName "Cabal" -- cue Sparta joke + inner - | pname == PackageName "Cabal" && pbNoRebuildCabal = + | thisIsCabal && pbNoRebuildCabal = atomically $ putTMVar (piResult sbPackageInfo) True | otherwise = do let wfd comps = @@ -303,6 +310,7 @@ withUnpacked <- wfd libComps buildLibrary wfd testComps (runTests withUnpacked) + wfd benchComps (buildBenches withUnpacked) pname = piName sbPackageInfo pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) @@ -355,8 +363,6 @@ , env = Just sbModifiedEnv } runParent = runIn sbBuildDir - runChild = runIn childDir - childDir = sbBuildDir unpack namever log' t = do i <- readTVarIO sbActive @@ -371,6 +377,7 @@ ] libOut = pbLogDir unpack namever "build.out" testOut = pbLogDir unpack namever "test.out" + benchOut = pbLogDir unpack namever "bench.out" wf fp inner' = do ref <- newIORef Nothing @@ -429,33 +436,43 @@ hasLib = not $ null $ sdModules $ ppDesc $ piPlan sbPackageInfo buildLibrary = wf libOut $ \getOutH -> do - let run a b = do when pbVerbose $ log' (unwords (a : b)) - runChild getOutH a b - cabal args = run "runghc" $ runghcArgs $ "Setup" : args - gpdRef <- newIORef Nothing let withUnpacked inner' = do mgpd <- readIORef gpdRef - gpd <- + (gpd, childDir) <- case mgpd of - Just gpd -> return gpd + Just x -> return x Nothing -> do - log' $ "Unpacking " ++ namever - runParent getOutH "stack" ["unpack", namever] + childDir <- if thisIsCabal && pbCabalFromHead + then do + log' "Getting most recent Cabal from Git" + runParent getOutH "git" + [ "clone" + , "https://github.com/haskell/cabal" + ] + return $ sbBuildDir "cabal" "Cabal" + else do + log' $ "Unpacking " ++ namever + runParent getOutH "stack" ["unpack", namever] + return $ sbBuildDir unpack namever gpd <- createSetupHs childDir name pbAllowNewer - writeIORef gpdRef $ Just gpd + writeIORef gpdRef $ Just (gpd, childDir) - return gpd - inner' gpd + return (gpd, childDir) + inner' gpd childDir isConfiged <- newIORef False - let withConfiged inner' = withUnpacked $ \_gpd -> do + let withConfiged inner' = withUnpacked $ \_gpd childDir -> do + let run a b = do when pbVerbose $ log' (unwords (a : b)) + runIn childDir getOutH a b + cabal args = run "runghc" $ runghcArgs $ "Setup" : args + unlessM (readIORef isConfiged) $ do log' $ "Configuring " ++ namever cabal $ "configure" : configArgs writeIORef isConfiged True - inner' + inner' childDir cabal prevBuildResult <- getPreviousResult pb Build pident toBuild <- case () of @@ -470,7 +487,7 @@ ] return True | otherwise -> return False - when toBuild $ withConfiged $ do + when toBuild $ withConfiged $ \_childDir cabal -> do deletePreviousResults pb pident log' $ "Building " ++ namever @@ -496,7 +513,7 @@ && checkPrevResult prevHaddockResult pcHaddocks && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo) && not pcSkipBuild - when needHaddock $ withConfiged $ do + when needHaddock $ withConfiged $ \childDir cabal -> do log' $ "Haddocks " ++ namever hfs <- readTVarIO sbHaddockFiles haddockDeps <- atomically $ getHaddockDeps pbPlan sbHaddockDeps pname @@ -554,14 +571,14 @@ return withUnpacked runTests withUnpacked = wf testOut $ \getOutH -> do - let run = runChild getOutH - cabal args = run "runghc" $ runghcArgs $ "Setup" : args - prevTestResult <- getPreviousResult pb Test pident let needTest = pbEnableTests && checkPrevResult prevTestResult pcTests && not pcSkipBuild - when needTest $ withUnpacked $ \gpd -> do + when needTest $ withUnpacked $ \gpd childDir -> do + let run = runIn childDir getOutH + cabal args = run "runghc" $ runghcArgs $ "Setup" : args + log' $ "Test configure " ++ namever cabal $ "configure" : "--enable-tests" : configArgs @@ -603,6 +620,28 @@ (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success" _ -> return () + buildBenches withUnpacked = wf benchOut $ \getOutH -> do + prevBenchResult <- getPreviousResult pb Bench pident + let needTest = pbEnableBenches + && checkPrevResult prevBenchResult pcBenches + && not pcSkipBuild + when needTest $ withUnpacked $ \gpd childDir -> do + let run = runIn childDir getOutH + cabal args = run "runghc" $ runghcArgs $ "Setup" : args + + log' $ "Benchmark configure " ++ namever + cabal $ "configure" : "--enable-benchmarks" : configArgs + + eres <- tryAny $ do + log' $ "Benchmark build " ++ namever + cabal ["build"] + + savePreviousResult pb Bench pident $ either (const False) (const True) eres + case (eres, pcBenches) of + (Left e, ExpectSuccess) -> throwM e + (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected benchmark success" + _ -> return () + warn t = atomically $ modifyTVar sbWarningsVar (. (t:)) updateErrs exc = do @@ -640,7 +679,7 @@ ------------- Previous results -- | The previous actions that can be run -data ResultType = Build | Haddock | Test +data ResultType = Build | Haddock | Test | Bench deriving (Show, Enum, Eq, Ord, Bounded, Read) -- | The result generated on a previous run diff --git a/Stackage/ShowBuildPlan.hs b/Stackage/ShowBuildPlan.hs new file mode 100644 --- /dev/null +++ b/Stackage/ShowBuildPlan.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Stackage.ShowBuildPlan + ( Settings + , SnapshotSpec + , parseSnapshotSpec + , defaultSettings + , setMirror + , setSnapshot + , setFullDeps + , ShellCommands + , setShellCommands + , abstractCommands + , simpleCommands + , getBuildPlan + , toSimpleText + , toShellScript + , mkPackageName + ) where + +import Control.Applicative ((<|>)) +import qualified Control.Exception as E +import Control.Monad (forM_, unless, when) +import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Control.Monad.State.Strict (MonadState, execStateT, get, + modify) +import Control.Monad.Writer.Strict (execWriter, tell) +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as A +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import Data.Function (fix) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Read (decimal) +import Data.Time (Day) +import Data.Typeable (Typeable) +import Data.Version (Version) +import Data.Yaml (decodeFileEither) +import Distribution.Package (PackageName) +import Network.HTTP.Client (Manager, brRead, httpLbs, + newManager, parseUrl, + responseBody, withResponse) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Stackage.Types (BuildPlan (..), Component (..), + DepInfo (..), + PackageConstraints (..), + PackagePlan (..), SystemInfo (..), + display, mkPackageName, + sdPackages, unFlagName) +import System.Directory (createDirectoryIfMissing, + doesFileExist, + getAppUserDataDirectory, + renameFile) +import System.FilePath ((<.>), ()) +import System.IO (IOMode (WriteMode), + withBinaryFile) +import Text.Read (readMaybe) + +catchIO :: IO a -> (E.IOException -> IO a) -> IO a +catchIO = E.catch + +-- | Parse a snapshot specification from the given @Text@. +-- +-- Since 0.1.0.0 +parseSnapshotSpec :: MonadThrow m => Text -> m SnapshotSpec +parseSnapshotSpec "lts" = return $ IncompleteSpec LTSNewest +parseSnapshotSpec "nightly" = return $ IncompleteSpec NightlyNewest +parseSnapshotSpec s + | Just t <- T.stripPrefix "nightly-" s + , Just d <- readMaybe $ T.unpack t = return $ CompleteSpec $ Nightly d +parseSnapshotSpec s + | Just t <- T.stripPrefix "lts-" s + , Just x <- go t = return x + where + go t1 = do + Right (x, t2) <- Just $ decimal t1 + if T.null t2 + then return $ IncompleteSpec $ LTSMajor x + else do + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ CompleteSpec $ LTS x y +parseSnapshotSpec s = throwM $ InvalidSnapshotSpec s + +data CompleteSpec + = Nightly !Day + | LTS !Int !Int +instance Show CompleteSpec where + show (Nightly d) = "nightly-" ++ show d + show (LTS x y) = concat ["lts-", show x, ".", show y] +data IncompleteSpec + = LTSMajor !Int + | LTSNewest + | NightlyNewest + deriving Show +data SnapshotSpec + = CompleteSpec !CompleteSpec + | IncompleteSpec !IncompleteSpec + deriving Show + +resolveSpec :: Manager -> SnapshotSpec -> IO CompleteSpec +resolveSpec _ (CompleteSpec x) = return x +resolveSpec man (IncompleteSpec spec) = do + res <- httpLbs "https://www.stackage.org/download/lts-snapshots.json" man + let lbs = responseBody res + m <- + case A.eitherDecode' lbs of + Left e -> throwM $ InvalidSnapshotsJson lbs e + Right m -> return m + case Map.lookup key m of + Nothing -> throwM $ SpecNotResolved key m + Just val -> parseCompleteSpec val + where + key = + case spec of + LTSMajor m -> T.pack $ "lts-" ++ show m + LTSNewest -> "lts" + NightlyNewest -> "nightly" + +parseCompleteSpec :: MonadThrow m => Text -> m CompleteSpec +parseCompleteSpec t = + maybe (throwM $ InvalidSpec t) return $ + parseNightly <|> parseLts + where + parseNightly = do + d <- T.stripPrefix "nightly-" t + x <- readMaybe $ T.unpack d + Just $ Nightly x + parseLts = do + t1 <- T.stripPrefix "lts-" t + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + Just $ LTS x y + +data BuildPlanException + = InvalidSnapshotsJson !L.ByteString !String + | SpecNotResolved !Text !(Map Text Text) + | InvalidSpec !Text + | PackageNotFound !PackageName + | InvalidSnapshotSpec !Text + deriving (Show, Typeable) +instance Exception BuildPlanException + +-- | Settings affecting various functions in this module. +-- +-- Since 0.1.0.0 +data Settings = Settings + { _snapshot :: !SnapshotSpec + , _getManager :: !(IO Manager) + , _fullDeps :: !Bool + -- ^ include test and benchmark deps + , _mirror :: !Text + , _shellCmds :: !ShellCommands + } + +-- | How to generate commands for shell output. +-- +-- Since 0.1.0.0 +data ShellCommands = ShellCommands + { scFetch :: Text -> Text + -- ^ URL + , scUnpack :: Text -> Text + -- ^ Tarball + , scBuild :: Map Text Bool -> Text + -- ^ Flags + } + +-- | Use abstract commands like build_plan_fetch. +-- +-- See: https://github.com/fpco/stackage-server/issues/95#issuecomment-97146188 +-- +-- Since 0.1.0.0 +abstractCommands :: ShellCommands +abstractCommands = ShellCommands + { scFetch = ("build_plan_fetch " <>) + , scUnpack = ("build_plan_unpack " <>) + , scBuild = ("build_plan_build " <>) . showFlags + } + +-- | Use simple commands requiring no wrapper shell script +-- +-- Since 0.1.0.0 +simpleCommands :: ShellCommands +simpleCommands = ShellCommands + { scFetch = ("wget " <>) + , scUnpack = ("tar xf " <>) + , scBuild = \flags -> T.concat + [ T.concat + [ "runghc Setup configure --user --flags='" + , showFlags flags + , "'" + ] + , "\nrunghc Setup build" + , "\nrunghc Setup copy" + , "\nrunghc Setup register" + ] + } + +showFlags :: Map Text Bool -> Text +showFlags = + T.unwords . map go . Map.toList + where + go (name, isOn) = (if isOn then id else (T.cons '-')) name + + +-- | Set the shell commands when using shell formatting. +-- +-- Default: 'abstractCommands' +-- +-- Since 0.1.0.0 +setShellCommands :: ShellCommands -> Settings -> Settings +setShellCommands x s = s { _shellCmds = x } + +-- | Default settings, to be tweaked via setter functions. +-- +-- Since 0.1.0.0 +defaultSettings :: Settings +defaultSettings = Settings + { _snapshot = IncompleteSpec LTSNewest + , _getManager = newManager tlsManagerSettings + , _fullDeps = False + , _mirror = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" + , _shellCmds = abstractCommands + } + +-- | Set the snapshot from which to pull the build plan. +-- +-- Default: latest LTS release +-- +-- Since 0.1.0.0 +setSnapshot :: SnapshotSpec -> Settings -> Settings +setSnapshot x s = s { _snapshot = x } + +-- | Should we trace dependencies of test suites and benchmarks? +-- +-- Default: False +-- +-- Since 0.1.1.0 +setFullDeps :: Bool -> Settings -> Settings +setFullDeps x s = s { _fullDeps = x } + +-- | Set the mirror prefix for tarball downloads (shell script only). +-- +-- Default: "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" +-- +-- Since 0.1.0.0 +setMirror :: Text -> Settings -> Settings +setMirror x s = s { _mirror = x } + +yamlFP :: Manager -> SnapshotSpec -> IO FilePath +yamlFP man spec' = do + spec <- resolveSpec man spec' + root <- getAppUserDataDirectory "stackage" + `catchIO` \_ -> return "/tmp/.stackage" -- server does not set HOME + let dir = root "build-plan" + fp = dir show spec <.> "yaml" + exists <- doesFileExist fp + if exists + then return fp + else do + createDirectoryIfMissing True dir + let tmp = fp <.> "tmp" + download man spec tmp + renameFile tmp fp + return fp + +download :: Manager -> CompleteSpec -> FilePath -> IO () +download man spec dest = do + req <- parseUrl $ specUrl spec + withResponse req man $ \res -> withBinaryFile dest WriteMode $ \h -> + fix $ \loop -> do + bs <- brRead $ responseBody res + unless (S.null bs) $ S.hPut h bs >> loop + +specUrl :: CompleteSpec -> String +specUrl (LTS x y) = concat + [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-" + , show x + , "." + , show y + , ".yaml" + ] +specUrl (Nightly x) = concat + [ "https://raw.githubusercontent.com/fpco/stackage-nightly/master/nightly-" + , show x + , ".yaml" + ] + +data ToInstall = ToInstall + { tiPackage :: !PackageName + , tiVersion :: !Version + , tiIsCore :: !Bool + , tiFlags :: !(Map Text Bool) + } + deriving Show + +instance A.ToJSON ToInstall where + toJSON ti = object + [ "name" .= display (tiPackage ti) + , "version" .= display (tiVersion ti) + , "flags" .= tiFlags ti + , "is-core" .= tiIsCore ti + ] + +getBuildPlan :: Settings -> [PackageName] -> IO [ToInstall] +getBuildPlan _ [] = return [] +getBuildPlan set packages = do + man <- _getManager set + fp <- yamlFP man $ _snapshot set + bp <- decodeFileEither fp >>= either throwM return + (_, front) <- execStateT (getDeps bp (_fullDeps set) packages) (Set.empty, id) + return $ front [] + +type TheState = + ( Set PackageName + , DList ToInstall + ) +type DList a = [a] -> [a] + +getDeps :: forall f m. (MonadThrow m, MonadState TheState m, Foldable f) + => BuildPlan + -> Bool + -> f PackageName + -> m () +getDeps bp fullDeps = + F.mapM_ goName + where + goName :: PackageName -> m () + goName name = do + (s, _) <- get + when (name `Set.notMember` s) $ + case Map.lookup name $ bpPackages bp of + Just pkg -> goPkg name pkg + Nothing -> + case Map.lookup name $ siCorePackages $ bpSystemInfo bp of + Just version -> do + addToSet name + addToList name version Map.empty True + Nothing -> throwM $ PackageNotFound name + + goPkg :: PackageName -> PackagePlan -> m () + goPkg name pp = do + addToSet name + forM_ (Map.toList $ sdPackages $ ppDesc pp) $ \(name', depInfo) -> + when (includeDep depInfo) (goName name') + addToList name (ppVersion pp) + (Map.mapKeysWith const unFlagName + $ pcFlagOverrides $ ppConstraints pp) + False + + addToSet name = modify $ \(s, front) -> (Set.insert name s, front) + + addToList name version flags isCore = + modify $ \(s, front) -> (s, front . (x:)) + where + x = ToInstall + { tiPackage = name + , tiVersion = version + , tiFlags = flags + , tiIsCore = isCore + } + + includeDep di = + fullDeps || + CompLibrary `Set.member` diComponents di || + CompExecutable `Set.member` diComponents di + +toSimpleText :: [ToInstall] -> Text +toSimpleText = + T.unlines . map go + where + go ti = T.unwords + [ display $ tiPackage ti + , display $ tiVersion ti + ] + +toShellScript :: Settings -> [ToInstall] -> Text +toShellScript set packages = T.unlines $ ($ []) $ execWriter $ do + yield "#!/usr/bin/env bash\nset -eux\n" + forM_ packages $ \ti -> unless (tiIsCore ti) $ do + let prefix = T.concat + [ display $ tiPackage ti + , "-" + , display $ tiVersion ti + ] + tarball = prefix <> ".tar.gz" + mapM_ yield + [ "" + , T.concat + [ "rm -rf " + , prefix + , " " + , tarball + ] + , scFetch sc $ _mirror set <> tarball + , scUnpack sc tarball + , "cd " <> prefix + , scBuild sc $ tiFlags ti + , "cd .." + ] + where + yield x = tell (x:) + sc = _shellCmds set diff --git a/Stackage/Types.hs b/Stackage/Types.hs new file mode 100644 --- /dev/null +++ b/Stackage/Types.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | Shared types for various stackage packages. +module Stackage.Types + ( -- * Types + SnapshotType (..) + , DocMap + , PackageDocs (..) + , BuildPlan (..) + , PackagePlan (..) + , PackageConstraints (..) + , ParseFailedException (..) + , TestState (..) + , SystemInfo (..) + , Maintainer (..) + , ExeName (..) + , SimpleDesc (..) + , DepInfo (..) + , Component (..) + , CabalFileInfo (..) + -- * Helper functions + , display + , simpleParse + , unPackageName + , mkPackageName + , unFlagName + , mkFlagName + , intersectVersionRanges + ) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Arrow ((&&&)) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow, throwM) +import Data.Aeson (FromJSON (..), ToJSON (..), + object, withObject, withText, + (.!=), (.:), (.:?), (.=)) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, mappend, mempty) +import Data.Semigroup (Semigroup, (<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString, fromString) +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import Data.Time (Day) +import qualified Data.Traversable as T +import Data.Typeable (TypeRep, Typeable, typeOf) +import Data.Vector (Vector) +import Distribution.Package (PackageName (PackageName)) +import Distribution.PackageDescription (FlagName (..)) +import Distribution.System (Arch, OS) +import qualified Distribution.Text as DT +import Distribution.Version (Version, VersionRange) +import qualified Distribution.Version as C +import Safe (readMay) +import qualified Data.Binary as Bin (Binary) +import qualified Data.Binary.Tagged as Bin +import qualified Data.ByteString.Base16 as B16 +import GHC.Generics (Generic) + +data SnapshotType = STNightly + | STNightly2 !Day + | STLTS !Int !Int -- ^ major, minor + deriving (Show, Read, Eq, Ord) + +instance ToJSON SnapshotType where + toJSON STNightly = object + [ "type" .= asText "nightly" + ] + toJSON (STNightly2 day) = object + [ "type" .= asText "nightly" + , "date" .= show day + ] + toJSON (STLTS major minor) = object + [ "type" .= asText "lts" + , "major" .= major + , "minor" .= minor + ] +instance FromJSON SnapshotType where + parseJSON = withObject "SnapshotType" $ \o -> do + t <- o .: "type" + case asText t of + "nightly" -> (STNightly2 <$> (o .: "date" >>= readFail)) <|> return STNightly + "lts" -> STLTS + <$> o .: "major" + <*> o .: "minor" + _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t + where + readFail t = + case readMay t of + Nothing -> fail "read failed" + Just x -> return x + +-- | Package name is key +type DocMap = Map Text PackageDocs + +asText :: Text -> Text +asText = id + +data PackageDocs = PackageDocs + { pdVersion :: Text + , pdModules :: Map Text [Text] + -- ^ module name, path + } +instance ToJSON PackageDocs where + toJSON PackageDocs {..} = object + [ "version" .= pdVersion + , "modules" .= pdModules + ] +instance FromJSON PackageDocs where + parseJSON = withObject "PackageDocs" $ \o -> PackageDocs + <$> o .: "version" + <*> o .: "modules" + +data BuildPlan = BuildPlan + { bpSystemInfo :: SystemInfo + , bpTools :: Vector (PackageName, Version) + , bpPackages :: Map PackageName PackagePlan + , bpGithubUsers :: Map Text (Set Text) + , bpBuildToolOverrides :: Map Text (Set Text) + } + deriving (Show, Eq) + +instance ToJSON BuildPlan where + toJSON BuildPlan {..} = object + [ "system-info" .= bpSystemInfo + , "tools" .= fmap goTool bpTools + , "packages" .= Map.mapKeysWith const unPackageName bpPackages + , "github-users" .= bpGithubUsers + , "build-tool-overrides" .= bpBuildToolOverrides + ] + where + goTool (k, v) = object + [ "name" .= display k + , "version" .= display v + ] +instance FromJSON BuildPlan where + parseJSON = withObject "BuildPlan" $ \o -> do + bpSystemInfo <- o .: "system-info" + bpTools <- (o .: "tools") >>= T.mapM goTool + bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + bpGithubUsers <- o .:? "github-users" .!= mempty + bpBuildToolOverrides <- o .:? "build-tool-overrides" .!= mempty + return BuildPlan {..} + where + goTool = withObject "Tool" $ \o -> (,) + <$> ((o .: "name") >>= + either (fail . show) return . simpleParse . asText) + <*> ((o .: "version") >>= + either (fail . show) return . simpleParse . asText) + +data PackagePlan = PackagePlan + { ppVersion :: Version + , ppCabalFileInfo :: Maybe CabalFileInfo + , ppGithubPings :: Set Text + , ppUsers :: Set PackageName + , ppConstraints :: PackageConstraints + , ppDesc :: SimpleDesc + } + deriving (Show, Eq) + +instance ToJSON PackagePlan where + toJSON PackagePlan {..} = object + $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo $ + [ "version" .= asText (display ppVersion) + , "github-pings" .= ppGithubPings + , "users" .= Set.map unPackageName ppUsers + , "constraints" .= ppConstraints + , "description" .= ppDesc + ] +instance FromJSON PackagePlan where + parseJSON = withObject "PackageBuild" $ \o -> do + ppVersion <- o .: "version" + >>= either (fail . show) return + . simpleParse . asText + ppCabalFileInfo <- o .:? "cabal-file-info" + ppGithubPings <- o .:? "github-pings" .!= mempty + ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) + ppConstraints <- o .: "constraints" + ppDesc <- o .: "description" + return PackagePlan {..} + +-- | Information on the contents of a cabal file +data CabalFileInfo = CabalFileInfo + { cfiSize :: !Int + -- ^ File size in bytes + , cfiHashes :: !(Map.Map Text Text) + -- ^ Various hashes of the file contents + } + deriving (Show, Eq, Generic) +instance Bin.Binary CabalFileInfo +instance Bin.HasStructuralInfo CabalFileInfo +instance Bin.HasSemanticVersion CabalFileInfo +instance ToJSON CabalFileInfo where + toJSON CabalFileInfo {..} = object + [ "size" .= cfiSize + , "hashes" .= cfiHashes + ] +instance FromJSON CabalFileInfo where + parseJSON = withObject "CabalFileInfo" $ \o -> do + cfiSize <- o .: "size" + cfiHashes <- o .: "hashes" + return CabalFileInfo {..} + +display :: DT.Text a => a -> Text +display = fromString . DT.display + +simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a +simpleParse orig = withTypeRep $ \rep -> + case DT.simpleParse str of + Nothing -> throwM (ParseFailedException rep (pack str)) + Just v -> return v + where + str = unpack orig + + withTypeRep :: Typeable a => (TypeRep -> m a) -> m a + withTypeRep f = + res + where + res = f (typeOf (unwrap res)) + + unwrap :: m a -> a + unwrap _ = error "unwrap" + +data ParseFailedException = ParseFailedException TypeRep Text + deriving (Show, Typeable) +instance Exception ParseFailedException + +unPackageName :: PackageName -> Text +unPackageName (PackageName str) = pack str + +mkPackageName :: Text -> PackageName +mkPackageName = PackageName . unpack + +data PackageConstraints = PackageConstraints + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcBenches :: TestState + , pcHaddocks :: TestState + , pcFlagOverrides :: Map FlagName Bool + , pcEnableLibProfile :: Bool + , pcSkipBuild :: Bool + -- ^ Don't even bother building this library, useful when dealing with + -- OS-specific packages. See: + -- https://github.com/fpco/stackage-curator/issues/3 + } + deriving (Show, Eq) +instance ToJSON PackageConstraints where + toJSON PackageConstraints {..} = object $ addMaintainer + [ "version-range" .= display pcVersionRange + , "tests" .= pcTests + , "benches" .= pcBenches + + -- for backwards compatibility + , "build-benchmarks" .= + case pcBenches of + Don'tBuild -> False + _ -> True + + , "haddocks" .= pcHaddocks + , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides + , "library-profiling" .= pcEnableLibProfile + , "skip-build" .= pcSkipBuild + ] + where + addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer +instance FromJSON PackageConstraints where + parseJSON = withObject "PackageConstraints" $ \o -> do + pcVersionRange <- (o .: "version-range") + >>= either (fail . show) return . simpleParse + pcTests <- o .: "tests" + pcBenches <- o .: "benches" <|> + -- Compatibility with old build-benchmarks boolean + ((\x -> if x then ExpectFailure else Don'tBuild) + <$> (o .: "build-benchmarks")) + pcHaddocks <- o .: "haddocks" + pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" + pcMaintainer <- o .:? "maintainer" + pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") + pcSkipBuild <- o .:? "skip-build" .!= False + return PackageConstraints {..} + +data TestState = ExpectSuccess + | ExpectFailure + | Don'tBuild -- ^ when the test suite will pull in things we don't want + deriving (Show, Eq, Ord, Bounded, Enum) + +testStateToText :: TestState -> Text +testStateToText ExpectSuccess = "expect-success" +testStateToText ExpectFailure = "expect-failure" +testStateToText Don'tBuild = "do-not-build" + +instance ToJSON TestState where + toJSON = toJSON . testStateToText +instance FromJSON TestState where + parseJSON = withText "TestState" $ \t -> + case HashMap.lookup t states of + Nothing -> fail $ "Invalid state: " ++ unpack t + Just v -> return v + where + states = HashMap.fromList + $ map (\x -> (testStateToText x, x)) [minBound..maxBound] + +data SystemInfo = SystemInfo + { siGhcVersion :: Version + , siOS :: OS + , siArch :: Arch + , siCorePackages :: Map PackageName Version + , siCoreExecutables :: Set ExeName + } + deriving (Show, Eq, Ord) +instance ToJSON SystemInfo where + toJSON SystemInfo {..} = object + [ "ghc-version" .= display siGhcVersion + , "os" .= display siOS + , "arch" .= display siArch + , "core-packages" .= Map.mapKeysWith const unPackageName (fmap display siCorePackages) + , "core-executables" .= siCoreExecutables + ] +instance FromJSON SystemInfo where + parseJSON = withObject "SystemInfo" $ \o -> do + let helper name = (o .: name) >>= either (fail . show) return . simpleParse + siGhcVersion <- helper "ghc-version" + siOS <- helper "os" + siArch <- helper "arch" + siCorePackages <- (o .: "core-packages") >>= goPackages + siCoreExecutables <- o .: "core-executables" + return SystemInfo {..} + where + goPackages = either (fail . show) return + . T.mapM simpleParse + . Map.mapKeysWith const mkPackageName + +unFlagName :: FlagName -> Text +unFlagName (FlagName str) = pack str + +mkFlagName :: Text -> FlagName +mkFlagName = FlagName . unpack + +newtype Maintainer = Maintainer { unMaintainer :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +-- | Name of an executable. +newtype ExeName = ExeName { unExeName :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +-- | A simplified package description that tracks: +-- +-- * Package dependencies +-- +-- * Build tool dependencies +-- +-- * Provided executables +-- +-- It has fully resolved all conditionals +data SimpleDesc = SimpleDesc + { sdPackages :: Map PackageName DepInfo + , sdTools :: Map ExeName DepInfo + , sdProvidedExes :: Set ExeName + , sdModules :: Set Text + -- ^ modules exported by the library + } + deriving (Show, Eq) +instance Monoid SimpleDesc where + mempty = SimpleDesc mempty mempty mempty mempty + mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc + (Map.unionWith (<>) a w) + (Map.unionWith (<>) b x) + (c <> y) + (d <> z) +instance ToJSON SimpleDesc where + toJSON SimpleDesc {..} = object + [ "packages" .= Map.mapKeysWith const unPackageName sdPackages + , "tools" .= Map.mapKeysWith const unExeName sdTools + , "provided-exes" .= sdProvidedExes + , "modules" .= sdModules + ] +instance FromJSON SimpleDesc where + parseJSON = withObject "SimpleDesc" $ \o -> do + sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") + sdProvidedExes <- o .: "provided-exes" + sdModules <- o .: "modules" + return SimpleDesc {..} + +data DepInfo = DepInfo + { diComponents :: Set Component + , diRange :: VersionRange + } + deriving (Show, Eq) + +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo + (a <> b) + (intersectVersionRanges x y) +instance ToJSON DepInfo where + toJSON DepInfo {..} = object + [ "components" .= diComponents + , "range" .= display diRange + ] +instance FromJSON DepInfo where + parseJSON = withObject "DepInfo" $ \o -> do + diComponents <- o .: "components" + diRange <- o .: "range" >>= either (fail . show) return . simpleParse + return DepInfo {..} + +data Component = CompLibrary + | CompExecutable + | CompTestSuite + | CompBenchmark + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +compToText :: Component -> Text +compToText CompLibrary = "library" +compToText CompExecutable = "executable" +compToText CompTestSuite = "test-suite" +compToText CompBenchmark = "benchmark" + +instance ToJSON Component where + toJSON = toJSON . compToText +instance FromJSON Component where + parseJSON = withText "Component" $ \t -> maybe + (fail $ "Invalid component: " ++ unpack t) + return + (HashMap.lookup t comps) + where + comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound] + +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -33,7 +33,7 @@ , pcMaintainer = moldPC >>= pcMaintainer , pcTests = maybe ExpectSuccess pcTests moldPC , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC - , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC + , pcBenches = maybe ExpectSuccess pcBenches moldPC , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC , pcEnableLibProfile = maybe True pcEnableLibProfile moldPC , pcSkipBuild = maybe False pcSkipBuild moldPC diff --git a/app/stackage-build-plan.hs b/app/stackage-build-plan.hs new file mode 100644 --- /dev/null +++ b/app/stackage-build-plan.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Data.Aeson (toJSON) +import Data.Aeson.Encode (encodeToTextBuilder) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (toLazyText) +import qualified Data.Text.Lazy.IO as TLIO +import Options.Applicative +import Paths_stackage_curator (version) +import Stackage.ShowBuildPlan +import Stackage.CLI (simpleOptions, simpleVersion) + +main :: IO () +main = do + ((set, render, packages), ()) <- simpleOptions + $(simpleVersion version) + "Calculate and print (in different formats) Stackage build plans" + "Calculate and print (in different formats) Stackage build plans" + options + empty + tis <- getBuildPlan set $ map (mkPackageName . T.pack) packages + TLIO.putStr $ render set tis + where + options = (,,) + <$> setOptions + <*> renderOptions + <*> some (argument str (metavar "PACKAGES...")) + + mkSettings mmirror msnapshot mcommands = + maybe id (setMirror . T.pack) mmirror + $ maybe id setSnapshot msnapshot + $ maybe id setShellCommands mcommands + $ defaultSettings + + setOptions = mkSettings + <$> ((fmap Just $ strOption + ( long "mirror" + <> help "Mirror to download packages from" + <> metavar "URL" + )) <|> pure Nothing) + <*> ((fmap Just $ option readSnapshot + ( long "snapshot" + <> help "Which snapshot to pull the build plan from" + <> metavar "SNAPSHOT" + )) <|> pure Nothing) + <*> ((fmap Just $ option readCommands + ( long "commands" + <> help "Shell commands do use: abstract, simple" + <> metavar "COMMANDS" + )) <|> pure Nothing) + + readSnapshot = + str >>= + either (fail . show) return . parseSnapshotSpec . T.pack + + readCommands = do + s <- str + case s of + "abstract" -> return abstractCommands + "simple" -> return simpleCommands + _ -> fail $ "Invalid commands: " ++ s + + renderOptions = + (option readRender + ( long "format" + <> help "Output format: shell, simple, json" + <> metavar "FORMAT" + )) + + readRender = do + x <- str + case x of + "shell" -> return $ \set tis -> + TL.fromStrict $ toShellScript set tis + "simple" -> return $ \_set tis -> + TL.fromStrict $ toSimpleText tis + "json" -> return $ \_set tis -> + toLazyText $ encodeToTextBuilder $ toJSON tis + _ -> fail $ "Invalid renderer: " ++ x diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -41,6 +41,7 @@ <*> many constraint <*> many addPackage <*> many expectTestFailure + <*> many expectBenchFailure <*> many expectHaddockFailure ) addCommand "check" "Verify that a plan is valid" id @@ -80,6 +81,7 @@ <*> target <*> jobs <*> skipTests + <*> skipBenches <*> skipHaddock <*> skipHoogle <*> enableLibraryProfiling @@ -87,6 +89,7 @@ <*> verbose <*> allowNewer <*> noRebuildCabal + <*> cabalFromHead installFlags :: Parser InstallFlags @@ -131,6 +134,11 @@ fmap not (switch + (long "skip-benches" <> + help "Skip building the benchmarks")) <*> + fmap + not + (switch (long "skip-haddock" <> help "Skip generating haddock documentation")) <*> switch @@ -157,6 +165,11 @@ (long "no-rebuild-cabal" <> help "Ignore new Cabal version from the plan and use whatever's in the database. Useful for testing pre-release GHCs") + cabalFromHead = + switch + (long "cabal-from-head" <> + help "Get the latest Cabal from Git HEAD, used for testing Cabal itself") + jobs = (fmap Just (option auto @@ -169,6 +182,11 @@ (long "skip-tests" ++ help "Skip build and running the test suites") + skipBenches = + switch + (long "skip-benches" ++ + help "Skip building the benchmarks") + skipHaddock = switch (long "skip-haddock" ++ @@ -277,6 +295,12 @@ (long "expect-test-failure" ++ metavar "PACKAGE-NAME" ++ help "Newly expected test failures") + + expectBenchFailure = + option packageRead + (long "expect-bench-failure" ++ + metavar "PACKAGE-NAME" ++ + help "Newly expected benchmark build failures") expectHaddockFailure = option packageRead diff --git a/app/upload-index.hs b/app/upload-index.hs deleted file mode 100644 --- a/app/upload-index.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -import Stackage.Curator.UploadIndex -import Stackage.Prelude - -main :: IO () -main = do - uploadIndex "lts-5.10.yaml" (TargetLts 5 10) "bucket" "prefix" diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.13.3 +version: 0.14.0 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -14,6 +14,11 @@ ChangeLog.md test/test-build-constraints.yaml +flag monad_unlift_0_2 + default: True + manual: False + description: Use monad-unlift 0.2 or newer + library default-language: Haskell2010 other-extensions: TemplateHaskell @@ -36,6 +41,8 @@ Stackage.CompleteBuild Stackage.Curator.UploadDocs Stackage.Curator.UploadIndex + Stackage.ShowBuildPlan + Stackage.Types build-depends: base >= 4 && < 5 , containers , Cabal >= 1.14 @@ -71,8 +78,6 @@ , semigroups , xml-conduit , conduit - , stackage-types >= 1.2 - , monad-unlift >= 0.1.1 , blaze-html , html-conduit @@ -90,14 +95,19 @@ , lucid , binary , binary-tagged + , binary-orphans , syb + , safe + , vector + , exceptions + , unordered-containers + , hashable -executable upload-index - default-language: Haskell2010 - hs-source-dirs: app - main-is: upload-index.hs - build-depends: base - , stackage-curator + if flag(monad_unlift_0_2) + build-depends: monad-unlift >= 0.2 + , monad-unlift-ref >= 0.2 + else + build-depends: monad-unlift >= 0.1.1 && < 0.2 executable stackage-curator default-language: Haskell2010 @@ -115,6 +125,19 @@ , http-client-tls , text ghc-options: -rtsopts -threaded -with-rtsopts=-N + +executable stackage-build-plan + main-is: stackage-build-plan.hs + other-modules: Paths_stackage_curator + hs-source-dirs: app + build-depends: base + , stackage-curator + , stackage-cli + , optparse-applicative + , text + , aeson + default-language: Haskell2010 + other-extensions: TemplateHaskell test-suite spec type: exitcode-stdio-1.0 diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -109,6 +109,7 @@ dummyPackage v deps = PackagePlan {ppVersion = Version v [] + ,ppCabalFileInfo = Nothing ,ppGithubPings = mempty ,ppUsers = mempty ,ppConstraints = @@ -117,7 +118,7 @@ ,pcMaintainer = Nothing ,pcTests = Don'tBuild ,pcHaddocks = Don'tBuild - ,pcBuildBenchmarks = False + ,pcBenches = Don'tBuild ,pcFlagOverrides = mempty ,pcEnableLibProfile = False ,pcSkipBuild = False}