From be3221fc2c24f5dd06275e134400ea2cfc8d7ed9 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 24 Dec 2014 09:25:50 +0200
Subject: [PATCH] More correct progress tracking

---
 ChangeLog.md              |  4 ++++
 Stackage/CompleteBuild.hs |  4 +++-
 Stackage/Upload.hs        | 10 +++++-----
 3 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index 2cfabe68..641463bd 100644
--- a/ChangeLog.md
+++ b/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.
diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs
index 27fad9df..872374cf 100644
--- a/Stackage/CompleteBuild.hs
+++ b/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
 
diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs
index 8bc67eeb..bb1c8246 100644
--- a/Stackage/Upload.hs
+++ b/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)