Introduce HoogleLocker #206

This is intended to ensure only one thread is creating a Hoogle file
at a time.

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)
+import           Stackage.Database.Cron (loadFromS3, newHoogleLocker)
 import           Control.AutoUpdate
 
 -- Import all relevant handler modules here.
@@ -136,6 +136,7 @@ makeFoundation appSettings = do
     appHoogleLock <- newMVar ()
 
     appMirrorStatus <- mkUpdateMirrorStatus
+    appHoogleLocker <- newHoogleLocker
 
     return App {..}
 

Foundation.hs

@@ -11,6 +11,7 @@ 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
@@ -30,6 +31,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
     }
 
 instance HasHttpManager App where

Handler/Hoogle.hs

@@ -15,7 +15,7 @@ import qualified Data.Text as T
 getHoogleDB :: SnapName -> Handler (Maybe FilePath)
 getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
     app <- getYesod
-    liftIO $ Cron.getHoogleDB True (appHttpManager app) name
+    liftIO $ Cron.getHoogleDB (appHoogleLocker app) True (appHttpManager app) name
 
 getHoogleR :: SnapName -> Handler Html
 getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do

Stackage/Database/Cron.hs

@@ -2,6 +2,8 @@ module Stackage.Database.Cron
     ( stackageServerCron
     , loadFromS3
     , getHoogleDB
+    , HoogleLocker
+    , newHoogleLocker
     ) where
 
 import ClassyPrelude.Conduit
@@ -122,31 +124,65 @@ hoogleUrl n = concat
     , hoogleKey n
     ]
 
-getHoogleDB :: Bool -- ^ print exceptions?
+newtype HoogleLocker = HoogleLocker (TVar (Map FilePath (MVar ())))
+
+newHoogleLocker :: IO HoogleLocker
+newHoogleLocker = HoogleLocker <$> newTVarIO mempty
+
+data Finished a = Finished a | TryAgain
+
+getHoogleDB :: HoogleLocker
+            -> Bool -- ^ print exceptions?
             -> Manager -> SnapName -> IO (Maybe FilePath)
-getHoogleDB toPrint man name = do
+getHoogleDB (HoogleLocker locker) toPrint man name = do
     let fp = fromText $ hoogleKey name
         fptmp = encodeString fp <.> "tmp"
-    exists <- isFile fp
-    if exists
-        then return $ Just (encodeString fp)
-        else do
-            req' <- parseUrl $ unpack $ hoogleUrl name
-            let req = req'
-                    { 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
+
+    baton <- newMVar ()
+
+    let go :: IO (Finished (Maybe FilePath))
+        go = withMVar baton $ \() -> bracket acquire fst snd
+
+        acquire :: IO (IO (), IO (Finished (Maybe FilePath)))
+        acquire = atomically $ do
+            m <- readTVar locker
+            case lookup (encodeString fp) m of
+                Just baton' -> return (return (), readMVar baton' $> TryAgain)
+                Nothing -> do
+                    modifyTVar locker $ insertMap (encodeString fp) baton
+                    let cleanup = modifyTVar locker $ deleteMap (encodeString fp)
+                    return (atomically $ cleanup, Finished <$> inner)
+
+
+        inner = do
+            exists <- isFile fp
+            if exists
+                then return $ Just (encodeString fp)
                 else do
-                    when toPrint $ mapM brRead res >>= print
-                    return Nothing
+                    req' <- parseUrl $ unpack $ hoogleUrl name
+                    let req = req'
+                            { 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
@@ -154,6 +190,8 @@ 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
@@ -193,7 +231,7 @@ stackageServerCron = do
     names <- runReaderT last5Lts5Nightly db
     let manager = view envManager env
     forM_ names $ \name -> do
-        mfp <- getHoogleDB False manager name
+        mfp <- getHoogleDB locker False manager name
         case mfp of
             Just _ -> putStrLn $ "Hoogle database exists for: " ++ toPathPiece name
             Nothing -> do