mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-18 15:11:56 +01:00
Revert "Try deleting Hoogle DBs to save disk space"
This reverts commit ebc27e0746.
This commit is contained in:
parent
3d8cd6a115
commit
0680b420e9
@ -1,6 +1,5 @@
|
|||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
-- | Ensure that a function is only being run on a given input in one
|
-- | Ensure that a function is only being run on a given input in one
|
||||||
-- thread at a time. All threads trying to make the call at once
|
-- thread at a time. All threads trying to make the call at once
|
||||||
-- return the same result.
|
-- return the same result.
|
||||||
@ -20,20 +19,19 @@ data SingleRun k v = SingleRun
|
|||||||
-- computations. More ideal would be to use a Map, but we're
|
-- computations. More ideal would be to use a Map, but we're
|
||||||
-- avoiding dependencies outside of base in case this moves into
|
-- avoiding dependencies outside of base in case this moves into
|
||||||
-- auto-update.
|
-- auto-update.
|
||||||
, srFunc :: k -> IO v
|
, srFunc :: forall m . MonadIO m => k -> m v
|
||||||
, srCleanup :: k -> v -> IO ()
|
|
||||||
, srMax :: !Int
|
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Create a 'SingleRun' value out of a function.
|
-- | Create a 'SingleRun' value out of a function.
|
||||||
mkSingleRun :: MonadIO m => Eq k
|
mkSingleRun :: MonadIO m => Eq k
|
||||||
=> (k -> IO v) -- ^ allocate
|
=> (forall n . MonadIO n => k -> n v)
|
||||||
-> (k -> v -> IO ()) -- ^ clean up
|
|
||||||
-> Int -- ^ max allowed
|
|
||||||
-> m (SingleRun k v)
|
-> m (SingleRun k v)
|
||||||
mkSingleRun srFunc srCleanup srMax = do
|
mkSingleRun f = do
|
||||||
srVar <- newMVar []
|
var <- newMVar []
|
||||||
return SingleRun {..}
|
return SingleRun
|
||||||
|
{ srVar = var
|
||||||
|
, srFunc = f
|
||||||
|
}
|
||||||
|
|
||||||
data Res v = SyncException SomeException
|
data Res v = SyncException SomeException
|
||||||
| AsyncException SomeException
|
| AsyncException SomeException
|
||||||
@ -53,8 +51,8 @@ toRes se =
|
|||||||
-- exception, we will rethrow that same synchronous exception. If,
|
-- exception, we will rethrow that same synchronous exception. If,
|
||||||
-- however, that other thread dies from an asynchronous exception, we
|
-- however, that other thread dies from an asynchronous exception, we
|
||||||
-- will retry.
|
-- will retry.
|
||||||
singleRun :: Eq k => SingleRun k v -> k -> IO v
|
singleRun :: (MonadUnliftIO m, Eq k) => SingleRun k v -> k -> m v
|
||||||
singleRun sr@(SingleRun var f cleanup maxHeld) k =
|
singleRun sr@(SingleRun var f) k =
|
||||||
-- Mask all exceptions so that we don't get killed between exiting
|
-- Mask all exceptions so that we don't get killed between exiting
|
||||||
-- the modifyMVar and entering the join, which could leave an
|
-- the modifyMVar and entering the join, which could leave an
|
||||||
-- empty MVar for a result that will never be filled.
|
-- empty MVar for a result that will never be filled.
|
||||||
@ -99,8 +97,7 @@ singleRun sr@(SingleRun var f cleanup maxHeld) k =
|
|||||||
-- and return it
|
-- and return it
|
||||||
Right v -> do
|
Right v -> do
|
||||||
putMVar resVar $ Success v
|
putMVar resVar $ Success v
|
||||||
void $ mkWeakMVar resVar $ cleanup k v
|
|
||||||
return v
|
return v
|
||||||
|
|
||||||
-- Modify pairs to include this variable.
|
-- Modify pairs to include this variable.
|
||||||
return (take maxHeld $ (k, resVar) : pairs, action)
|
return ((k, resVar) : pairs, action)
|
||||||
|
|||||||
@ -110,11 +110,8 @@ withResponseUnliftIO req man f = withRunInIO $ \ runInIO -> withResponse req man
|
|||||||
|
|
||||||
newHoogleLocker ::
|
newHoogleLocker ::
|
||||||
(HasLogFunc env, MonadIO m) => env -> Manager -> m (SingleRun SnapName (Maybe FilePath))
|
(HasLogFunc env, MonadIO m) => env -> Manager -> m (SingleRun SnapName (Maybe FilePath))
|
||||||
newHoogleLocker env man = mkSingleRun hoogleLocker cleanup 10
|
newHoogleLocker env man = mkSingleRun hoogleLocker
|
||||||
where
|
where
|
||||||
cleanup :: SnapName -> Maybe FilePath -> IO ()
|
|
||||||
cleanup _ mfp = for_ mfp removeFile
|
|
||||||
|
|
||||||
hoogleLocker :: MonadIO n => SnapName -> n (Maybe FilePath)
|
hoogleLocker :: MonadIO n => SnapName -> n (Maybe FilePath)
|
||||||
hoogleLocker name =
|
hoogleLocker name =
|
||||||
runRIO env $ do
|
runRIO env $ do
|
||||||
@ -710,7 +707,7 @@ buildAndUploadHoogleDB doNotUpload = do
|
|||||||
for_ snapshots $ \(snapshotId, snapName) ->
|
for_ snapshots $ \(snapshotId, snapName) ->
|
||||||
unlessM (checkInsertSnapshotHoogleDb False snapshotId) $ do
|
unlessM (checkInsertSnapshotHoogleDb False snapshotId) $ do
|
||||||
logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName)
|
logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName)
|
||||||
mfp <- liftIO $ singleRun locker snapName
|
mfp <- singleRun locker snapName
|
||||||
case mfp of
|
case mfp of
|
||||||
Just _ -> do
|
Just _ -> do
|
||||||
logInfo $ "Current hoogle database exists for: " <> display snapName
|
logInfo $ "Current hoogle database exists for: " <> display snapName
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user