haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-01-20 03:01:56 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

More correct progress tracking

Browse Source
This commit is contained in:
Michael Snoyman 2014-12-24 09:25:50 +02:00
parent 3982eee037
commit be3221fc2c
3 changed files with 12 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ChangeLog.md
View File

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

4
Stackage/CompleteBuild.hs
View File

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

10
Stackage/Upload.hs
View File

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