stackage-curator 0.13.3 → 0.14.0
raw patch · 15 files changed
+1118/−50 lines, 15 filesdep +binary-orphansdep +exceptionsdep +hashabledep −stackage-typesdep ~monad-unliftdep ~optparse-applicativenew-component:exe:stackage-build-plan
Dependencies added: binary-orphans, exceptions, hashable, monad-unlift-ref, safe, unordered-containers, vector
Dependencies removed: stackage-types
Dependency ranges changed: monad-unlift, optparse-applicative
Files
- ChangeLog.md +8/−0
- Stackage/BuildConstraints.hs +7/−1
- Stackage/BuildPlan.hs +2/−1
- Stackage/CompleteBuild.hs +11/−3
- Stackage/InstallBuild.hs +3/−0
- Stackage/PackageIndex.hs +32/−3
- Stackage/PerformBuild.hs +62/−23
- Stackage/ShowBuildPlan.hs +415/−0
- Stackage/Types.hs +439/−0
- Stackage/UpdateBuildPlan.hs +1/−1
- app/stackage-build-plan.hs +80/−0
- app/stackage.hs +24/−0
- app/upload-index.hs +0/−8
- stackage-curator.cabal +32/−9
- test/Stackage/BuildPlanSpec.hs +2/−1
ChangeLog.md view
@@ -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
Stackage/BuildConstraints.hs view
@@ -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
Stackage/BuildPlan.hs view
@@ -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
Stackage/CompleteBuild.hs view
@@ -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"
Stackage/InstallBuild.hs view
@@ -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.
Stackage/PackageIndex.hs view
@@ -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
Stackage/PerformBuild.hs view
@@ -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
+ Stackage/ShowBuildPlan.hs view
@@ -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
+ Stackage/Types.hs view
@@ -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
Stackage/UpdateBuildPlan.hs view
@@ -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
+ app/stackage-build-plan.hs view
@@ -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
app/stackage.hs view
@@ -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
− app/upload-index.hs
@@ -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"
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.13.3+version: 0.14.0 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@@ -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
test/Stackage/BuildPlanSpec.hs view
@@ -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}