stackage-curator 0.7.4 → 0.8.0
raw patch · 8 files changed
+522/−289 lines, 8 filesdep +monad-unliftdep +optparse-simpledep +stackage-cli
Dependencies added: monad-unlift, optparse-simple, stackage-cli, stackage-update
Files
- ChangeLog.md +4/−0
- Stackage/CompleteBuild.hs +341/−50
- Stackage/PerformBuild.hs +1/−16
- Stackage/Prelude.hs +5/−0
- Stackage/ServerBundle.hs +2/−2
- Stackage/Upload.hs +6/−155
- app/stackage.hs +155/−64
- stackage-curator.cabal +8/−2
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.8.0++* Restructured commands to work on server/Docker setup+ ## 0.7.4 * `-j`/`--jobs` option for build flags
Stackage/CompleteBuild.hs view
@@ -1,24 +1,35 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) , BuildFlags (..)- , completeBuild- , justCheck+ , checkPlan , getStackageAuthToken+ , createPlan+ , fetch+ , makeBundle+ , upload+ , hackageDistro+ , uploadGithub ) where +import System.Directory (getAppUserDataDirectory)+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)+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@@ -30,6 +41,9 @@ 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 (..)) -- | Flags passed in from the command line. data BuildFlags = BuildFlags@@ -46,6 +60,9 @@ , bfGitPush :: !Bool -- ^ push to Git (when doing an LTS build) , bfJobs :: !(Maybe Int)+ , bfPlanFile :: !(Maybe FilePath)+ , bfPreBuild :: !Bool+ , bfLoadPlan :: !Bool } deriving (Show) data BuildType = Nightly | LTS BumpType Text@@ -61,7 +78,6 @@ , logDir :: FilePath , title :: Text -> Text -- ^ GHC version -> title , slug :: Text- , setArgs :: Text -> UploadBundle -> UploadBundle , postBuild :: IO () , distroName :: Text -- ^ distro name on Hackage , snapshotType :: SnapshotType@@ -77,7 +93,7 @@ -> BuildPlan -> Settings nightlySettings day bf plan' = Settings- { planFile = nightlyPlanFile day+ { planFile = fromMaybe (nightlyPlanFile day) (bfPlanFile bf) , buildDir = fpFromText $ "builds/nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day , title = \ghcVer -> concat@@ -87,7 +103,6 @@ , ghcVer ] , slug = slug'- , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } , plan = plan' , postBuild = return () , distroName = "Stackage"@@ -124,14 +139,17 @@ deriving (Show, Typeable) instance Exception ParseGoalFailure -getSettings :: Manager -> BuildFlags -> BuildType -> IO Settings-getSettings man bf Nightly = do+getSettings :: Manager -> BuildFlags -> BuildType -> Maybe FilePath -> IO Settings+getSettings man bf Nightly mplanFile = do day <- tshow . utctDay <$> getCurrentTime- bc <- defaultBuildConstraints man- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc+ 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) = do+getSettings man bf (LTS bumpType goal) Nothing = do matchesGoal <- parseGoal bumpType goal Option mlts <- fmap (fmap getMax) $ runResourceT $ sourceDirectory "."@@ -162,7 +180,7 @@ let newfile = renderLTSVer new return Settings- { planFile = newfile+ { planFile = fromMaybe newfile (bfPlanFile bf) , buildDir = fpFromText $ "builds/lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat@@ -172,7 +190,6 @@ , ghcVer ] , slug = "lts-" ++ tshow new- , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new } , plan = plan' , postBuild = do let git args = withCheckedProcess@@ -213,6 +230,39 @@ Right (minor, "") <- Just $ decimal z return $ LTSVer major minor +createPlan :: Target+ -> FilePath+ -> IO ()+createPlan target dest = withManager tlsManagerSettings $ \man -> do+ putStrLn $ "Creating plan for: " ++ tshow target+ bc <-+ case target of+ TargetMinor x y -> do+ let url = concat+ [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"+ , show x+ , "."+ , show (y - 1)+ , ".yaml"+ ]+ putStrLn $ "Downloading old plan from " ++ pack url+ req <- parseUrl url+ res <- httpLbs req man+ oldplan <- either throwM return+ $ decodeEither' (toStrict $ responseBody res)+ return $ updateBuildConstraints oldplan+ _ -> defaultBuildConstraints man++ plan <- planFromConstraints bc++ putStrLn $ "Writing build plan to " ++ fpToText dest+ encodeFile (fpToString dest) plan++planFromConstraints bc = do+ putStrLn "Creating build plan"+ plans <- getLatestAllowedPlans bc+ newBuildPlan plans bc+ renderLTSVer :: LTSVer -> FilePath renderLTSVer lts = fpFromText $ concat [ "lts-"@@ -233,18 +283,24 @@ -- | Generate and check a new build plan, but do not execute it. -- -- Since 0.3.1-justCheck :: IO ()-justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do- putStrLn "Loading build constraints"- bc <- defaultBuildConstraints man+checkPlan :: Maybe FilePath -> IO ()+checkPlan mfp = stillAlive $ withManager tlsManagerSettings $ \man -> do+ plan <-+ case mfp of+ Nothing -> do+ putStrLn "Loading default build constraints"+ bc <- defaultBuildConstraints man - putStrLn "Creating build plan"- plans <- getLatestAllowedPlans bc- plan <- newBuildPlan plans bc+ plan <- planFromConstraints bc - putStrLn $ "Writing build plan to check-plan.yaml"- encodeFile "check-plan.yaml" plan+ putStrLn $ "Writing build plan to check-plan.yaml"+ encodeFile "check-plan.yaml" plan + return plan+ Just fp -> do+ putStrLn $ "Loading plan from " ++ fpToText fp+ decodeFileEither (fpToString fp) >>= either throwM return+ putStrLn "Checking plan" checkBuildPlan plan @@ -269,44 +325,60 @@ , pbBuildHoogle = bfBuildHoogle buildFlags } +{- FIXME remove -- | Make a complete plan, build, test and upload bundle, docs and -- distro. completeBuild :: BuildType -> BuildFlags -> IO () completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do hSetBuffering stdout LineBuffering - putStrLn $ "Loading settings for: " ++ tshow buildType- settings@Settings {..} <- getSettings man buildFlags buildType+ settings@Settings {..} <- if bfLoadPlan buildFlags+ then+ case bfPlanFile buildFlags of+ Nothing -> error "When loading plan, plan file must be specified"+ Just file -> do+ putStrLn $ "Loading build plan from: " ++ fpToText file+ getSettings man buildFlags buildType $ Just file+ else do+ putStrLn $ "Loading settings for: " ++ tshow buildType+ settings@Settings {..} <- getSettings man buildFlags buildType Nothing - putStrLn $ "Writing build plan to: " ++ fpToText planFile- encodeFile (fpToString planFile) plan+ putStrLn $ "Writing build plan to: " ++ fpToText planFile+ encodeFile (fpToString planFile) plan - if bfSkipCheck buildFlags- then putStrLn "Skipping build plan check"- else do- putStrLn "Checking build plan"- checkBuildPlan plan+ if bfSkipCheck buildFlags+ then putStrLn "Skipping build plan check"+ else do+ putStrLn "Checking build plan"+ checkBuildPlan plan - putStrLn "Performing build"+ return settings+ pb <- getPerformBuild buildFlags settings- performBuild pb >>= mapM_ putStrLn - putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest- createBundleV2 CreateBundleV2- { cb2Plan = plan- , cb2Type = snapshotType- , cb2DocsDir = pbDocDir pb- , cb2Dest = bundleDest- }+ if bfPreBuild buildFlags+ then prefetchPackages pb+ else do+ putStrLn "Performing build"+ performBuild pb >>= mapM_ putStrLn - postBuild `catchAny` print+ putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest+ createBundleV2 CreateBundleV2+ { cb2Plan = plan+ , cb2Type = snapshotType+ , cb2DocsDir = pbDocDir pb+ , cb2Dest = bundleDest+ } - when (bfDoUpload buildFlags) $- finallyUpload- buildFlags- settings- man+ postBuild `catchAny` print + when (bfDoUpload buildFlags) $+ finallyUpload+ buildFlags+ settings+ man+-}+ getStackageAuthToken :: IO Text getStackageAuthToken = do mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"@@ -314,6 +386,7 @@ Nothing -> decodeUtf8 <$> readFile "/auth-token" Just token -> return $ pack token +{- FIXME remove -- | The final part of the complete build process: uploading a bundle, -- docs and a distro to hackage. finallyUpload :: BuildFlags@@ -333,10 +406,228 @@ } putStrLn $ "New snapshot available at: " ++ res +-}++hackageDistro+ :: FilePath -- ^ plan file+ -> Target+ -> IO ()+hackageDistro planFile target = withManager tlsManagerSettings $ \man -> do+ plan <- decodeFileEither (fpToString planFile) >>= either throwM return ecreds <- tryIO $ readFile "/hackage-creds" case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do- putStrLn "Uploading as Hackage distro"- res2 <- uploadHackageDistroNamed distroName plan username password man+ putStrLn $ "Uploading as Hackage distro: " ++ distroName+ res2 <- uploadHackageDistro distroName plan username password man putStrLn $ "Distro upload response: " ++ tshow res2- _ -> putStrLn "No creds found, skipping Hackage distro upload"+ _ -> error "No Hackage creds found at /hackage-creds"+ 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"++ now <- getCurrentTime++ 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"+ ])++ runIn wdir cmd args = do+ putStrLn $ concat+ [ fpToText wdir+ , ": "+ , tshow (cmd:args)+ ]+ withCheckedProcess+ (proc cmd args)+ { cwd = Just $ fpToString wdir+ } $ \ClosedStream Inherited Inherited -> return ()++ git = runIn repoDir "git"++ exists <- isDirectory repoDir+ if exists+ then do+ git ["fetch"]+ git ["checkout", "origin/master"]+ else do+ 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)]+ git ["push", "origin", "HEAD:master"]++upload+ :: FilePath -- ^ bundle file+ -> StackageServer -- ^ server URL+ -> IO ()+upload bundleFile server = withManager tlsManagerSettings $ \man -> do+ putStrLn "Uploading bundle to Stackage Server"++ token <- getStackageAuthToken++ res <- flip uploadBundleV2 man UploadBundleV2+ { ub2Server = server+ , ub2AuthToken = token+ , ub2Bundle = bundleFile+ }+ putStrLn $ "New snapshot available at: " ++ res++makeBundle+ :: FilePath -- ^ plan file+ -> FilePath -- ^ bundle file+ -> Target+ -> Maybe Int -- ^ jobs+ -> Bool -- ^ skip tests?+ -> Bool -- ^ skip haddock?+ -> Bool -- ^ skip hoogle?+ -> Bool -- ^ enable library profiling?+ -> Bool -- ^ enable executable dynamic?+ -> Bool -- ^ verbose?+ -> Bool -- ^ allow-newer?+ -> IO ()+makeBundle+ planFile 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+ , pbLog = hPut stdout+ , pbLogDir =+ case target of+ TargetNightly -> "logs/nightly"+ TargetMajor x -> fpFromText $ "logs/lts-" ++ tshow x+ TargetMinor x _ -> fpFromText $ "logs/lts-" ++ tshow x+ , pbJobs = jobs+ , pbGlobalInstall = False+ , pbEnableTests = not skipTests+ , pbEnableHaddock = not skipHaddocks+ , pbEnableLibProfiling = enableLibraryProfiling+ , pbEnableExecDyn = enableExecutableDynamic+ , pbVerbose = verbose+ , pbAllowNewer = allowNewer+ , pbBuildHoogle = not skipHoogle+ }++ putStrLn "Performing build"+ performBuild pb >>= mapM_ putStrLn++ putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleFile+ createBundleV2 CreateBundleV2+ { cb2Plan = plan+ , cb2Type =+ case target of+ TargetNightly -> STNightly+ TargetMajor x -> STLTS x 0+ TargetMinor x y -> STLTS x y+ , cb2DocsDir = pbDocDir pb+ , cb2Dest = bundleFile+ }++fetch :: FilePath -> IO ()+fetch planFile = withManager tlsManagerSettings $ \man -> do+ -- First make sure to fetch all of the dependencies... just in case Hackage+ -- has an outage. Don't feel like wasting hours of CPU time.+ putStrLn "Pre-fetching all packages"++ plan <- decodeFileEither (fpToString planFile) >>= either throwM return++ cabalDir <- fpFromString <$> getAppUserDataDirectory "cabal"+ parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan+ where+ download man cabalDir (display -> name, display . ppVersion -> version) = do+ unlessM (isFile fp) $ do+ hPut stdout $ encodeUtf8 $ concat+ [ "Downloading "+ , name+ , "-"+ , version+ , "\n"+ ]+ createTree $ parent fp+ req <- parseUrl url+ withResponse req man $ \res -> do+ let tmp = fp <.> "tmp"+ runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp+ rename tmp fp+ where+ url = unpack $ concat+ [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"+ , name+ , "-"+ , version+ , ".tar.gz"+ ]+ fp = cabalDir </>+ "packages" </>+ "hackage.haskell.org" </>+ fpFromText name </>+ fpFromText version </>+ fpFromText (concat [name, "-", version, ".tar.gz"])++parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono)+ => Int+ -> (Element mono -> m ())+ -> mono+ -> m ()+parMapM_ (max 1 -> 1) f xs = mapM_ f xs+parMapM_ cnt f xs0 = do+ var <- liftBase $ newTVarIO $ toList xs0+ run <- askRunBase+ let worker :: IO ()+ worker = run $ fix $ \loop -> join $ atomically $ do+ xs <- readTVar var+ case xs of+ [] -> return $ return ()+ x:xs' -> do+ writeTVar var xs'+ return $ do+ f x+ loop+ workers 1 = Concurrently worker+ workers i = Concurrently worker *> workers (i - 1)+ liftBase $ runConcurrently $ workers cnt
Stackage/PerformBuild.hs view
@@ -32,6 +32,7 @@ import System.IO (IOMode (WriteMode), openBinaryFile) import System.IO.Temp (withSystemTempDirectory)+import Data.Yaml (decodeFileEither) data BuildException = BuildException (Map PackageName BuildFailure) [Text] deriving Typeable@@ -154,22 +155,6 @@ performBuild' :: PerformBuild -> IO [Text] performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do- -- First make sure to fetch all of the dependencies... just in case Hackage- -- has an outage. Don't feel like wasting hours of CPU time.- pbLog $ encodeUtf8 "Pre-fetching all packages\n"- let toDownload = flip map (mapToList $ bpPackages pbPlan)- $ \(name, plan) -> unpack $ concat- [ display name- , "-"- , display $ ppVersion plan- ]- withCheckedProcess- (proc "cabal"- $ "fetch"- : "--no-dependencies"- : toDownload)- $ \ClosedStream Inherited Inherited -> return ()- let removeTree' fp = whenM (isDirectory fp) (removeTree fp) removeTree' pbLogDir
Stackage/Prelude.hs view
@@ -69,3 +69,8 @@ let dest' = dest </> suffix liftIO $ createTree $ parent dest' sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())++data Target = TargetNightly+ | TargetMajor Int+ | TargetMinor Int Int+ deriving Show
Stackage/ServerBundle.hs view
@@ -174,13 +174,13 @@ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>" , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>" , "<link rel='stylesheet' href='style.css'>"- , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"+ , "<link rel='shortcut icon' href='https://www.stackage.org/static/img/favicon.ico' />" , "</head>" , "<body><div class='container'>" , "<div class='row'><div class='span12 col-md-12'>" , "<h1>Haddock documentation index</h1>" , flip foldMap msnapid $ \snapid -> concat- [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"+ [ "<p class='return'><a href=\"https://www.stackage.org/stackage/" , snapid , "\">Return to snapshot</a></p>" ]
Stackage/Upload.hs view
@@ -5,15 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Stackage.Upload- ( UploadBundle (..)- , SnapshotIdent (..)- , uploadBundle- , UploadDocs (..)- , uploadDocs- , uploadHackageDistro- , uploadHackageDistroNamed- , UploadDocMap (..)- , uploadDocMap+ ( uploadHackageDistro , uploadBundleV2 , UploadBundleV2 (..) , def@@ -38,129 +30,18 @@ newtype StackageServer = StackageServer { unStackageServer :: Text } deriving (Show, Eq, Ord, Hashable, IsString) instance Default StackageServer where- def = "http://www.stackage.org"--data UploadBundle = UploadBundle- { ubServer :: StackageServer- , ubContents :: LByteString- , ubAlias :: Maybe Text- , ubNightly :: Maybe Text -- ^ should be GHC version- , ubLTS :: Maybe Text -- ^ e.g. 2.3- , ubAuthToken :: Text- }-instance Default UploadBundle where- def = UploadBundle- { ubServer = def- , ubContents = mempty- , ubAlias = Nothing- , ubNightly = Nothing- , ubLTS = Nothing- , ubAuthToken = "no-auth-token-provided"- }--newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }- deriving (Show, Eq, Ord, Hashable, IsString)--uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)-uploadBundle UploadBundle {..} man = do- req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"- req2 <- formDataBody formData req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 ubAuthToken)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- res <- httpLbs req3 man- case lookup "x-stackage-ident" $ responseHeaders res of- Just snapid -> return- ( SnapshotIdent $ decodeUtf8 snapid- , decodeUtf8 <$> lookup "location" (responseHeaders res)- )- Nothing -> error $ "An error occurred: " ++ show res- where- params = mapMaybe (\(x, y) -> (x, ) <$> y)- [ ("alias", ubAlias)- , ("nightly", ubNightly)- , ("lts", ubLTS)- ]- formData = ($ []) $ execWriter $ do- forM_ params $ \(key, value) ->- tell' $ partBS key $ encodeUtf8 value- tell' $ partFileRequestBody "stackage" "stackage"- $ RequestBodyLBS ubContents-- tell' x = tell (x:)--data UploadDocs = UploadDocs- { udServer :: StackageServer- , udDocs :: FilePath -- ^ may be a directory or a tarball- , udAuthToken :: Text- , udSnapshot :: SnapshotIdent- }--uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString)-uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do- fe <- isFile fp0- if fe- then uploadDocsFile $ fpToString fp0- else do- de <- isDirectory fp0- if de- then uploadDocsDir- else error $ "Path not found: " ++ fpToString fp0- where- uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do- hClose h- dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0- let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)- { cwd = Just $ fpToString fp0- }- withCheckedProcess cp $ \Inherited Inherited Inherited -> return ()- uploadDocsFile fp- uploadDocsFile fp = do- req1 <- parseUrl $ unpack $ concat- [ host- , "/upload-haddock/"- , unSnapshotIdent ident- ]- let formData =- [ partFileSource "tarball" fp- ]- req2 <- formDataBody formData req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 token)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- httpLbs req3 man--uploadHackageDistro :: BuildPlan- -> ByteString -- ^ Hackage username- -> ByteString -- ^ Hackage password- -> Manager- -> IO (Response LByteString)-uploadHackageDistro = uploadHackageDistroNamed "Stackage"+ def = "https://www.stackage.org" -uploadHackageDistroNamed+uploadHackageDistro :: Text -- ^ distro name -> BuildPlan -> ByteString -- ^ Hackage username -> ByteString -- ^ Hackage password -> Manager -> IO (Response LByteString)-uploadHackageDistroNamed name bp username password manager = do+uploadHackageDistro name bp username password manager = do req1 <- parseUrl $ concat- [ "http://hackage.haskell.org/distro/"+ [ "https://hackage.haskell.org/distro/" , unpack name , "/packages.csv" ]@@ -184,39 +65,9 @@ (toBuilder $ display name) ++ "\",\"" ++ (toBuilder $ display version) ++- "\",\"http://www.stackage.org/package/" +++ "\",\"https://www.stackage.org/package/" ++ (toBuilder $ display name) ++ "\""--data UploadDocMap = UploadDocMap- { udmServer :: StackageServer- , udmAuthToken :: Text- , udmSnapshot :: SnapshotIdent- , udmDocDir :: FilePath- , udmPlan :: BuildPlan- }--uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)-uploadDocMap UploadDocMap {..} man = do- docmap <- docsListing udmPlan udmDocDir- req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"- req2 <- formDataBody (formData $ Y.encode docmap) req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 udmAuthToken)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- httpLbs req3 man- where- formData docmap =- [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)- , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap- ] data UploadBundleV2 = UploadBundleV2 { ub2Server :: StackageServer
app/stackage.hs view
@@ -1,45 +1,80 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main where +import qualified Prelude import Control.Monad-import Data.Monoid import Data.String (fromString) import Data.Version+import Data.Text (pack, stripPrefix)+import Data.Text.Read (decimal) import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) import Paths_stackage_curator (version)+import Stackage.CLI import Stackage.CompleteBuild import Stackage.DiffPlans import Stackage.Upload+import Stackage.Update import Stackage.InstallBuild+import Stackage.Prelude hiding ((<>)) import Stackage.Stats import Network.HTTP.Client (withManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import qualified Data.Text as T+import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering)) main :: IO ()-main =- join $- execParser $- info- (helpOption <*> versionOption <*> summaryOption <*> config)- (header "Stackage" <>- fullDesc)+main = do+ hSetBuffering stdout LineBuffering+ join $ fmap snd $ simpleOptions+ $(simpleVersion version)+ "Stackage curation tool"+ "Build package sets for Stackage Nightly and LTS Haskell"+ (pure ())+ commands where- helpOption =- abortOption ShowHelpText $- long "help" <>- help "Show this help text"- versionOption =- infoOption- ("stackage-curator version " ++ showVersion version)- (long "version" <>- help "Show stackage version")- summaryOption =- infoOption- "Build package sets for Stackage Nightly and LTS Haskell"- (long "summary")+ commands = do+ addCommand "update" "Update the package index" id+ (pure $ stackageUpdate defaultStackageUpdateSettings)+ addCommand "create-plan" "Generate a new plan file (possibly based on a previous LTS)" id+ (createPlan <$> target <*> planFile)+ addCommand "check" "Verify that a plan is valid" id+ (checkPlan <$> (fmap Just planFile <|> pure Nothing))+ addCommand "fetch" "Fetch all tarballs needed by a plan" id+ (fetch <$> planFile)+ addCommand "make-bundle" "Run a complete build and generate an upload bundle" id+ makeBundle'+ 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)+ 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)++ makeBundle' = makeBundle+ <$> planFile+ <*> bundleFile+ <*> target+ <*> jobs+ <*> skipTests+ <*> skipHaddock+ <*> skipHoogle+ <*> enableLibraryProfiling+ <*> enableExecutableDynamic+ <*> verbose+ <*> allowNewer+++ {- config = subparser $ mconcat@@ -67,7 +102,6 @@ installBuild installFlags "install"- "Install a snapshot from an existing build plan" , cmnd upload uploadFlags@@ -96,12 +130,12 @@ fmap not (switch- (long "skip-tests" <>+ (long "skip-tests" ++ help "Skip build and running the test suites")) <*> fmap not (switch- (long "skip-haddock" <>+ (long "skip-haddock" ++ help "Skip generating haddock documentation")) <*> fmap not@@ -112,12 +146,6 @@ (long "enable-library-profiling" <> help "Enable profiling when building") <*> switch- (long "enable-executable-dynamic" <>- help "Enable dynamic executables when building") <*>- switch- (long "verbose" <> short 'v' <>- help "Output verbose detail about the build steps") <*>- switch (long "skip-check" <> help "Skip the check phase, and pass --allow-newer to cabal configure") <*> (fmap fromString (strOption@@ -136,12 +164,18 @@ (fmap not (switch (long "skip-git-push" <> help "Do not perform a git push after completion (for LTS builds only)"))) <*>- (fmap Just (option- auto- (long "jobs" <> short 'j' <>- metavar "NUMBER" <>- help "Number of threads")) <|> pure Nothing)+ (fmap (Just . fromString) (strOption+ (long "plan-file" <> metavar "FILENAME"))+ <|> pure Nothing) <*>+ (switch+ (long "pre-build" <>+ help "Only perform operations up until the actual build")) <*>+ (switch+ (long "load-plan" <>+ help "Load plan from file"))+ -} + installFlags :: Parser InstallFlags installFlags = InstallFlags <$> (fmap@@ -205,37 +239,94 @@ (long "skip-hoogle" <> help "Skip generating Hoogle input files")) - upload (path, url) = withManager tlsManagerSettings $ \man -> do- token <- getStackageAuthToken- res <- flip uploadBundleV2 man UploadBundleV2- { ub2AuthToken = token- , ub2Server = fromString url- , ub2Bundle = decodeString path- }- putStrLn $ "New URL: " ++ T.unpack res+ jobs =+ (fmap Just (option+ auto+ (long "jobs" ++ short 'j' +++ metavar "NUMBER" +++ help "Number of threads")) <|> pure Nothing) - uploadFlags = (,)- <$> (strArgument- (metavar "BUNDLE-PATH" <>- help "Bundle path"))- <*> strOption- (long "server-url" <>- metavar "SERVER-URL" <>- showDefault <> value (T.unpack $ unStackageServer def) <>- help "Server to upload bundle to")+ skipTests =+ switch+ (long "skip-tests" +++ help "Skip build and running the test suites") - lts bumpType = (\x y -> (y, x)) -- get the order of arguments correct- <$> buildFlags- <*> (LTS bumpType <$> (T.pack <$> argument str- ( metavar "TARGET-VERSION"- <> help "Used to run old LTS minor bumps, and rerun broken builds"- <> value ""- ) ) )+ skipHaddock =+ switch+ (long "skip-haddock" +++ help "Skip generating haddock documentation") - printStatsFlags = yamlArg+ skipHoogle =+ switch+ (long "skip-hoogle" +++ help "Skip generating Hoogle input files") - diffPlansFlags = (,) <$> yamlArg <*> yamlArg+ enableLibraryProfiling =+ switch+ (long "enable-library-profiling" +++ help "Enable profiling when building") - yamlArg = fmap decodeString $ strArgument- $ metavar "YAML-FILE"- <> help "YAML file containing a build plan"+ enableExecutableDynamic =+ switch+ (long "enable-executable-dynamic" +++ help "Enable dynamic executables when building")++ verbose =+ switch+ (long "verbose" ++ short 'v' +++ help "Output verbose detail about the build steps")++ allowNewer =+ switch+ (long "allow-newer" +++ help "Pass --allow-newer to cabal configure (useful when skipping checks)")++ target :: Parser Target+ target = option readTarget+ ( metavar "TARGET"+ ++ long "target"+ ++ help "Build target: nightly, lts-X.Y"+ )++ readTarget :: ReadM Target+ readTarget = do+ s <- str+ let onErr = fail $ "Invalid target: " ++ s+ case s of+ "nightly" -> return TargetNightly+ 'l':'t':'s':'-':t1 -> maybe onErr return $ do+ Right (i, t2) <- Just $ decimal $ T.pack t1+ if T.null t2+ then return $ TargetMajor i+ 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+ _ -> onErr++ planFile = fmap decodeString $ strOption+ ( metavar "YAML-FILE"+ ++ long "plan-file"+ ++ help "YAML file containing a build plan"+ )++ planFileArg = fmap decodeString $ strArgument+ ( metavar "YAML-FILE"+ ++ help "YAML file containing a build plan"+ )++ bundleFile = fmap decodeString $ strOption+ ( metavar "BUNDLE-FILE"+ ++ long "bundle-file"+ ++ help "Path to bundle file"+ )++ stackageServer =+ (fmap fromString (strOption+ (long "server-url" +++ metavar "SERVER-URL" +++ showDefault ++ value (T.unpack $ unStackageServer def) +++ help "Server to upload bundle to")))
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.7.4+version: 0.8.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@@ -16,6 +16,7 @@ library default-language: Haskell2010+ other-extensions: TemplateHaskell exposed-modules: Stackage.Prelude Stackage.BuildConstraints Stackage.CorePackages@@ -35,7 +36,7 @@ Stackage.CompleteBuild build-depends: base >= 4 && < 5 , containers- , Cabal >= 1.14 && < 1.20+ , Cabal >= 1.14 , tar >= 0.3 , zlib , bytestring@@ -69,14 +70,19 @@ , xml-conduit , conduit , stackage-types+ , monad-unlift executable stackage-curator default-language: Haskell2010 hs-source-dirs: app main-is: stackage.hs+ other-extensions: TemplateHaskell build-depends: base , stackage-curator , optparse-applicative >= 0.11+ , optparse-simple+ , stackage-update+ , stackage-cli , system-filepath , http-client , http-client-tls