diff --git a/Application.hs b/Application.hs index 97d7b1f..b726ca4 100644 --- a/Application.hs +++ b/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 {..} diff --git a/Foundation.hs b/Foundation.hs index d4d33ca..fe77e32 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 600e330..776abbd 100644 --- a/Handler/Hoogle.hs +++ b/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 diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 50ded6c..7492dae 100644 --- a/Stackage/Database/Cron.hs +++ b/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