diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.8.2 + +* `upload-docs` command + ## 0.8.1 * Redefine core packages [#395](https://github.com/fpco/stackage/issues/395) diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -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) = diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -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 diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs new file mode 100644 --- /dev/null +++ b/Stackage/Curator/UploadDocs.hs @@ -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 diff --git a/Stackage/Curator/UploadIndex.hs b/Stackage/Curator/UploadIndex.hs new file mode 100644 --- /dev/null +++ b/Stackage/Curator/UploadIndex.hs @@ -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) diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs --- a/Stackage/Prelude.hs +++ b/Stackage/Prelude.hs @@ -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] diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -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 diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -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 diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -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 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.8.1 +version: 0.9.0 synopsis: Tools for curating Stackage bundles description: Please see 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