stackage-curator 0.8.1 → 0.9.0
raw patch · 10 files changed
+464/−143 lines, 10 filesdep +amazonkadep +amazonka-coredep +amazonka-s3dep ~classy-prelude-conduitdep ~monad-unliftdep ~stackage-types
Dependencies added: amazonka, amazonka-core, amazonka-s3, base16-bytestring, blaze-html, byteable, cryptohash, cryptohash-conduit, html-conduit, mime-types, resourcet, stackage-install, stackage-metadata, xml-types
Dependency ranges changed: classy-prelude-conduit, monad-unlift, stackage-types, xml-conduit
Files
- ChangeLog.md +4/−0
- Stackage/BuildConstraints.hs +20/−0
- Stackage/CompleteBuild.hs +92/−128
- Stackage/Curator/UploadDocs.hs +210/−0
- Stackage/Curator/UploadIndex.hs +84/−0
- Stackage/Prelude.hs +6/−3
- Stackage/ServerBundle.hs +2/−0
- Stackage/UpdateBuildPlan.hs +1/−1
- app/stackage.hs +23/−6
- stackage-curator.cabal +22/−5
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.8.2++* `upload-docs` command+ ## 0.8.1 * Redefine core packages [#395](https://github.com/fpco/stackage/issues/395)
Stackage/BuildConstraints.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -109,6 +110,7 @@ , cfPackages :: Map Maintainer (Vector Dependency) , cfGithubUsers :: Map Text (Set Text) , cfSkippedLibProfiling :: Set PackageName+ , cfGhcMajorVersion :: Maybe (Int, Int) } instance FromJSON ConstraintFile where@@ -123,6 +125,7 @@ >>= mapM (mapM toDep) . Map.mapKeysWith const Maintainer cfGithubUsers <- o .: "github-users"+ cfGhcMajorVersion <- o .:? "ghc-major-version" >>= mapM parseMajorVersion return ConstraintFile {..} where goFlagMap = Map.mapKeysWith const FlagName@@ -132,9 +135,26 @@ toDep :: Monad m => Text -> m Dependency toDep = either (fail . show) return . simpleParse + parseMajorVersion t =+ case versionBranch <$> simpleParse t of+ Just [x, y] -> return (x, y)+ _ -> fail $ "Invalid GHC major version: " ++ unpack t++data MismatchedGhcVersion = MismatchedGhcVersion+ { mgvGhcOnPath :: !Version+ , mgvExpectedMajor :: !Int+ , mgcExpectedMinor :: !Int+ }+ deriving (Show, Typeable)+instance Exception MismatchedGhcVersion+ toBC :: ConstraintFile -> IO BuildConstraints toBC ConstraintFile {..} = do bcSystemInfo <- getSystemInfo+ forM_ cfGhcMajorVersion $ \(major, minor) ->+ case versionBranch $ siGhcVersion bcSystemInfo of+ major':minor':_ | major == major' && minor == minor' -> return ()+ _ -> throwIO $ MismatchedGhcVersion (siGhcVersion bcSystemInfo) major minor return BuildConstraints {..} where combine (maintainer, range1) (_, range2) =
Stackage/CompleteBuild.hs view
@@ -16,6 +16,8 @@ , upload , hackageDistro , uploadGithub+ , uploadDocs'+ , checkTargetAvailable ) where import System.Directory (getAppUserDataDirectory)@@ -45,6 +47,7 @@ import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift) import Data.Function (fix) import Control.Concurrent.Async (Concurrently (..))+import Stackage.Curator.UploadDocs (uploadDocs) -- | Flags passed in from the command line. data BuildFlags = BuildFlags@@ -89,11 +92,11 @@ -> FilePath nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml" -nightlySettings :: Text -- ^ day+nightlySettings :: Day -> BuildFlags -> BuildPlan -> Settings-nightlySettings day bf plan' = Settings+nightlySettings day' bf plan' = Settings { planFile = fromMaybe (nightlyPlanFile day) (bfPlanFile bf) , buildDir = fpFromText $ "builds/nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day@@ -107,13 +110,14 @@ , plan = plan' , postBuild = return () , distroName = "Stackage"- , snapshotType = STNightly+ , snapshotType = STNightly2 day' , bundleDest = fromMaybe (fpFromText $ "stackage-nightly-" ++ day ++ ".bundle") (bfBundleDest bf) } where slug' = "nightly-" ++ day+ day = tshow day' parseGoal :: MonadThrow m => BumpType@@ -140,77 +144,6 @@ deriving (Show, Typeable) instance Exception ParseGoalFailure -getSettings :: Manager -> BuildFlags -> BuildType -> Maybe FilePath -> IO Settings-getSettings man bf Nightly mplanFile = do- day <- tshow . utctDay <$> getCurrentTime- plan' <- case mplanFile of- Nothing -> do- bc <- defaultBuildConstraints man- pkgs <- getLatestAllowedPlans bc- newBuildPlan pkgs bc- Just file -> decodeFileEither (fpToString file) >>= either throwIO return- return $ nightlySettings day bf plan'-getSettings man bf (LTS bumpType goal) Nothing = do- matchesGoal <- parseGoal bumpType goal- Option mlts <- fmap (fmap getMax) $ runResourceT- $ sourceDirectory "."- $= concatMapC (parseLTSVer . filename)- $= filterC matchesGoal- $$ foldMapC (Option . Just . Max)-- (new, plan') <- case bumpType of- Major -> do- let new =- case mlts of- Nothing -> LTSVer 0 0- Just (LTSVer x _) -> LTSVer (x + 1) 0- bc <- defaultBuildConstraints man- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc- return (new, plan')- Minor -> do- old <- maybe (error "No LTS plans found in current directory") return mlts- oldplan <- decodeFileEither (fpToString $ renderLTSVer old)- >>= either throwM return- let new = incrLTSVer old- let bc = updateBuildConstraints oldplan- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc- return (new, plan')-- let newfile = renderLTSVer new-- return Settings- { planFile = fromMaybe newfile (bfPlanFile bf)- , buildDir = fpFromText $ "builds/lts"- , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new- , title = \ghcVer -> concat- [ "LTS Haskell "- , tshow new- , ", GHC "- , ghcVer- ]- , slug = "lts-" ++ tshow new- , plan = plan'- , postBuild = do- let git args = withCheckedProcess- (proc "git" args) $ \ClosedStream Inherited Inherited ->- return ()- putStrLn "Committing new LTS file to Git"- git ["add", fpToString newfile]- git ["commit", "-m", "Added new LTS release: " ++ show new]- when (bfGitPush bf) $ do- putStrLn "Pushing to Git repository"- git ["push"]- , distroName = "LTSHaskell"- , snapshotType =- case new of- LTSVer x y -> STLTS x y- , bundleDest = fromMaybe- (fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle")- (bfBundleDest bf)- }- data LTSVer = LTSVer !Int !Int deriving (Eq, Ord) instance Show LTSVer where@@ -239,7 +172,7 @@ putStrLn $ "Creating plan for: " ++ tshow target bc <- case target of- TargetMinor x y -> do+ TargetLts x y | y /= 0 -> do let url = concat [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-" , show x@@ -426,48 +359,17 @@ where distroName = case target of- TargetNightly -> "Stackage"- TargetMajor _ -> "LTSHaskell"- TargetMinor _ _ -> "LTSHaskell"--uploadGithub- :: FilePath -- ^ plan file- -> Target- -> IO ()-uploadGithub planFile target = do- let repoUrl =- case target of- TargetNightly -> "git@github.com:fpco/stackage-nightly"- _ -> "git@github.com:fpco/lts-haskell"-- root <- fpFromString <$> getAppUserDataDirectory "stackage-curator"+ TargetNightly _ -> "Stackage"+ TargetLts _ _ -> "LTSHaskell" - now <- getCurrentTime+checkoutRepo :: Target -> IO ([String] -> IO (), FilePath, FilePath)+checkoutRepo target = do+ root <- fmap (</> "curator") $ fpFromString <$> getAppUserDataDirectory "stackage" let repoDir = case target of- TargetNightly -> root </> "stackage-nightly"- _ -> root </> "lts-haskell"-- destFP =- case target of- TargetNightly -> repoDir </> (fpFromString $ concat- [ "nightly-"- , show $ utctDay now- , ".yaml"- ])- TargetMajor x -> repoDir </> (fpFromString $ concat- [ "lts-"- , show x- , ".0.yaml"- ])- TargetMinor x y -> repoDir </> (fpFromString $ concat- [ "lts-"- , show x- , "."- , show y- , ".yaml"- ])+ TargetNightly _ -> root </> "stackage-nightly"+ TargetLts _ _ -> root </> "lts-haskell" runIn wdir cmd args = do putStrLn $ concat@@ -482,6 +384,24 @@ git = runIn repoDir "git" + name =+ case target of+ TargetNightly day -> fpFromString $ concat+ [ "nightly-"+ , show day+ , ".yaml"+ ]+ TargetLts x y -> fpFromString $ concat+ [ "lts-"+ , show x+ , "."+ , show y+ , ".yaml"+ ]++ destFPPlan = repoDir </> name+ destFPDocmap = repoDir </> "docs" </> name+ exists <- isDirectory repoDir if exists then do@@ -491,9 +411,33 @@ createTree $ parent repoDir runIn "." "git" ["clone", repoUrl, fpToString repoDir] - runResourceT $ sourceFile planFile $$ (sinkFile destFP :: Sink ByteString (ResourceT IO) ())- git ["add", fpToString destFP]- git ["commit", "-m", "Checking in " ++ fpToString (filename destFP)]+ whenM (liftIO $ isFile destFPPlan)+ $ error $ "File already exists: " ++ fpToString destFPPlan+ whenM (liftIO $ isFile destFPDocmap)+ $ error $ "File already exists: " ++ fpToString destFPDocmap++ return (git, destFPPlan, destFPDocmap)+ where+ repoUrl =+ case target of+ TargetNightly _ -> "git@github.com:fpco/stackage-nightly"+ TargetLts _ _ -> "git@github.com:fpco/lts-haskell"++uploadGithub+ :: FilePath -- ^ plan file+ -> FilePath -- ^ docmap file+ -> Target+ -> IO ()+uploadGithub planFile docmapFile target = do+ (git, destFPPlan, destFPDocmap) <- checkoutRepo target++ createTree $ parent destFPDocmap+ runResourceT $ do+ sourceFile planFile $$ (sinkFile destFPPlan :: Sink ByteString (ResourceT IO) ())+ sourceFile docmapFile $$ (sinkFile destFPDocmap :: Sink ByteString (ResourceT IO) ())++ git ["add", fpToString destFPPlan, fpToString destFPDocmap]+ git ["commit", "-m", "Checking in " ++ fpToString (basename destFPPlan)] git ["push", "origin", "HEAD:master"] upload@@ -512,8 +456,29 @@ } putStrLn $ "New snapshot available at: " ++ res +uploadDocs' :: Target+ -> FilePath -- ^ bundle file+ -> IO ()+uploadDocs' target bundleFile = do+ name <-+ case target of+ TargetNightly day -> return $ "nightly-" ++ tshow day+ TargetLts x y -> return $ concat ["lts-", tshow x, ".", tshow y]+ uploadDocs+ (installDest target </> "doc")+ bundleFile+ name+ "haddock.stackage.org"++installDest :: Target -> FilePath+installDest target =+ case target of+ TargetNightly _ -> "builds/nightly"+ TargetLts x _ -> fpFromText $ "builds/lts-" ++ tshow x+ makeBundle :: FilePath -- ^ plan file+ -> FilePath -- ^ docmap file -> FilePath -- ^ bundle file -> Target -> Maybe Int -- ^ jobs@@ -526,24 +491,19 @@ -> Bool -- ^ allow-newer? -> IO () makeBundle- planFile bundleFile target mjobs skipTests skipHaddocks skipHoogle+ planFile docmapFile bundleFile target mjobs skipTests skipHaddocks skipHoogle enableLibraryProfiling enableExecutableDynamic verbose allowNewer = do plan <- decodeFileEither (fpToString planFile) >>= either throwM return jobs <- maybe getNumCapabilities return mjobs let pb = PerformBuild { pbPlan = plan- , pbInstallDest =- case target of- TargetNightly -> "builds/nightly"- TargetMajor x -> fpFromText $ "builds/lts-" ++ tshow x- TargetMinor x _ -> fpFromText $ "builds/lts-" ++ tshow x+ , pbInstallDest = installDest target , pbLog = hPut stdout , pbLogDir = case target of- TargetNightly -> "logs/nightly"- TargetMajor x -> fpFromText $ "logs/lts-" ++ tshow x- TargetMinor x _ -> fpFromText $ "logs/lts-" ++ tshow x+ TargetNightly _ -> "logs/nightly"+ TargetLts x _ -> fpFromText $ "logs/lts-" ++ tshow x , pbJobs = jobs , pbGlobalInstall = False , pbEnableTests = not skipTests@@ -563,11 +523,11 @@ { cb2Plan = plan , cb2Type = case target of- TargetNightly -> STNightly- TargetMajor x -> STLTS x 0- TargetMinor x y -> STLTS x y+ TargetNightly day -> STNightly2 day+ TargetLts x y -> STLTS x y , cb2DocsDir = pbDocDir pb , cb2Dest = bundleFile+ , cb2DocmapFile = docmapFile } fetch :: FilePath -> IO ()@@ -633,3 +593,7 @@ workers 1 = Concurrently worker workers i = Concurrently worker *> workers (i - 1) liftBase $ runConcurrently $ workers cnt++-- | Check if the given target is already used in the Github repos+checkTargetAvailable :: Target -> IO ()+checkTargetAvailable = void . checkoutRepo
+ Stackage/Curator/UploadDocs.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+-- | Upload Haddock documentation to S3.+module Stackage.Curator.UploadDocs+ ( uploadDocs+ , upload+ ) where+import ClassyPrelude.Conduit+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import Control.Monad.Trans.Resource (liftResourceT)+import Control.Monad.Trans.RWS.Ref (MonadRWS, get, modify, put,+ runRWSIORefT, tell)+import Crypto.Hash (Digest, SHA256)+import Crypto.Hash.Conduit (sinkHash)+import Data.Byteable (toBytes)+import qualified Data.ByteString.Base16 as B16+import Data.Conduit.Zlib (WindowBits (WindowBits),+ compress)+import Data.XML.Types (Content (ContentText), Event (EventBeginDoctype, EventEndDoctype, EventBeginElement),+ Name)+import Distribution.Package (PackageIdentifier (..))+import qualified Filesystem as F+import qualified Filesystem.Path.CurrentOS as F+import Network.AWS (Credentials (Discover), Env,+ Region (NorthVirginia), getEnv,+ send)+import Network.AWS.Data (toBody)+import Network.AWS.S3 (ObjectCannedACL (PublicRead),+ poACL, poCacheControl,+ poContentEncoding,+ poContentType, putObject)+import Network.Mime (defaultMimeLookup)+import Stackage.Types (simpleParse)+import Text.Blaze.Html (toHtml)+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.HTML.DOM (eventConduit)+import Text.XML (fromEvents)++upload :: (MonadResource m)+ => Bool -- ^ compression?+ -> Env+ -> Text+ -> Text+ -> Consumer ByteString m ()+upload toCompress env bucket name = do+ let mime = defaultMimeLookup name++ body <-+ if toCompress+ then compress 9 (WindowBits 31) =$= sinkLazy+ else sinkLazy++ let po = set poContentType (Just $ decodeUtf8 mime)+ $ (if toCompress+ then set poContentEncoding (Just "gzip")+ else id)+ $ set poCacheControl (Just "maxage=31536000")+ $ set poACL (Just PublicRead)+ $ putObject (toBody body) bucket name+ putStrLn $ "Sending " ++ name+ eres <- liftResourceT $ send env po+ case eres of+ Left e -> error $ show e+ Right _ -> return ()++-- | Uses 'getEnv' for S3 credentials.+uploadDocs :: FilePath -- ^ directory containing docs+ -> FilePath -- ^ the bundle file+ -> Text -- ^ name of current docs, used as prefix in object names+ -> Text -- ^ bucket name+ -> IO ()+uploadDocs input' bundleFile name bucket = do+ env <- getEnv NorthVirginia Discover++ unlessM (F.isDirectory input') $ error $ "Could not find directory: " ++ show input'+ input <- fmap (</> "") $ F.canonicalizePath input'++ let inner = sourceDirectoryDeep False input $$ mapM_C (go input name)+ runResourceT $ do+ ((), _, hoogles) <- runRWSIORefT inner (env, bucket) mempty++ lbs <- liftIO $ fmap Tar.write $ mapM toEntry $ toList hoogles+ flip runReaderT (env, bucket) $ do+ upload' True (name ++ "/hoogle/orig.tar") $ sourceLazy lbs+ upload' False (name ++ "/bundle.tar.xz") $ sourceFile bundleFile++-- | Create a TAR entry for each Hoogle txt file. Unfortunately doesn't stream.+toEntry :: FilePath -> IO Tar.Entry+toEntry fp = do+ tp <- either error return $ Tar.toTarPath False $ fpToString $ F.filename fp+ Tar.packFileEntry (fpToString fp) tp++upload' :: (MonadResource m, MonadReader (Env, Text) m)+ => Bool -- ^ compress?+ -> Text -- ^ S3 key+ -> Source (ResourceT IO) ByteString+ -> m ()+upload' toCompress name src = do+ (env, bucket) <- ask+ liftResourceT $ src $$ upload toCompress env bucket name++isHoogleFile :: FilePath -> FilePath -> Bool+isHoogleFile input fp' = fromMaybe False $ do+ fp <- F.stripPrefix input fp'+ [dir, name] <- Just $ F.splitDirectories fp+ pkgver <- stripSuffix "/" $ fpToText dir+ (fpToText -> pkg, ["txt"]) <- Just $ F.splitExtensions name+ PackageIdentifier pkg1 _ver <- simpleParse pkgver+ pkg2 <- simpleParse pkg+ return $ pkg1 == pkg2++go :: M m+ => FilePath -- ^ prefix for all input+ -> Text -- ^ upload name+ -> FilePath -- ^ current file+ -> m ()+go input name fp+ | isHoogleFile input fp = tell $! singletonSet fp+ | hasExtension fp "html" = do+ doc <- sourceFile fp+ $= eventConduit+ $= (do+ yield (Nothing, EventBeginDoctype "html" Nothing)+ yield (Nothing, EventEndDoctype)+ mapMC $ \e -> do+ e' <- goEvent fp toRoot e+ return (Nothing, e')+ )+ $$ fromEvents++ -- Sink to a Document and then use blaze-html to render to avoid using+ -- XML rendering rules (e.g., empty elements)+ upload' True key $ sourceLazy (renderHtml $ toHtml doc)+ | any (hasExtension fp) $ words "css js png svg gif" = void $ getName fp+ | otherwise = upload' True key $ sourceFile fp+ where+ Just suffix = F.stripPrefix input fp+ toRoot = concat $ asList $ replicate (length $ F.splitDirectories suffix) $ asText "../"+ key = name ++ "/" ++ fpToText suffix++goEvent :: M m+ => FilePath -- HTML file path+ -> Text -- ^ relative prefix to root+ -> Event+ -> m Event+goEvent htmlfp toRoot (EventBeginElement name attrs) =+ EventBeginElement name <$> mapM (goAttr htmlfp toRoot) attrs+goEvent _ _ e = return e++goAttr :: M m+ => FilePath -- ^ HTML file path+ -> Text -- ^ relative prefix to root+ -> (Name, [Content])+ -> m (Name, [Content])+goAttr htmlfp toRoot pair@(name, [ContentText value])+ | isRef name && not (".html" `isSuffixOf` value) = do+ let fp = F.parent htmlfp </> fpFromText value+ exists <- liftIO $ F.isFile fp+ if exists+ then do+ x <- getName fp+ return (name, [ContentText $ toRoot ++ x])+ else return pair+goAttr _ _ pair = return pair++isRef :: Name -> Bool+isRef "href" = True+isRef "src" = True+isRef _ = False++type M m = ( MonadRWS (Env, Text) (Set FilePath) (Map FilePath Text, Set Text) m+ , MonadResource m+ )++getName :: M m => FilePath -> m Text+getName src = do+ (m, _) <- get+ case lookup src m of+ Just x -> return x+ Nothing -> do+ x <- toHash src+ modify $ \(m, s) -> (insertMap src x m, s)+ return x++toHash :: M m => FilePath -> m Text+toHash src = do+ (digest, lbs) <- sourceFile src $$ sink+ let hash' = decodeUtf8 $ B16.encode $ toBytes (digest :: Digest SHA256)+ name = fpToText $ F.addExtensions ("byhash" </> fpFromText hash') (F.extensions src)+ (m, s) <- get+ unless (name `member` s) $ do+ put (m, insertSet name s)+ upload' True name $ sourceLazy lbs+ return name+ where+ sink = getZipSink $ (,)+ <$> ZipSink sinkHash+ <*> ZipSink sinkLazy++type Setter s a = (a -> Identity a) -> s -> Identity s++set :: Setter s a -> a -> s -> s+set l a s = runIdentity $ l (const $ Identity a) s
+ Stackage/Curator/UploadIndex.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+module Stackage.Curator.UploadIndex+ ( uploadIndex+ ) where++import System.Directory (getAppUserDataDirectory)+import Distribution.Package (Dependency)+import Filesystem (isDirectory, createTree, isFile, rename)+import Filesystem.Path (parent)+import Control.Concurrent (threadDelay, getNumCapabilities)+import Control.Concurrent.Async (withAsync)+import Data.Default.Class (def)+import Data.Semigroup (Max (..), Option (..))+import Data.Text.Read (decimal)+import Data.Time+import Data.Yaml (decodeFileEither, encodeFile, decodeEither')+import Network.HTTP.Client+import Network.HTTP.Client.Conduit (bodyReaderSource)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.CheckBuildPlan+import Stackage.PerformBuild+import Stackage.Prelude+import Stackage.ServerBundle+import Stackage.UpdateBuildPlan+import Stackage.Upload+import System.Environment (lookupEnv)+import System.IO (BufferMode (LineBuffering), hSetBuffering)+import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift)+import Data.Function (fix)+import Control.Concurrent.Async (Concurrently (..))+import Stackage.Curator.UploadDocs (uploadDocs)+import Stackage.Install (defaultIndexLocation)+import Stackage.PackageIndex.Conduit+import qualified Codec.Archive.Tar as Tar+import Data.Conduit.Lazy (lazyConsume)+import Codec.Compression.GZip (compress)+import Network.AWS (Credentials (Discover), Env,+ Region (NorthVirginia), getEnv,+ send)+import Network.AWS.Data (toBody)+import Network.AWS.S3 (ObjectCannedACL (PublicRead),+ poACL, poCacheControl,+ poContentEncoding,+ poContentType, putObject)+import Stackage.Curator.UploadDocs (upload)++uploadIndex+ :: FilePath -- ^ build plan+ -> Target+ -> Text -- ^ bucket+ -> Text -- ^ key prefix+ -> IO ()+uploadIndex bpFile target bucket prefix = do+ env <- getEnv NorthVirginia Discover+ bp <- decodeFileEither (fpToString bpFile) >>= either throwM return+ let toInclude = getToInclude bp+ runResourceT $ do+ entries <- lazyConsume+ $ sourceAllCabalFiles defaultIndexLocation+ $= filterC toInclude+ $= mapC cfeEntry+ let lbs = compress $ Tar.write entries+ key = concat+ [ prefix+ , targetSlug target+ , ".tar.gz"+ ]+ sourceLazy lbs $$ upload False env bucket key++getToInclude :: BuildPlan -> CabalFileEntry -> Bool+getToInclude bp =+ go+ where+ go cfe = lookup (cfeName cfe) packages == Just (cfeVersion cfe)++ packages = siCorePackages (bpSystemInfo bp) +++ (ppVersion <$> bpPackages bp)
Stackage/Prelude.hs view
@@ -70,7 +70,10 @@ liftIO $ createTree $ parent dest' sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) -data Target = TargetNightly- | TargetMajor Int- | TargetMinor Int Int+data Target = TargetNightly !Day+ | TargetLts !Int !Int deriving Show++targetSlug :: Target -> Text+targetSlug (TargetNightly day) = "nightly-" ++ tshow day+targetSlug (TargetLts x y) = concat ["lts-", tshow x, ".", tshow y]
Stackage/ServerBundle.hs view
@@ -130,6 +130,7 @@ , cb2Type :: SnapshotType , cb2DocsDir :: FilePath , cb2Dest :: FilePath+ , cb2DocmapFile :: !FilePath } -- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc@@ -142,6 +143,7 @@ Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap+ Y.encodeFile (fpToString cb2DocmapFile) docMap void $ writeIndexStyle Nothing cb2DocsDir currentDir <- getWorkingDirectory
Stackage/UpdateBuildPlan.hs view
@@ -34,7 +34,7 @@ , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC- , pcEnableLibProfile = maybe False pcEnableLibProfile moldPC+ , pcEnableLibProfile = maybe True pcEnableLibProfile moldPC } where moldBP = lookup name bpPackages
app/stackage.hs view
@@ -25,6 +25,7 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import qualified Data.Text as T import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering))+import Stackage.Curator.UploadIndex main :: IO () main = do@@ -51,21 +52,32 @@ (fetch <$> planFile) addCommand "make-bundle" "Run a complete build and generate an upload bundle" id makeBundle'+ addCommand "check-target-available" "Is the given target available to be used?" id+ (checkTargetAvailable <$> target) addCommand "upload" "Upload a bundle to Stackage Server" id (upload <$> bundleFile <*> stackageServer) addCommand "hackage-distro" "Update the Hackage distro list" id (hackageDistro <$> planFile <*> target) addCommand "upload-github" "Upload a plan to the relevant Github repo" id- (uploadGithub <$> planFile <*> target)+ (uploadGithub <$> planFile <*> docmapFile <*> target) addCommand "install" "Install a snapshot from an existing build plan" id (installBuild <$> installFlags) addCommand "stats" "Print statistics on a build plan" id (printStats <$> planFile) addCommand "diff" "Show the high-level differences between two build plans" id (diffPlans <$> planFileArg <*> planFileArg)+ addCommand "upload-index" "Upload the 00-index.tar.gz file to S3" id+ (uploadIndex+ <$> planFile+ <*> target+ <*> pure (T.pack "haddock.stackage.org")+ <*> pure (T.pack "package-index/"))+ addCommand "upload-docs" "Upload documentation to an S3 bucket" id+ (uploadDocs' <$> target <*> bundleFile) makeBundle' = makeBundle <$> planFile+ <*> docmapFile <*> bundleFile <*> target <*> jobs@@ -196,24 +208,29 @@ s <- str let onErr = fail $ "Invalid target: " ++ s case s of- "nightly" -> return TargetNightly+ 'n':'i':'g':'h':'t':'l':'y':'-':t ->+ maybe onErr (return . TargetNightly) (readMay t) 'l':'t':'s':'-':t1 -> maybe onErr return $ do Right (i, t2) <- Just $ decimal $ T.pack t1 if T.null t2- then return $ TargetMajor i+ then return $ TargetLts i 0 else do t3 <- T.stripPrefix (T.pack ".") t2 Right (j, t4) <- Just $ decimal t3 guard $ T.null t4- if j == 0- then return $ TargetMajor i- else return $ TargetMinor i j+ return $ TargetLts i j _ -> onErr planFile = fmap decodeString $ strOption ( metavar "YAML-FILE" ++ long "plan-file" ++ help "YAML file containing a build plan"+ )++ docmapFile = fmap decodeString $ strOption+ ( metavar "YAML-FILE"+ ++ long "docmap-file"+ ++ help "YAML file containing the docmap (list of all generated Haddock modules)" ) planFileArg = fmap decodeString $ strArgument
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.8.1+version: 0.9.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@@ -34,6 +34,8 @@ Stackage.Upload Stackage.PerformBuild Stackage.CompleteBuild+ Stackage.Curator.UploadDocs+ Stackage.Curator.UploadIndex build-depends: base >= 4 && < 5 , containers , Cabal >= 1.14@@ -49,7 +51,7 @@ , utf8-string , conduit-extra- , classy-prelude-conduit+ , classy-prelude-conduit < 0.12 , text , system-fileio , system-filepath@@ -67,10 +69,25 @@ , async , streaming-commons >= 0.1.7.1 , semigroups- , xml-conduit+ , xml-conduit < 1.3 , conduit- , stackage-types- , monad-unlift+ , stackage-types >= 1.0.1+ , monad-unlift >= 0.1.1++ , blaze-html+ , html-conduit+ , mime-types+ , amazonka+ , amazonka-s3+ , amazonka-core+ , xml-types+ , base16-bytestring+ , byteable+ , cryptohash+ , cryptohash-conduit+ , resourcet+ , stackage-metadata >= 0.3+ , stackage-install >= 0.1.1 executable stackage-curator default-language: Haskell2010