Merge branch 'new-upload'

Conflicts: build-constraints.yaml
2026-01-11 23:08:30 +01:00 · 2015-03-18 10:55:18 +02:00 · 2015-03-18 10:55:18 +02:00 · ffb705f874
commit ffb705f874
parent 03ac82de68 ca22965695
9 changed files with 352 additions and 134 deletions
--- a/ChangeLog.md
+++ b/ChangeLog.md
@ -1,3 +1,7 @@
+## 0.6.0
+
+* Upload bundle V2 stuff
+
 ## 0.5.2

 * Upload LTS to Hackage with the name LTSHaskell
--- 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
@ -57,6 +59,8 @@ data Settings = Settings
    , setArgs   :: Text -> UploadBundle -> UploadBundle
    , postBuild :: IO ()
    , distroName :: Text -- ^ distro name on Hackage
+    , snapshotType :: SnapshotType
+    , bundleDest :: FilePath
    }

 nightlyPlanFile :: Text -- ^ day
@ -81,6 +85,8 @@ nightlySettings day plan' = Settings
    , plan = plan'
    , postBuild = return ()
    , distroName = "Stackage"
+    , snapshotType = STNightly
+    , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"
    }
  where
    slug' = "nightly-" ++ day
@ -142,6 +148,10 @@ getSettings man (LTS bumpType) = do
            putStrLn "Pushing to Git repository"
            git ["push"]
        , distroName = "LTSHaskell"
+        , snapshotType =
+            case new of
+                LTSVer x y -> STLTS x y
+        , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"
        }

 data LTSVer = LTSVer !Int !Int
@ -231,10 +241,19 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
            checkBuildPlan plan

    putStrLn "Performing build"
-    performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn
+    let 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
+        }

    when (bfDoUpload buildFlags) $
-        finallyUpload settings man
+        finallyUpload (bfUploadV2 buildFlags) settings man

 justUploadNightly
    :: Text -- ^ nightly date
@ -242,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
@ -284,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
--- a/Stackage/PerformBuild.hs
+++ b/Stackage/PerformBuild.hs
@ -495,16 +495,6 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
 renameOrCopy :: FilePath -> FilePath -> IO ()
 renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest

-copyDir :: FilePath -> FilePath -> IO ()
-copyDir src dest =
-    runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
-  where
-    src' = src </> ""
-    go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
-        let dest' = dest </> suffix
-        liftIO $ createTree $ parent dest'
-        sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
-
 copyBuiltInHaddocks :: FilePath -> IO ()
 copyBuiltInHaddocks docdir = do
    mghc <- findExecutable "ghc"
--- a/Stackage/Prelude.hs
+++ b/Stackage/Prelude.hs
@ -20,6 +20,9 @@ import           Distribution.Version            as X (Version (..),
                                                       VersionRange)
 import           Distribution.Version            as X (withinRange)
 import qualified Distribution.Version            as C
+import           Filesystem                      (createTree)
+import           Filesystem.Path                 (parent)
+import qualified Filesystem.Path                 as F

 unPackageName :: PackageName -> Text
 unPackageName (PackageName str) = pack str
@ -101,3 +104,13 @@ topologicalSort toFinal toDeps =
 data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
    deriving (Show, Typeable)
 instance (Show key, Typeable key) => Exception (TopologicalSortException key)
+
+copyDir :: FilePath -> FilePath -> IO ()
+copyDir src dest =
+    runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
+  where
+    src' = src </> ""
+    go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
+        let dest' = dest </> suffix
+        liftIO $ createTree $ parent dest'
+        sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
--- a/Stackage/ServerBundle.hs
+++ b/Stackage/ServerBundle.hs
@ -7,21 +7,31 @@ module Stackage.ServerBundle
    , epochTime
    , bpAllPackages
    , docsListing
+    , createBundleV2
+    , CreateBundleV2 (..)
+    , SnapshotType (..)
+    , writeIndexStyle
+    , DocMap
+    , PackageDocs (..)
    ) where

 import qualified Codec.Archive.Tar         as Tar
 import qualified Codec.Archive.Tar.Entry   as Tar
 import qualified Codec.Compression.GZip    as GZip
 import qualified Data.Map                  as M
+import           Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)
+import System.IO.Temp (withTempDirectory)
 import qualified Data.Yaml                 as Y
-import           Filesystem                (isFile)
+import           Filesystem                (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)
 import           Foreign.C.Types           (CTime (CTime))
 import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
 import           Stackage.Prelude
+import           System.IO.Temp (withTempDirectory)
 import qualified System.PosixCompat.Time   as PC
 import qualified Text.XML                  as X
 import           Text.XML.Cursor
+import System.PosixCompat.Files (createSymbolicLink)

 -- | Get current time
 epochTime :: IO Tar.EpochTime
@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
            map (\(PackageName name) -> name)
                (M.keys $ siCorePackages bpSystemInfo)

+-- | Package name is key
+type DocMap = Map Text PackageDocs
+data PackageDocs = PackageDocs
+    { pdVersion :: Text
+    , pdModules :: Map Text [Text]
+    -- ^ module name, path
+    }
+instance ToJSON PackageDocs where
+    toJSON PackageDocs {..} = object
+        [ "version" .= pdVersion
+        , "modules" .= pdModules
+        ]
+instance FromJSON PackageDocs where
+    parseJSON = withObject "PackageDocs" $ \o -> PackageDocs
+        <$> o .: "version"
+        <*> o .: "modules"
+
 docsListing :: BuildPlan
            -> FilePath -- ^ docs directory
-            -> IO ByteString
+            -> IO DocMap
 docsListing bp docsDir =
-    fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
+    fmap fold $ mapM go $ mapToList $ bpAllPackages bp
  where
-    go :: (PackageName, Version) -> IO (Map Text Y.Value)
+    go :: (PackageName, Version) -> IO DocMap
    go (package, version) = do -- handleAny (const $ return mempty) $ do
        let dirname = fpFromText (concat
                [ display package
@ -107,8 +134,138 @@ docsListing bp docsDir =
                    return $ if e
                        then asMap $ singletonMap name [fpToText dirname, href]
                        else mempty
-                return $ singletonMap (display package) $ Y.object
-                    [ "version" Y..= display version
-                    , "modules" Y..= m
-                    ]
+                return $ singletonMap (display package) $ PackageDocs
+                    { pdVersion = display version
+                    , pdModules = m
+                    }
            else return mempty
+
+data SnapshotType = STNightly
+                  | STLTS !Int !Int -- ^ major, minor
+    deriving (Show, Read, Eq, Ord)
+
+instance ToJSON SnapshotType where
+    toJSON STNightly = object
+        [ "type" .= asText "nightly"
+        ]
+    toJSON (STLTS major minor) = object
+        [ "type" .= asText "lts"
+        , "major" .= major
+        , "minor" .= minor
+        ]
+instance FromJSON SnapshotType where
+    parseJSON = withObject "SnapshotType" $ \o -> do
+        t <- o .: "type"
+        case asText t of
+            "nightly" -> return STNightly
+            "lts" -> STLTS
+                <$> o .: "major"
+                <*> o .: "minor"
+            _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t
+
+data CreateBundleV2 = CreateBundleV2
+    { cb2Plan :: BuildPlan
+    , cb2Type :: SnapshotType
+    , cb2DocsDir :: FilePath
+    , cb2Dest :: FilePath
+    }
+
+-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc
+-- map.
+createBundleV2 :: CreateBundleV2 -> IO ()
+createBundleV2 CreateBundleV2 {..} = do
+    docsDir <- canonicalizePath cb2DocsDir
+    docMap <- docsListing cb2Plan cb2DocsDir
+
+    Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan
+    Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type
+    Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap
+    void $ writeIndexStyle Nothing cb2DocsDir
+
+    currentDir <- getWorkingDirectory
+    files <- listDirectory docsDir
+
+    let args = "cfJ"
+             : fpToString (currentDir </> cb2Dest)
+             : "--dereference"
+             : map (fpToString . filename) files
+        cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }
+    withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
+
+writeIndexStyle :: Maybe Text -- ^ snapshot id
+                -> FilePath -- ^ docs dir
+                -> IO [String]
+writeIndexStyle msnapid dir = do
+    dirs <- fmap sort
+          $ runResourceT
+          $ sourceDirectory dir
+         $$ filterMC (liftIO . isDirectory)
+         =$ mapC (fpToString . filename)
+         =$ sinkList
+    writeFile (dir </> "index.html") $ mkIndex
+        (unpack <$> msnapid)
+        dirs
+    writeFile (dir </> "style.css") styleCss
+    return dirs
+
+mkIndex :: Maybe String -> [String] -> String
+mkIndex msnapid dirs = concat
+    [ "<!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' />"
+    , "</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/"
+        , snapid
+        , "\">Return to snapshot</a></p>"
+        ]
+    , "<ul>"
+    , concatMap toLI dirs
+    , "</ul></div></div></div></body></html>"
+    ]
+  where
+    toLI name = concat
+        [ "<li><a href='"
+        , name
+        , "/index.html'>"
+        , name
+        , "</a></li>"
+        ]
+
+styleCss :: String
+styleCss = concat
+    [ "@media (min-width: 530px) {"
+    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
+    , "}"
+    , "@media (min-width: 760px) {"
+    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
+    , "}"
+    , "ul {"
+    , "  margin-left: 0;"
+    , "  padding-left: 0;"
+    , "  list-style-type: none;"
+    , "}"
+    , "body {"
+    , "  background: #f0f0f0;"
+    , "  font-family: 'Lato', sans-serif;"
+    , "  text-shadow: 1px 1px 1px #ffffff;"
+    , "  font-size: 20px;"
+    , "  line-height: 30px;"
+    , "  padding-bottom: 5em;"
+    , "}"
+    , "h1 {"
+    , "  font-weight: normal;"
+    , "  color: #06537d;"
+    , "  font-size: 45px;"
+    , "}"
+    , ".return a {"
+    , "  color: #06537d;"
+    , "  font-style: italic;"
+    , "}"
+    , ".return {"
+    , "  margin-bottom: 1em;"
+    , "}"]
--- a/Stackage/Upload.hs
+++ b/Stackage/Upload.hs
@ -14,17 +14,25 @@ module Stackage.Upload
    , uploadHackageDistroNamed
    , UploadDocMap (..)
    , uploadDocMap
+    , uploadBundleV2
+    , UploadBundleV2 (..)
+    , def
+    , unStackageServer
    ) where

 import Control.Monad.Writer.Strict           (execWriter, tell)
 import Data.Default.Class                    (Default (..))
+import Data.Function                         (fix)
 import Filesystem                            (isDirectory, isFile)
 import Network.HTTP.Client
+import qualified Network.HTTP.Client.Conduit as HCC
 import Network.HTTP.Client.MultipartFormData
 import Stackage.BuildPlan                    (BuildPlan)
 import Stackage.Prelude
-import Stackage.ServerBundle                 (bpAllPackages, docsListing)
+import Stackage.ServerBundle                 (bpAllPackages, docsListing, writeIndexStyle)
 import System.IO.Temp                        (withSystemTempFile)
+import qualified System.IO as IO
+import qualified Data.Yaml as Y

 newtype StackageServer = StackageServer { unStackageServer :: Text }
    deriving (Show, Eq, Ord, Hashable, IsString)
@ -107,17 +115,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
  where
    uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
        hClose h
-        dirs <- fmap sort
-              $ runResourceT
-              $ sourceDirectory fp0
-             $$ filterMC (liftIO . isDirectory)
-             =$ mapC (fpToString . filename)
-             =$ sinkList
-        writeFile (fp0 </> "index.html") $ mkIndex
-            (unpack $ unSnapshotIdent ident)
-            dirs
-        writeFile (fp0 </> "style.css") styleCss
-        -- FIXME write index.html, style.css
+        dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
        let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
                { cwd = Just $ fpToString fp0
                }
@ -201,7 +199,7 @@ 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 docmap) req1
+    req2 <- formDataBody (formData $ Y.encode docmap) req1
    let req3 = req2
            { method = "PUT"
            , requestHeaders =
@ -219,61 +217,55 @@ uploadDocMap UploadDocMap {..} man = do
        , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
        ]

-mkIndex :: String -> [String] -> String
-mkIndex snapid dirs = concat
-    [ "<!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' />"
-    , "</head>"
-    , "<body><div class='container'>"
-    , "<div class='row'><div class='span12 col-md-12'>"
-    , "<h1>Haddock documentation index</h1>"
-    , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
-    , snapid
-    , "\">Return to snapshot</a></p><ul>"
-    , concatMap toLI dirs
-    , "</ul></div></div></div></body></html>"
-    ]
-  where
-    toLI name = concat
-        [ "<li><a href='"
-        , name
-        , "/index.html'>"
-        , name
-        , "</a></li>"
-        ]
+data UploadBundleV2 = UploadBundleV2
+    { ub2Server :: StackageServer
+    , ub2AuthToken :: Text
+    , ub2Bundle :: FilePath
+    }

-styleCss :: String
-styleCss = concat
-    [ "@media (min-width: 530px) {"
-    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
-    , "}"
-    , "@media (min-width: 760px) {"
-    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
-    , "}"
-    , "ul {"
-    , "  margin-left: 0;"
-    , "  padding-left: 0;"
-    , "  list-style-type: none;"
-    , "}"
-    , "body {"
-    , "  background: #f0f0f0;"
-    , "  font-family: 'Lato', sans-serif;"
-    , "  text-shadow: 1px 1px 1px #ffffff;"
-    , "  font-size: 20px;"
-    , "  line-height: 30px;"
-    , "  padding-bottom: 5em;"
-    , "}"
-    , "h1 {"
-    , "  font-weight: normal;"
-    , "  color: #06537d;"
-    , "  font-size: 45px;"
-    , "}"
-    , ".return a {"
-    , "  color: #06537d;"
-    , "  font-style: italic;"
-    , "}"
-    , ".return {"
-    , "  margin-bottom: 1em;"
-    , "}"]
+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"
+            , requestHeaders =
+                [ ("Authorization", encodeUtf8 ub2AuthToken)
+                , ("Accept", "application/json")
+                , ("Content-Type", "application/x-tar")
+                ]
+            , requestBody = HCC.requestBodySource (fromIntegral size)
+                          $ sourceHandle h $= printProgress size
+            }
+        sink = decodeUtf8C =$ fix (\loop -> do
+            mx <- peekC
+            case mx of
+                Nothing -> error $ "uploadBundleV2: premature end of stream"
+                Just _ -> do
+                    l <- lineC $ takeCE 4096 =$ foldC
+                    let (cmd, msg') = break (== ':') l
+                        msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
+                    case cmd of
+                        "CONT" -> do
+                            putStrLn msg
+                            loop
+                        "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
+                        "SUCCESS" -> return msg
+                        _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
+            )
+    withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
+  where
+    printProgress total =
+        loop 0 0
+      where
+        loop sent lastPercent =
+            await >>= maybe (putStrLn "Upload complete") go
+          where
+            go bs = do
+                yield bs
+                let sent' = sent + fromIntegral (length bs)
+                    percent = sent' * 100 `div` total
+                when (percent /= lastPercent)
+                    $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"
+                loop sent' percent
--- 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")
--- a/build-constraints.yaml
+++ b/build-constraints.yaml
@ -976,9 +976,6 @@ expected-test-failures:
    # https://github.com/BioHaskell/octree/issues/4
    - Octree

-    # https://github.com/goldfirere/th-desugar/issues/12
-    - th-desugar
-
    # https://github.com/jmillikin/haskell-filesystem/issues/3
    - system-filepath

@ -1087,9 +1084,6 @@ expected-haddock-failures:
    # https://github.com/acw/bytestring-progress/issues/4
    - bytestring-progress

-    # https://github.com/ekmett/gl/issues/4
-    - gl
-
    # https://github.com/leventov/yarr/issues/5
    - yarr

--- 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 <http://www.stackage.org/package/stackage> for a description and documentation.
 homepage:            https://github.com/fpco/stackage
@ -55,6 +55,7 @@ library
                     , yaml
                     , unix-compat
                     , http-client
+                     , http-conduit
                     , http-client-tls
                     , temporary
                     , data-default-class
@ -74,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