Provide options for v2 uploads

ChangeLog.md

@@ -1,4 +1,4 @@
-## Unreleased
+## 0.6.0
 
 * Upload bundle V2 stuff
 

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

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"

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")

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 <http://www.stackage.org/package/stackage> 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