mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
Use non-permanent temp dir for intermediate files
This commit also removes some extraneous error checking in favor of just crashing if things go wrong.
This commit is contained in:
parent
672099d68e
commit
c344ce21ce
@ -814,6 +814,7 @@ buildAndUploadHoogleDBs doNotUpload = do
|
|||||||
-- checkInsertSnapshotHoogleDb just check against SnapshotHoogleDb.
|
-- checkInsertSnapshotHoogleDb just check against SnapshotHoogleDb.
|
||||||
-- Perhaps the check can be removed.
|
-- Perhaps the check can be removed.
|
||||||
unlessM (checkH snapshotId) $ do
|
unlessM (checkH snapshotId) $ do
|
||||||
|
withSystemTempDirectory ("hoogle-" ++ T.unpack (textDisplay snapName)) $ \tmpdir -> do
|
||||||
logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName)
|
logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName)
|
||||||
-- Check if the database already exists (by downloading it).
|
-- Check if the database already exists (by downloading it).
|
||||||
-- FIXME: Why not just send a HEAD?
|
-- FIXME: Why not just send a HEAD?
|
||||||
@ -830,15 +831,12 @@ buildAndUploadHoogleDBs doNotUpload = do
|
|||||||
void $ insertH snapshotId
|
void $ insertH snapshotId
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
logInfo $ "Current hoogle database does not yet exist in the bucket for: " <> display snapName
|
logInfo $ "Current hoogle database does not yet exist in the bucket for: " <> display snapName
|
||||||
mfp' <- createHoogleDB snapshotId snapName
|
-- NB: createHoogleDB will fail if something goes wrong.
|
||||||
forM_ mfp' $ \fp -> do
|
fp <- createHoogleDB tmpdir snapshotId snapName
|
||||||
let key = hoogleKey snapName
|
let key = hoogleKey snapName
|
||||||
dest = T.unpack key
|
unless doNotUpload $ do
|
||||||
createDirectoryIfMissing True $ takeDirectory dest
|
uploadHoogleDB fp (ObjectKey key)
|
||||||
renamePath fp dest
|
void $ insertH snapshotId
|
||||||
unless doNotUpload $ do
|
|
||||||
uploadHoogleDB dest (ObjectKey key)
|
|
||||||
void $ insertH snapshotId
|
|
||||||
|
|
||||||
-- | Create a hoogle db from haddocks for the given snapshot.
|
-- | Create a hoogle db from haddocks for the given snapshot.
|
||||||
--
|
--
|
||||||
@ -847,31 +845,30 @@ buildAndUploadHoogleDBs doNotUpload = do
|
|||||||
--
|
--
|
||||||
-- Returns the path to the .hoo database, which will be found in the first
|
-- Returns the path to the .hoo database, which will be found in the first
|
||||||
-- argument. It will look like @<rootDir>/hoogle-gen/output.hoo@.
|
-- argument. It will look like @<rootDir>/hoogle-gen/output.hoo@.
|
||||||
createHoogleDB :: SnapshotId -> SnapName -> RIO StackageCron FilePath
|
createHoogleDB :: FilePath -> SnapshotId -> SnapName -> RIO StackageCron FilePath
|
||||||
createHoogleDB snapshotId snapName = do
|
createHoogleDB rootDir snapshotId snapName = do
|
||||||
logInfo $ "Creating Hoogle DB for " <> display snapName
|
logInfo $ "Creating Hoogle DB for " <> display snapName
|
||||||
downloadBucketUrl <- scDownloadBucketUrl <$> ask
|
downloadBucketUrl <- scDownloadBucketUrl <$> ask
|
||||||
let root = "hoogle-gen"
|
let root = rootDir </> "hoogle-gen"
|
||||||
outname = root </> "output.hoo"
|
outname = root </> "output.hoo"
|
||||||
tarKey = toPathPiece snapName <> "/hoogle/orig.tar"
|
inputTarKey = toPathPiece snapName <> "/hoogle/orig.tar"
|
||||||
tarUrl = downloadBucketUrl <> "/" <> tarKey
|
inputTarUrl = downloadBucketUrl <> "/" <> inputTarKey
|
||||||
tarFP = root </> T.unpack tarKey
|
outputTarFP = root </> T.unpack inputTarKey
|
||||||
-- When tarball is downloaded it is saved with durability and atomicity, so if it
|
-- Fetch the tarball with Hoogle inputs
|
||||||
-- is present it is not in a corrupted state
|
req <- parseRequest $ T.unpack inputTarUrl
|
||||||
unlessM (doesFileExist tarFP) $ do
|
env <- asks scEnvAWS
|
||||||
req <- parseRequest $ T.unpack tarUrl
|
let man = env ^. env_manager
|
||||||
env <- asks scEnvAWS
|
withResponseUnliftIO req {decompress = const True} man $ \res -> do
|
||||||
let man = env ^. env_manager
|
throwErrorStatusCodes req res
|
||||||
withResponseUnliftIO req {decompress = const True} man $ \res -> do
|
createDirectoryIfMissing True $ takeDirectory outputTarFP
|
||||||
throwErrorStatusCodes req res
|
withBinaryFileDurableAtomic outputTarFP WriteMode $ \tarHandle ->
|
||||||
createDirectoryIfMissing True $ takeDirectory tarFP
|
runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle
|
||||||
withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle ->
|
-- Extract the Hoogle inputs from the tarball into a separate temp dir, then
|
||||||
runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle
|
-- generate the hoogle database.
|
||||||
void $ tryIO $ removeFile outname
|
|
||||||
withSystemTempDirectory ("hoogle-" ++ T.unpack (textDisplay snapName)) $ \tmpdir -> do
|
withSystemTempDirectory ("hoogle-" ++ T.unpack (textDisplay snapName)) $ \tmpdir -> do
|
||||||
Any hasRestored <-
|
Any hasRestored <-
|
||||||
runConduitRes $
|
runConduitRes $
|
||||||
sourceFile tarFP .|
|
sourceFile outputTarFP .|
|
||||||
untar (restoreHoogleTxtFileWithCabal tmpdir snapshotId snapName) .|
|
untar (restoreHoogleTxtFileWithCabal tmpdir snapshotId snapName) .|
|
||||||
foldMapC Any
|
foldMapC Any
|
||||||
-- We just check if we have any Hoogle .txt file at all.
|
-- We just check if we have any Hoogle .txt file at all.
|
||||||
@ -888,7 +885,7 @@ createHoogleDB snapshotId snapName = do
|
|||||||
-- goes wrong. That's good.
|
-- goes wrong. That's good.
|
||||||
liftIO $ Hoogle.hoogle args
|
liftIO $ Hoogle.hoogle args
|
||||||
logInfo "Merge done"
|
logInfo "Merge done"
|
||||||
return $ Just outname
|
pure outname
|
||||||
|
|
||||||
|
|
||||||
-- | Grabs hoogle txt file from the tarball and a matching cabal file from pantry. Writes
|
-- | Grabs hoogle txt file from the tarball and a matching cabal file from pantry. Writes
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user