diff --git a/Application.hs b/Application.hs index b726ca4..d39ae9f 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, 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 {..} diff --git a/Foundation.hs b/Foundation.hs index fe77e32..92297d8 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 776abbd..62d3785 100644 --- a/Handler/Hoogle.hs +++ b/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 diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 7492dae..fe368fa 100644 --- a/Stackage/Database/Cron.hs +++ b/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 :: IO HoogleLocker -newHoogleLocker = HoogleLocker <$> newTVarIO mempty - -data Finished a = Finished a | TryAgain - -getHoogleDB :: HoogleLocker - -> Bool -- ^ print exceptions? - -> Manager -> SnapName -> IO (Maybe FilePath) -getHoogleDB (HoogleLocker locker) toPrint man name = do +newHoogleLocker :: Bool -- ^ print exceptions? + -> Manager + -> IO (SingleRun SnapName (Maybe FilePath)) +newHoogleLocker toPrint man = mkSingleRun $ \name -> do let fp = fromText $ hoogleKey name fptmp = encodeString fp <.> "tmp" - 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) + 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 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 - 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 + when toPrint $ mapM brRead res >>= print + return Nothing 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 diff --git a/stackage-server.cabal b/stackage-server.cabal index fc43d64..f732ac2 100644 --- a/stackage-server.cabal +++ b/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