git.iko.soy/stackage
on master help sign in
More correct progress tracking
commitbe3221fc2c24f5dd06275e134400ea2cfc8d7ed9 authorMichael Snoyman <michael@snoyman.com> dateWed 24 Dec 2014, 09:25 (12 years ago) parent3982eee
3 files changed+12−6
compare with master
unifiedsplit
ChangeLog.md+4 Stackage/CompleteBuild.hs+3−1 Stackage/Upload.hs+5−5
ChangeLog.md+4
@@ -1,3 +1,7 @@
1+## 0.3.0.0
2+
3+* Return progress URL from uploadBundle
4+
15## 0.2.1.4
26
37Generate a `core` file in bundles.
Stackage/CompleteBuild.hs+3−1
@@ -157,11 +157,13 @@ completeBuild buildType = withManager tlsManagerSettings $ \man -> do
157157 token <- readFile "/auth-token"
158158 now <- epochTime
159159 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
160− ident <- flip uploadBundle man $ setArgs ghcVer def
160+ (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
161161 { ubContents = serverBundle now (title ghcVer) slug plan
162162 , ubAuthToken = decodeUtf8 token
163163 }
164164 putStrLn $ "New ident: " ++ unSnapshotIdent ident
165+ forM_ mloc $ \loc ->
166+ putStrLn $ "Track progress at: " ++ loc
165167
166168 postBuild `catchAny` print
167169
Stackage/Upload.hs+5−5
@@ -51,7 +51,7 @@ instance Default UploadBundle where
5151newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }
5252 deriving (Show, Eq, Ord, Hashable, IsString)
5353
54−uploadBundle :: UploadBundle -> Manager -> IO SnapshotIdent
54+uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)
5555uploadBundle UploadBundle {..} man = do
5656 req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"
5757 req2 <- formDataBody formData req1
@@ -67,10 +67,10 @@ uploadBundle UploadBundle {..} man = do
6767 }
6868 res <- httpLbs req3 man
6969 case lookup "x-stackage-ident" $ responseHeaders res of
70− Just snapid -> do
71− forM_ (lookup "location" $ responseHeaders res) $ \loc ->
72− putStrLn $ "Check upload progress at: " ++ decodeUtf8 loc
73− return $ SnapshotIdent $ decodeUtf8 snapid
70+ Just snapid -> return
71+ ( SnapshotIdent $ decodeUtf8 snapid
72+ , decodeUtf8 <$> lookup "location" (responseHeaders res)
73+ )
7474 Nothing -> error $ "An error occurred: " ++ show res
7575 where
7676 params = mapMaybe (\(x, y) -> (x, ) <$> y)