diff --git a/src/Guide/Cache.hs b/src/Guide/Cache.hs index 4fcc46d..5d48505 100644 --- a/src/Guide/Cache.hs +++ b/src/Guide/Cache.hs @@ -25,31 +25,52 @@ import Guide.State import Guide.Utils --- Left = someone started rendering but haven't finished yet --- Right = result of the render +{- | The cache is a (concurrent) map of rendered HTML for various pages and +pieces of pages. + +* 'Left' means that someone has started rendering the piece but hasn't + finished yet; the 'Unique' specifies who started the rendering. + +* 'Right' gives you the result of a complete render. +-} type Cache = STMMap.Map CacheKey (Either Unique LByteString) +-- | The actual global cache. cache :: Cache {-# NOINLINE cache #-} cache = unsafePerformIO STMMap.newIO +-- | 'CacheKey' specifies what exactly we're caching. Currently we only cache +-- pieces of pages, never pages themselves. data CacheKey + -- | List of categories on the main page = CacheCategoryList - -- categories - | CacheCategory (Uid Category) - | CacheCategoryInfo (Uid Category) + + -- | Whole category (but not the wrapper page) + | CacheCategory (Uid Category) + -- | The header with category name + the edit form + possibly status banner + | CacheCategoryInfo (Uid Category) + -- | Category description | CacheCategoryNotes (Uid Category) - -- items - | CacheItem (Uid Item) - | CacheItemInfo (Uid Item) + + -- | Whole item (but not the wrapper page) + | CacheItem (Uid Item) + -- | Item header + | CacheItemInfo (Uid Item) + -- | Item summary | CacheItemDescription (Uid Item) - | CacheItemEcosystem (Uid Item) - | CacheItemTraits (Uid Item) - | CacheItemNotes (Uid Item) + -- | Item ecosystem + | CacheItemEcosystem (Uid Item) + -- | Item “traits” section + | CacheItemTraits (Uid Item) + -- | Item notes + | CacheItemNotes (Uid Item) deriving (Show, Eq, Generic) instance Hashable CacheKey +-- | Determine which parts should be re-rendered when a given part +-- updates. (Including the given part itself.) cacheDepends :: GlobalState -> CacheKey -> [CacheKey] cacheDepends gs key = case key of CacheCategoryList -> [key] @@ -93,58 +114,61 @@ cacheDepends gs key = case key of let cat = findCategoryByItem x gs in [key, CacheItem x, CacheCategory (cat^.uid)] --- Note that cache invalidation has to happen before the actual action is --- performed, because otherwise bad things can happen (e.g. if we're deleting --- an item we have to invalidate the cache for its category, but if we've --- already deleted the item we can't look up its category). +{- | Remove a part from the cache, together with all parts that depend on it. + +Note that cache invalidation has to happen before the actual action is +performed, because otherwise bad things can happen (e.g. if we're deleting an +item we have to invalidate the cache for its category, but if we've already +deleted the item we can't look up its category in the 'GlobalState'). +-} invalidateCache :: MonadIO m => GlobalState -> CacheKey -> m () invalidateCache gs key = liftIO $ atomically $ do for_ (cacheDepends gs key) $ \k -> STMMap.delete k cache +-- | Empty the whole cache. emptyCache :: MonadIO m => m () emptyCache = liftIO $ atomically $ STMMap.deleteAll cache +-- | Either take the rendered item from the cache, or render it and put it +-- into the cache if it's not there. cached :: MonadIO m => CacheKey -> HtmlT IO () -> HtmlT m () cached key gen = do -- If the item isn't in the cache, we'll have to render it, so we insert a -- unique mark if the item wasn't found, and we do it in the same STM -- transaction (so that nobody would be able to interfere) uniq <- liftIO newUnique - mbRes <- liftSTM $ do + mbRes <- liftSTM $ do -- liftSTM uses 'atomically' r <- STMMap.lookup key cache when (isNothing r) $ STMMap.insert (Left uniq) key cache return r - -- Okay, so. What's the result? case mbRes of - -- The item was in the cache, so we just return it + -- If the item was in the cache already, we just return it Just (Right res) -> toHtmlRaw res - -- Someone else is already rendering this; we'll use their result when - -- it's ready + -- If someone else is already rendering this, we'll use their result when + -- it's ready (so we wait a bit and then retry) Just (Left _) -> do liftIO (threadDelay 1000) cached key gen - -- The item isn't in the cache, so we'll take on rendering it + -- If the item isn't in the cache, we'll take on rendering it Nothing -> do - -- If rendering doesn't succeed, we delete the mark so that someone - -- else would be able to render it + -- On exception (i.e. when we have failed to do the render), we delete + -- our mark (but only if it's really our mark) so that someone else + -- would be able to try to render it bs <- liftIO $ renderBST gen `onException` liftSTM (deleteIfEq key (Left uniq) cache) - -- If rendering has succeeded, we write the rendered result + -- If rendering has succeeded, we write the rendered result, but only + -- if the rendering has been started by us liftSTM (replaceIfEq key (Left uniq) (Right bs) cache) toHtmlRaw bs --- The *IfEq functions are used for extra safety (we'll never replace a newer --- render with an older render accidentally) - +-- | Delete the value, but only if it's equal to the one we expect. deleteIfEq :: Eq v => STMMap.Key k => k -> v -> STMMap.Map k v -> STM () deleteIfEq k v m = STMMap.focus (Focus.updateM upd) k m where upd a = return (if a == v then Nothing else Just a) +-- | Replace the value, but only if it's equal to the one we expect. replaceIfEq :: Eq v => STMMap.Key k => k -> v -> v -> STMMap.Map k v -> STM () replaceIfEq k v v' m = STMMap.focus (Focus.adjustM upd) k m where upd a = return (if a == v then v' else a) - -liftSTM :: MonadIO m => STM a -> m a -liftSTM = liftIO . atomically diff --git a/src/Guide/Utils.hs b/src/Guide/Utils.hs index 3187929..c078f8f 100644 --- a/src/Guide/Utils.hs +++ b/src/Guide/Utils.hs @@ -63,6 +63,9 @@ module Guide.Utils MigrateConstructor(..), migrateVer, + -- * STM + liftSTM, + -- * Instances -- ** 'MonadThrow' for 'HtmlT' ) @@ -629,6 +632,13 @@ migrateVer tyName ver constructors = do lam1E (varP arg) (caseE (varE arg) (map return branches')) +---------------------------------------------------------------------------- +-- STM +---------------------------------------------------------------------------- + +liftSTM :: MonadIO m => STM a -> m a +liftSTM = liftIO . atomically + ---------------------------------------------------------------------------- -- Orphan instances ---------------------------------------------------------------------------- diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index f157fbb..75d14ce 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -657,7 +657,8 @@ renderSearch mbSearchQuery = mustache "search" $ A.object [ "query" A..= mbSearchQuery ] --- | Render list of categories on the main page. +-- | Render list of categories on the main page (the one with category groups +-- and categories in it). -- -- If the presentation of the category list ever changes (e.g. to include -- lists of items in categories, or their counts, or something), you might