From ebc27e0746f3463b17d4947989be11af3add2079 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 27 Aug 2020 09:44:59 +0300
Subject: [PATCH] Try deleting Hoogle DBs to save disk space

---
 src/Control/SingleRun.hs      | 25 ++++++++++++++-----------
 src/Stackage/Database/Cron.hs |  7 +++++--
 2 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/src/Control/SingleRun.hs b/src/Control/SingleRun.hs
index 776072e..aa91972 100644
--- a/src/Control/SingleRun.hs
+++ b/src/Control/SingleRun.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
 -- | 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
 -- return the same result.
@@ -19,19 +20,20 @@ data SingleRun k v = SingleRun
     -- computations. More ideal would be to use a Map, but we're
     -- avoiding dependencies outside of base in case this moves into
     -- auto-update.
-    , srFunc :: forall m . MonadIO m => k -> m v
+    , srFunc :: k -> IO v
+    , srCleanup :: k -> v -> IO ()
+    , srMax :: !Int
     }
 
 -- | Create a 'SingleRun' value out of a function.
 mkSingleRun :: MonadIO m => Eq k
-            => (forall n . MonadIO n => k -> n v)
+            => (k -> IO v) -- ^ allocate
+            -> (k -> v -> IO ()) -- ^ clean up
+            -> Int -- ^ max allowed
             -> m (SingleRun k v)
-mkSingleRun f = do
-    var <- newMVar []
-    return SingleRun
-        { srVar = var
-        , srFunc = f
-        }
+mkSingleRun srFunc srCleanup srMax = do
+    srVar <- newMVar []
+    return SingleRun {..}
 
 data Res v = SyncException SomeException
            | AsyncException SomeException
@@ -51,8 +53,8 @@ toRes se =
 -- exception, we will rethrow that same synchronous exception. If,
 -- however, that other thread dies from an asynchronous exception, we
 -- will retry.
-singleRun :: (MonadUnliftIO m, Eq k) => SingleRun k v -> k -> m v
-singleRun sr@(SingleRun var f) k =
+singleRun :: Eq k => SingleRun k v -> k -> IO v
+singleRun sr@(SingleRun var f cleanup maxHeld) k =
     -- Mask all exceptions so that we don't get killed between exiting
     -- the modifyMVar and entering the join, which could leave an
     -- empty MVar for a result that will never be filled.
@@ -97,7 +99,8 @@ singleRun sr@(SingleRun var f) k =
                             -- and return it
                             Right v -> do
                                 putMVar resVar $ Success v
+                                void $ mkWeakMVar resVar $ cleanup k v
                                 return v
 
                 -- Modify pairs to include this variable.
-                return ((k, resVar) : pairs, action)
+                return (take maxHeld $ (k, resVar) : pairs, action)
diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs
index 6ddc262..9cabe0d 100644
--- a/src/Stackage/Database/Cron.hs
+++ b/src/Stackage/Database/Cron.hs
@@ -110,8 +110,11 @@ withResponseUnliftIO req man f = withRunInIO $ \ runInIO -> withResponse req man
 
 newHoogleLocker ::
        (HasLogFunc env, MonadIO m) => env -> Manager -> m (SingleRun SnapName (Maybe FilePath))
-newHoogleLocker env man = mkSingleRun hoogleLocker
+newHoogleLocker env man = mkSingleRun hoogleLocker cleanup 10
   where
+    cleanup :: SnapName -> Maybe FilePath -> IO ()
+    cleanup _ mfp = for_ mfp removeFile
+
     hoogleLocker :: MonadIO n => SnapName -> n (Maybe FilePath)
     hoogleLocker name =
         runRIO env $ do
@@ -705,7 +708,7 @@ buildAndUploadHoogleDB doNotUpload = do
     for_ snapshots $ \(snapshotId, snapName) ->
         unlessM (checkInsertSnapshotHoogleDb False snapshotId) $ do
             logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName)
-            mfp <- singleRun locker snapName
+            mfp <- liftIO $ singleRun locker snapName
             case mfp of
                 Just _ -> do
                     logInfo $ "Current hoogle database exists for: " <> display snapName