Switch to Control.SingleRun

Application.hs

@@ -33,7 +33,7 @@ import           Yesod.Default.Config2
 import           Yesod.Default.Handlers
 import           Yesod.GitRepo
 import           System.Process (rawSystem)
-import           Stackage.Database.Cron (loadFromS3, newHoogleLocker)
+import           Stackage.Database.Cron (loadFromS3, newHoogleLocker, singleRun)
 import           Control.AutoUpdate
 
 -- Import all relevant handler modules here.
@@ -136,7 +136,8 @@ makeFoundation appSettings = do
     appHoogleLock <- newMVar ()
 
     appMirrorStatus <- mkUpdateMirrorStatus
-    appHoogleLocker <- newHoogleLocker
+    hoogleLocker <- newHoogleLocker True appHttpManager
+    let appGetHoogleDB = singleRun hoogleLocker
 
     return App {..}
 

Foundation.hs

@@ -11,7 +11,6 @@ import           Yesod.Core.Types (Logger)
 import           Yesod.AtomFeed
 import           Yesod.GitRepo
 import Stackage.Database
-import Stackage.Database.Cron (HoogleLocker)
 import qualified Yesod.Core.Unsafe as Unsafe
 
 -- | The site argument for your application. This can be a good place to
@@ -31,7 +30,7 @@ data App = App
     -- ^ Avoid concurrent Hoogle queries, see
     -- https://github.com/fpco/stackage-server/issues/172
     , appMirrorStatus :: IO (Status, WidgetT App IO ())
-    , appHoogleLocker :: HoogleLocker
+    , appGetHoogleDB :: SnapName -> IO (Maybe FilePath)
     }
 
 instance HasHttpManager App where

Handler/Hoogle.hs

@@ -9,13 +9,12 @@ import qualified Hoogle
 import           Import
 import           Text.Blaze.Html (preEscapedToHtml)
 import Stackage.Database
-import qualified Stackage.Database.Cron as Cron
 import qualified Data.Text as T
 
 getHoogleDB :: SnapName -> Handler (Maybe FilePath)
 getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
     app <- getYesod
-    liftIO $ Cron.getHoogleDB (appHoogleLocker app) True (appHttpManager app) name
+    liftIO $ appGetHoogleDB app name
 
 getHoogleR :: SnapName -> Handler Html
 getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do

Stackage/Database/Cron.hs

@@ -1,9 +1,8 @@
 module Stackage.Database.Cron
     ( stackageServerCron
     , loadFromS3
-    , getHoogleDB
-    , HoogleLocker
     , newHoogleLocker
+    , singleRun
     ) where
 
 import ClassyPrelude.Conduit
@@ -35,6 +34,7 @@ import           Data.Conduit.Zlib             (WindowBits (WindowBits),
 import qualified Hoogle
 import System.Directory (doesFileExist)
 import System.IO.Temp (withSystemTempDirectory)
+import Control.SingleRun
 
 filename' :: Text
 filename' = concat
@@ -124,65 +124,33 @@ hoogleUrl n = concat
     , hoogleKey n
     ]
 
-newtype HoogleLocker = HoogleLocker (TVar (Map FilePath (MVar ())))
+newHoogleLocker :: Bool -- ^ print exceptions?
-
+                -> Manager
-newHoogleLocker :: IO HoogleLocker
+                -> IO (SingleRun SnapName (Maybe FilePath))
-newHoogleLocker = HoogleLocker <$> newTVarIO mempty
+newHoogleLocker toPrint man = mkSingleRun $ \name -> do
-
-data Finished a = Finished a | TryAgain
-
-getHoogleDB :: HoogleLocker
-            -> Bool -- ^ print exceptions?
-            -> Manager -> SnapName -> IO (Maybe FilePath)
-getHoogleDB (HoogleLocker locker) toPrint man name = do
     let fp = fromText $ hoogleKey name
         fptmp = encodeString fp <.> "tmp"
 
-    baton <- newMVar ()
+    exists <- isFile fp
-
+    if exists
-    let go :: IO (Finished (Maybe FilePath))
+        then return $ Just (encodeString fp)
-        go = withMVar baton $ \() -> bracket acquire fst snd
+        else do
-
+            req' <- parseUrl $ unpack $ hoogleUrl name
-        acquire :: IO (IO (), IO (Finished (Maybe FilePath)))
+            let req = req'
-        acquire = atomically $ do
+                    { checkStatus = \_ _ _ -> Nothing
-            m <- readTVar locker
+                    , decompress = const False
-            case lookup (encodeString fp) m of
+                    }
-                Just baton' -> return (return (), readMVar baton' $> TryAgain)
+            withResponse req man $ \res -> if responseStatus res == status200
-                Nothing -> do
+                then do
-                    modifyTVar locker $ insertMap (encodeString fp) baton
+                    createTree $ parent (fromString fptmp)
-                    let cleanup = modifyTVar locker $ deleteMap (encodeString fp)
+                    runResourceT $ bodyReaderSource (responseBody res)
-                    return (atomically $ cleanup, Finished <$> inner)
+                                $= ungzip
-
+                                $$ sinkFile fptmp
-
+                    rename (fromString fptmp) fp
-        inner = do
+                    return $ Just $ encodeString fp
-            exists <- isFile fp
-            if exists
-                then return $ Just (encodeString fp)
                 else do
-                    req' <- parseUrl $ unpack $ hoogleUrl name
+                    when toPrint $ mapM brRead res >>= print
-                    let req = req'
+                    return Nothing
-                            { checkStatus = \_ _ _ -> Nothing
-                            , decompress = const False
-                            }
-                    withResponse req man $ \res -> if responseStatus res == status200
-                        then do
-                            createTree $ parent (fromString fptmp)
-                            runResourceT $ bodyReaderSource (responseBody res)
-                                        $= ungzip
-                                        $$ sinkFile fptmp
-                            rename (fromString fptmp) fp
-                            return $ Just $ encodeString fp
-                        else do
-                            when toPrint $ mapM brRead res >>= print
-                            return Nothing
-
-        loop :: IO (Maybe FilePath)
-        loop = do
-            mres <- go
-            case mres of
-                TryAgain -> loop
-                Finished res -> return res
-    loop
 
 stackageServerCron :: IO ()
 stackageServerCron = do
@@ -190,8 +158,6 @@ stackageServerCron = do
     void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
         error $ "cabal loader process already running, exiting"
 
-    locker <- newHoogleLocker
-
     env <- newEnv NorthVirginia Discover
     let upload :: FilePath -> ObjectKey -> IO ()
         upload fp key = do
@@ -230,8 +196,11 @@ stackageServerCron = do
 
     names <- runReaderT last5Lts5Nightly db
     let manager = view envManager env
+
+    locker <- newHoogleLocker False manager
+
     forM_ names $ \name -> do
-        mfp <- getHoogleDB locker False manager name
+        mfp <- singleRun locker name
         case mfp of
             Just _ -> putStrLn $ "Hoogle database exists for: " ++ toPathPiece name
             Nothing -> do

stackage-server.cabal

@@ -47,6 +47,7 @@ library
                      Handler.Feed
                      Handler.DownloadStack
                      Handler.MirrorStatus
+                     Control.SingleRun
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT