diff --git a/ChangeLog.md b/ChangeLog.md index 3d7dd179..2aa9aea0 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,4 @@ -## Unreleased +## 0.6.0 * Upload bundle V2 stuff diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index b5f41759..5f4735e6 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -8,6 +8,7 @@ module Stackage.CompleteBuild , completeBuild , justCheck , justUploadNightly + , getStackageAuthToken ) where import Control.Concurrent (threadDelay) @@ -39,6 +40,7 @@ data BuildFlags = BuildFlags , bfEnableExecDyn :: !Bool , bfVerbose :: !Bool , bfSkipCheck :: !Bool + , bfUploadV2 :: !Bool } deriving (Show) data BuildType = Nightly | LTS BumpType @@ -251,7 +253,7 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do } when (bfDoUpload buildFlags) $ - finallyUpload settings man + finallyUpload (bfUploadV2 buildFlags) settings man justUploadNightly :: Text -- ^ nightly date @@ -259,41 +261,63 @@ justUploadNightly justUploadNightly day = do plan <- decodeFileEither (fpToString $ nightlyPlanFile day) >>= either throwM return - withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan + withManager tlsManagerSettings $ finallyUpload False $ nightlySettings day plan + +getStackageAuthToken :: IO Text +getStackageAuthToken = do + mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" + case mtoken of + Nothing -> decodeUtf8 <$> readFile "/auth-token" + Just token -> return $ pack token -- | The final part of the complete build process: uploading a bundle, -- docs and a distro to hackage. -finallyUpload :: Settings -> Manager -> IO () -finallyUpload settings@Settings{..} man = do +finallyUpload :: Bool -- ^ use v2 upload + -> Settings -> Manager -> IO () +finallyUpload useV2 settings@Settings{..} man = do putStrLn "Uploading bundle to Stackage Server" - mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" - token <- - case mtoken of - Nothing -> decodeUtf8 <$> readFile "/auth-token" - Just token -> return $ pack token + token <- getStackageAuthToken - now <- epochTime - let ghcVer = display $ siGhcVersion $ bpSystemInfo plan - (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def - { ubContents = serverBundle now (title ghcVer) slug plan - , ubAuthToken = token - } - putStrLn $ "New ident: " ++ unSnapshotIdent ident - forM_ mloc $ \loc -> - putStrLn $ "Track progress at: " ++ loc + if useV2 + then do + res <- flip uploadBundleV2 man UploadBundleV2 + { ub2Server = def + , ub2AuthToken = token + , ub2Bundle = bundleDest + } + putStrLn $ "New snapshot available at: " ++ res + else do + now <- epochTime + let ghcVer = display $ siGhcVersion $ bpSystemInfo plan + (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def + { ubContents = serverBundle now (title ghcVer) slug plan + , ubAuthToken = token + } + putStrLn $ "New ident: " ++ unSnapshotIdent ident + forM_ mloc $ \loc -> + putStrLn $ "Track progress at: " ++ loc + + putStrLn "Uploading docs to Stackage Server" + res1 <- tryAny $ uploadDocs UploadDocs + { udServer = def + , udAuthToken = token + , udDocs = pbDocDir pb + , udSnapshot = ident + } man + putStrLn $ "Doc upload response: " ++ tshow res1 + + putStrLn "Uploading doc map" + tryAny (uploadDocMap UploadDocMap + { udmServer = def + , udmAuthToken = token + , udmSnapshot = ident + , udmDocDir = pbDocDir pb + , udmPlan = plan + } man) >>= print postBuild `catchAny` print - putStrLn "Uploading docs to Stackage Server" - res1 <- uploadDocs UploadDocs - { udServer = def - , udAuthToken = token - , udDocs = pbDocDir pb - , udSnapshot = ident - } man - putStrLn $ "Doc upload response: " ++ tshow res1 - ecreds <- tryIO $ readFile "/hackage-creds" case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do @@ -301,14 +325,5 @@ finallyUpload settings@Settings{..} man = do res2 <- uploadHackageDistroNamed distroName plan username password man putStrLn $ "Distro upload response: " ++ tshow res2 _ -> putStrLn "No creds found, skipping Hackage distro upload" - - putStrLn "Uploading doc map" - uploadDocMap UploadDocMap - { udmServer = def - , udmAuthToken = token - , udmSnapshot = ident - , udmDocDir = pbDocDir pb - , udmPlan = plan - } man >>= print where pb = getPerformBuild (error "finallyUpload.buildFlags") settings diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs index 3282bf91..28cdf730 100644 --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -16,6 +16,8 @@ module Stackage.Upload , uploadDocMap , uploadBundleV2 , UploadBundleV2 (..) + , def + , unStackageServer ) where import Control.Monad.Writer.Strict (execWriter, tell) @@ -224,6 +226,7 @@ data UploadBundleV2 = UploadBundleV2 uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do size <- IO.hFileSize h + putStrLn $ "Bundle size: " ++ tshow size req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2" let req2 = req1 { method = "PUT" diff --git a/app/stackage.hs b/app/stackage.hs index 1b9583c7..c53c4ee4 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -10,7 +10,11 @@ import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) import Paths_stackage (version) import Stackage.CompleteBuild +import Stackage.Upload import Stackage.InstallBuild +import Network.HTTP.Client (withManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Data.Text as T main :: IO () main = @@ -62,7 +66,13 @@ main = installBuild installFlags "install" - "Install a snapshot from an existing build plan"] + "Install a snapshot from an existing build plan" + , cmnd + uploadv2 + uploadv2Flags + "upload2" + "Upload a pre-existing v2 bundle" + ] cmnd exec parse name desc = command name $ @@ -98,7 +108,10 @@ main = help "Output verbose detail about the build steps") <*> switch (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + switch + (long "upload-v2" <> + help "Use the V2 upload code") nightlyUploadFlags = fromString <$> strArgument (metavar "DATE" <> @@ -161,3 +174,22 @@ main = switch (long "skip-check" <> help "Skip the check phase, and pass --allow-newer to cabal configure") + + uploadv2 (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 + + uploadv2Flags = (,) + <$> (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") diff --git a/stackage.cabal b/stackage.cabal index df327327..7efbd149 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -1,5 +1,5 @@ name: stackage -version: 0.5.2 +version: 0.6.0 synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -75,6 +75,9 @@ executable stackage , stackage , optparse-applicative >= 0.11 , system-filepath + , http-client + , http-client-tls + , text ghc-options: -rtsopts -threaded -with-rtsopts=-N test-suite spec