Merge branch 'new-upload'

Conflicts:
	build-constraints.yaml

ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.6.0
+
+* Upload bundle V2 stuff
+
 ## 0.5.2
 
 * Upload LTS to Hackage with the name LTSHaskell

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 :: Bool -- ^ use v2 upload
-finallyUpload settings@Settings{..} man = do
+              -> Settings -> Manager -> IO ()
+finallyUpload useV2 settings@Settings{..} man = do
     putStrLn "Uploading bundle to Stackage Server"
 
-    mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
+    token <- getStackageAuthToken
-    token <-
-        case mtoken of
-            Nothing -> decodeUtf8 <$> readFile "/auth-token"
-            Just token -> return $ pack token
 
-    now <- epochTime
+    if useV2
-    let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
+        then do
-    (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
+            res <- flip uploadBundleV2 man UploadBundleV2
-        { ubContents = serverBundle now (title ghcVer) slug plan
+                { ub2Server = def
-        , ubAuthToken = token
+                , ub2AuthToken = token
-        }
+                , ub2Bundle = bundleDest
-    putStrLn $ "New ident: " ++ unSnapshotIdent ident
+                }
-    forM_ mloc $ \loc ->
+            putStrLn $ "New snapshot available at: " ++ res
-        putStrLn $ "Track progress at: " ++ loc
+        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

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"

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

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
+                return $ singletonMap (display package) $ PackageDocs
-                    [ "version" Y..= display version
+                    { pdVersion = display version
-                    , "modules" Y..= m
+                    , 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;"
+    , "}"]

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
+        dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
-              $ 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
         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
+data UploadBundleV2 = UploadBundleV2
-mkIndex snapid dirs = concat
+    { ub2Server :: StackageServer
-    [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
+    , ub2AuthToken :: Text
-    , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
+    , ub2Bundle :: FilePath
-    , "<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>"
-        ]
 
-styleCss :: String
+uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
-styleCss = concat
+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
-    [ "@media (min-width: 530px) {"
+    size <- IO.hFileSize h
-    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
+    putStrLn $ "Bundle size: " ++ tshow size
-    , "}"
+    req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
-    , "@media (min-width: 760px) {"
+    let req2 = req1
-    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
+            { method = "PUT"
-    , "}"
+            , requestHeaders =
-    , "ul {"
+                [ ("Authorization", encodeUtf8 ub2AuthToken)
-    , "  margin-left: 0;"
+                , ("Accept", "application/json")
-    , "  padding-left: 0;"
+                , ("Content-Type", "application/x-tar")
-    , "  list-style-type: none;"
+                ]
-    , "}"
+            , requestBody = HCC.requestBodySource (fromIntegral size)
-    , "body {"
+                          $ sourceHandle h $= printProgress size
-    , "  background: #f0f0f0;"
+            }
-    , "  font-family: 'Lato', sans-serif;"
+        sink = decodeUtf8C =$ fix (\loop -> do
-    , "  text-shadow: 1px 1px 1px #ffffff;"
+            mx <- peekC
-    , "  font-size: 20px;"
+            case mx of
-    , "  line-height: 30px;"
+                Nothing -> error $ "uploadBundleV2: premature end of stream"
-    , "  padding-bottom: 5em;"
+                Just _ -> do
-    , "}"
+                    l <- lineC $ takeCE 4096 =$ foldC
-    , "h1 {"
+                    let (cmd, msg') = break (== ':') l
-    , "  font-weight: normal;"
+                        msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
-    , "  color: #06537d;"
+                    case cmd of
-    , "  font-size: 45px;"
+                        "CONT" -> do
-    , "}"
+                            putStrLn msg
-    , ".return a {"
+                            loop
-    , "  color: #06537d;"
+                        "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
-    , "  font-style: italic;"
+                        "SUCCESS" -> return msg
-    , "}"
+                        _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
-    , ".return {"
+            )
-    , "  margin-bottom: 1em;"
+    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

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

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
 

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