More correct progress tracking

ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.3.0.0
+
+* Return progress URL from uploadBundle
+
 ## 0.2.1.4
 
 Generate a `core` file in bundles.

Stackage/CompleteBuild.hs

@@ -157,11 +157,13 @@ completeBuild buildType = withManager tlsManagerSettings $ \man -> do
     token <- readFile "/auth-token"
     now <- epochTime
     let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
-    ident <- flip uploadBundle man $ setArgs ghcVer def
+    (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
         { ubContents = serverBundle now (title ghcVer) slug plan
         , ubAuthToken = decodeUtf8 token
         }
     putStrLn $ "New ident: " ++ unSnapshotIdent ident
+    forM_ mloc $ \loc ->
+        putStrLn $ "Track progress at: " ++ loc
 
     postBuild `catchAny` print
 

Stackage/Upload.hs

@@ -51,7 +51,7 @@ instance Default UploadBundle where
 newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }
     deriving (Show, Eq, Ord, Hashable, IsString)
 
-uploadBundle :: UploadBundle -> Manager -> IO SnapshotIdent
+uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)
 uploadBundle UploadBundle {..} man = do
     req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"
     req2 <- formDataBody formData req1
@@ -67,10 +67,10 @@ uploadBundle UploadBundle {..} man = do
             }
     res <- httpLbs req3 man
     case lookup "x-stackage-ident" $ responseHeaders res of
-        Just snapid -> do
-            forM_ (lookup "location" $ responseHeaders res) $ \loc ->
-                putStrLn $ "Check upload progress at: " ++ decodeUtf8 loc
-            return $ SnapshotIdent $ decodeUtf8 snapid
+        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)