1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-23 12:52:31 +03:00

Add caching

Fixes #21
This commit is contained in:
Artyom 2016-05-01 16:28:10 +03:00
parent a3c7f896c5
commit f560f461d2
7 changed files with 224 additions and 20 deletions

View File

@ -32,6 +32,7 @@ executable guide
Config
Types
Utils
Cache
Markdown
JS
View
@ -57,6 +58,7 @@ executable guide
, feed >= 0.3.11 && < 0.4
, filepath
, friendly-time == 0.4.*
, hashable
, http-types
, iproute == 1.7.*
, lucid >= 2.9.5 && < 3
@ -70,6 +72,7 @@ executable guide
, random >= 1.1
, safecopy
, shortcut-links >= 0.4.2
, stm-containers == 0.2.10.*
, template-haskell
, text
, text-format

128
src/Cache.hs Normal file
View File

@ -0,0 +1,128 @@
{-# LANGUAGE
DeriveGeneric,
NoImplicitPrelude
#-}
module Cache
(
CacheKey(..),
invalidateCache,
cached,
)
where
-- General
import BasePrelude hiding (Category)
-- Lenses
import Lens.Micro.Platform hiding ((&))
-- Monads and monad transformers
import Control.Monad.IO.Class
import Control.Monad.Trans
-- ByteString
import qualified Data.ByteString.Lazy as BSL
-- Concurrent map
import qualified STMContainers.Map as STMMap
import Data.Hashable
-- Lucid
import Lucid.Base
-- local
import Types
import Utils
type Cache = STMMap.Map CacheKey BSL.ByteString
cache :: Cache
{-# NOINLINE cache #-}
cache = unsafePerformIO STMMap.newIO
data CacheKey
= CacheCategoryList
-- categories
| CacheCategory (Uid Category)
| CacheCategoryTitle (Uid Category)
| CacheCategoryNotes (Uid Category)
-- items
| CacheItem (Uid Item)
| CacheItemInfo (Uid Item)
| CacheItemDescription (Uid Item)
| CacheItemEcosystem (Uid Item)
| CacheItemTraits (Uid Item)
| CacheItemNotes (Uid Item)
deriving (Show, Eq, Generic)
instance Hashable CacheKey
cacheDepends :: GlobalState -> CacheKey -> [CacheKey]
cacheDepends gs key = case key of
CacheCategoryList -> [key]
CacheCategory _ -> [key, CacheCategoryList]
CacheCategoryTitle x -> [key, CacheCategory x, CacheCategoryList]
CacheCategoryNotes x -> [key, CacheCategory x, CacheCategoryList]
-- If the item's group has been changed, it can influence how other items
-- in the same category are rendered (specifically, their lists of groups
-- in iteminfo will change)
CacheItem x ->
let cat = findCategoryByItem x gs
in CacheCategory (cat^.uid) :
-- This will cover (CacheItem x) so we don't need to prepend it
-- manually like we did before with including 'key' into lists
map CacheItem (cat^..items.each.uid) ++
map CacheItemInfo (cat^..items.each.uid)
-- Be careful if the presentation of the category list ever changes
-- (e.g. to include lists of items in categories, or their counts, or
-- something), we'd have to invalidate CacheCategoryList here too.
CacheItemInfo x ->
let cat = findCategoryByItem x gs
in CacheCategory (cat^.uid) :
map CacheItem (cat^..items.each.uid) ++
map CacheItemInfo (cat^..items.each.uid)
CacheItemDescription x ->
let cat = findCategoryByItem x gs
in [key, CacheItem x, CacheCategory (cat^.uid)]
CacheItemEcosystem x ->
let cat = findCategoryByItem x gs
in [key, CacheItem x, CacheCategory (cat^.uid)]
CacheItemTraits x ->
let cat = findCategoryByItem x gs
in [key, CacheItem x, CacheCategory (cat^.uid)]
CacheItemNotes x ->
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).
invalidateCache :: MonadIO m => GlobalState -> CacheKey -> m ()
invalidateCache gs key = liftIO $ atomically $ do
for_ (cacheDepends gs key) $ \k ->
STMMap.delete k cache
cached :: MonadIO m => CacheKey -> HtmlT m () -> HtmlT m ()
cached key gen = do
mbRes <- liftIO . atomically $ STMMap.lookup key cache
case mbRes of
Just res -> toHtmlRaw res
Nothing -> do
bs <- lift $ renderBST gen
-- TODO: this bad situation is *maybe* possible:
--
-- item is changed in request A
-- request A invalidates cache
-- request A starts re-rendering the item
-- 'cached' started by A sees that the cache is empty
-- item is changed in request B
-- request B starts re-rendering the item
-- request B fills the cache
-- 'cached' started by A finishes rendering
-- 'cached' started by A fills the cache with an outdated render
--
-- It's unlikely, but still probably possible. Ideally we'd like to run
-- lookup *and* insert inside the same transaction, but I don't know
-- how to do it.
liftIO . atomically $ STMMap.insert bs key cache
toHtmlRaw bs

View File

@ -59,6 +59,7 @@ import View
import JS (JS(..), allJSFunctions)
import Utils
import Markdown
import Cache
{- Note [acid-state]
@ -70,6 +71,8 @@ This application doesn't use a database instead, it uses acid-state. Acid-st
* All changes to the state (and all queries) have to be done by using 'dbUpdate'/'dbQuery' and types (GetItem, SetItemName, etc) from the Types.hs module.
* When doing a 'dbUpdate', don't forget to 'invalidateCache'!
* The data is kept in-memory, but all changes are logged to the disk (which lets us recover the state in case of a crash by reapplying the changes) and you can't access the state directly. When the application exits, it creates a snapshot of the state (called checkpoint) and writes it to the disk. Additionally, a checkpoint is created every hour (grep for createCheckpoint).
* When any type is changed, we have to write a migration function that would read the old version of the type and turn it into the new version. It's enough to keep just one old version (and even that isn't needed after the migration happened and a new checkpoint has been created). For examples, look at instance Migrate in Types.hs. Also, all types involved in acid-state (whether migrate-able or not) have to have a SafeCopy instance, which is generated by 'deriveSafeCopySimple'.
@ -119,7 +122,15 @@ categoryVar = "category" <//> var
traitVar :: Path '[Uid Trait]
traitVar = "trait" <//> var
-- Call this whenever a user edits the database
invalidateCache'
:: (MonadIO m, HasSpock (ActionCtxT ctx m),
SpockState (ActionCtxT ctx m) ~ ServerState)
=> CacheKey -> ActionCtxT ctx m ()
invalidateCache' key = do
gs <- dbQuery GetGlobalState
invalidateCache gs key
-- | Call this whenever a user edits the database.
addEdit :: (MonadIO m, HasSpock (ActionCtxT ctx m),
SpockState (ActionCtxT ctx m) ~ ServerState)
=> Edit -> ActionCtxT ctx m ()
@ -148,10 +159,42 @@ addEdit ed = do
unless (isVacuousEdit ed) $
dbUpdate (RegisterEdit ed mbIP time)
invalidateCacheForEdit
:: (MonadIO m, HasSpock m, SpockState m ~ ServerState)
=> Edit -> m ()
invalidateCacheForEdit ed = do
gs <- dbQuery GetGlobalState
mapM_ (invalidateCache gs) $ case ed of
Edit'AddCategory catId _ -> [CacheCategory catId]
Edit'AddItem catId itemId _ -> [CacheCategory catId,
CacheItem itemId]
Edit'AddPro itemId _ _ -> [CacheItem itemId]
Edit'AddCon itemId _ _ -> [CacheItem itemId]
Edit'SetCategoryTitle catId _ _ -> [CacheCategory catId]
Edit'SetCategoryNotes catId _ _ -> [CacheCategory catId]
Edit'SetItemName itemId _ _ -> [CacheItem itemId]
Edit'SetItemLink itemId _ _ -> [CacheItem itemId]
Edit'SetItemGroup itemId _ _ -> [CacheItem itemId]
Edit'SetItemKind itemId _ _ -> [CacheItem itemId]
Edit'SetItemDescription itemId _ _ -> [CacheItem itemId]
Edit'SetItemNotes itemId _ _ -> [CacheItem itemId]
Edit'SetItemEcosystem itemId _ _ -> [CacheItem itemId]
Edit'SetTraitContent itemId _ _ _ -> [CacheItem itemId]
Edit'DeleteCategory catId _ -> [CacheCategory catId]
Edit'DeleteItem itemId _ -> [CacheItem itemId]
Edit'DeleteTrait itemId _ _ -> [CacheItem itemId]
Edit'MoveItem itemId _ -> [CacheItem itemId]
Edit'MoveTrait itemId _ _ -> [CacheItem itemId]
-- | Do an action that would undo an edit.
--
-- 'Left' signifies failure.
--
-- This doesn't do cache invalidation (you have to do it at the call site
-- using 'invalidateCacheForEdit').
--
-- TODO: make this do cache invalidation.
--
-- TODO: many of these don't work when the changed category/item/etc has been
-- deleted; this should change.
undoEdit :: (MonadIO m, HasSpock m, SpockState m ~ ServerState)
@ -266,12 +309,14 @@ setMethods = Spock.subcomponent "set" $ do
-- Title of a category
Spock.post (categoryVar <//> "title") $ \catId -> do
content' <- param' "content"
invalidateCache' (CacheCategoryTitle catId)
(edit, category) <- dbUpdate (SetCategoryTitle catId content')
addEdit edit
lucidIO $ renderCategoryTitle category
-- Notes for a category
Spock.post (categoryVar <//> "notes") $ \catId -> do
content' <- param' "content"
invalidateCache' (CacheCategoryNotes catId)
(edit, category) <- dbUpdate (SetCategoryNotes catId content')
addEdit edit
lucidIO $ renderCategoryNotes category
@ -279,6 +324,7 @@ setMethods = Spock.subcomponent "set" $ do
Spock.post (itemVar <//> "info") $ \itemId -> do
-- TODO: [easy] add a cross-link saying where the form is handled in the
-- code and other notes saying where stuff is rendered, etc
invalidateCache' (CacheItemInfo itemId)
name' <- T.strip <$> param' "name"
link' <- T.strip <$> param' "link"
kind' <- do
@ -321,18 +367,21 @@ setMethods = Spock.subcomponent "set" $ do
-- Item description
Spock.post (itemVar <//> "description") $ \itemId -> do
content' <- param' "content"
invalidateCache' (CacheItemDescription itemId)
(edit, item) <- dbUpdate (SetItemDescription itemId content')
addEdit edit
lucidIO $ renderItemDescription item
-- Item ecosystem
Spock.post (itemVar <//> "ecosystem") $ \itemId -> do
content' <- param' "content"
invalidateCache' (CacheItemEcosystem itemId)
(edit, item) <- dbUpdate (SetItemEcosystem itemId content')
addEdit edit
lucidIO $ renderItemEcosystem item
-- Item notes
Spock.post (itemVar <//> "notes") $ \itemId -> do
content' <- param' "content"
invalidateCache' (CacheItemNotes itemId)
(edit, item) <- dbUpdate (SetItemNotes itemId content')
addEdit edit
category <- dbQuery (GetCategoryByItem itemId)
@ -340,6 +389,7 @@ setMethods = Spock.subcomponent "set" $ do
-- Trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
content' <- param' "content"
invalidateCache' (CacheItemTraits itemId)
(edit, trait) <- dbUpdate (SetTraitContent itemId traitId content')
addEdit edit
lucidIO $ renderTrait itemId trait
@ -358,6 +408,7 @@ addMethods = Spock.subcomponent "add" $ do
catId <- randomShortUid
time <- liftIO getCurrentTime
(edit, newCategory) <- dbUpdate (AddCategory catId title' time)
invalidateCache' (CacheCategory catId)
addEdit edit
return newCategory
-- And now send the URL of the new (or old) category
@ -376,6 +427,7 @@ addMethods = Spock.subcomponent "add" $ do
if T.all (\c -> isAscii c && (isAlphaNum c || c == '-')) name'
then dbUpdate (AddItem catId itemId name' time (Library (Just name')))
else dbUpdate (AddItem catId itemId name' time Other)
invalidateCache' (CacheItem itemId)
addEdit edit
category <- dbQuery (GetCategory catId)
lucidIO $ renderItem category newItem
@ -384,6 +436,7 @@ addMethods = Spock.subcomponent "add" $ do
content' <- param' "content"
traitId <- randomLongUid
(edit, newTrait) <- dbUpdate (AddPro itemId traitId content')
invalidateCache' (CacheItemTraits itemId)
addEdit edit
lucidIO $ renderTrait itemId newTrait
-- Con (argument against an item)
@ -391,6 +444,7 @@ addMethods = Spock.subcomponent "add" $ do
content' <- param' "content"
traitId <- randomLongUid
(edit, newTrait) <- dbUpdate (AddCon itemId traitId content')
invalidateCache' (CacheItemTraits itemId)
addEdit edit
lucidIO $ renderTrait itemId newTrait
@ -406,7 +460,8 @@ adminMethods = Spock.subcomponent "admin" $ do
res <- undoEdit edit
case res of
Left err -> Spock.text (T.pack err)
Right () -> do dbUpdate (RemovePendingEdit n)
Right () -> do invalidateCacheForEdit edit
dbUpdate (RemovePendingEdit n)
Spock.text ""
-- Accept a range of edits
Spock.post ("edits" <//> var <//> var <//> "accept") $ \m n -> do
@ -419,7 +474,8 @@ adminMethods = Spock.subcomponent "admin" $ do
res <- undoEdit edit
case res of
Left err -> return (Just ((edit, details), Just err))
Right () -> do dbUpdate (RemovePendingEdit (editId details))
Right () -> do invalidateCacheForEdit edit
dbUpdate (RemovePendingEdit (editId details))
return Nothing
case failed of
[] -> Spock.text ""
@ -437,25 +493,30 @@ otherMethods = do
Spock.post itemVar $ \itemId -> do
direction :: Text <- param' "direction"
edit <- dbUpdate (MoveItem itemId (direction == "up"))
invalidateCache' (CacheItem itemId)
addEdit edit
-- Move trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
direction :: Text <- param' "direction"
edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
invalidateCache' (CacheItemTraits itemId)
addEdit edit
-- Deleting things
Spock.subcomponent "delete" $ do
-- Delete category
Spock.post categoryVar $ \catId -> do
invalidateCache' (CacheCategory catId)
mbEdit <- dbUpdate (DeleteCategory catId)
mapM_ addEdit mbEdit
-- Delete item
Spock.post itemVar $ \itemId -> do
invalidateCache' (CacheItem itemId)
mbEdit <- dbUpdate (DeleteItem itemId)
mapM_ addEdit mbEdit
-- Delete trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
invalidateCache' (CacheItemTraits itemId)
mbEdit <- dbUpdate (DeleteTrait itemId traitId)
mapM_ addEdit mbEdit

View File

@ -69,6 +69,8 @@ import Data.SafeCopy
import Utils
-- TODO: switch from Builder to ByteString here
data MarkdownInline = MarkdownInline {
markdownInlineMdText :: Text,
markdownInlineMdHtml :: !Builder,

View File

@ -44,6 +44,7 @@ module Types
categoriesDeleted,
pendingEdits,
editIdCounter,
findCategoryByItem,
-- * Overloaded things
uid,

View File

@ -71,6 +71,8 @@ import Lens.Micro.Platform hiding ((&))
-- Monads and monad transformers
import Control.Monad.Trans
import Control.Monad.Random
-- Hashable (needed for Uid)
import Data.Hashable
-- Text
import Data.Text (Text)
import qualified Data.Text as T
@ -164,7 +166,7 @@ sockAddrToIP _ = Nothing
-- | Unique id, used for many things categories, items, and anchor ids.
newtype Uid a = Uid {uidToText :: Text}
deriving (Eq, Ord, Show, PathPiece, Format.Buildable)
deriving (Eq, Ord, Show, PathPiece, Format.Buildable, Hashable)
-- See Note [acid-state]
deriveSafeCopySimple 2 'extension ''Uid

View File

@ -83,6 +83,7 @@ import Utils
import JS (JS(..), JQuerySelector)
import qualified JS
import Markdown
import Cache
{- Note [autosize]
@ -384,7 +385,7 @@ renderHaskellRoot globalState mbSearchQuery =
renderCategoryPage
:: (MonadIO m, MonadRandom m, MonadReader Config m)
=> Category -> HtmlT m ()
renderCategoryPage category =
renderCategoryPage category = do
wrapPage (category^.title <> " Aelve Guide") $ do
onPageLoad $ JS.expandHash ()
-- TODO: another absolute link [absolute-links]
@ -530,8 +531,12 @@ renderHelp = do
helpVersion :: Int
helpVersion = 3
-- 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
-- have to start invalidating 'CacheCategoryList' in more things in
-- 'Cache.invalidateCache'.
renderCategoryList :: (MonadIO m, MonadRandom m) => [Category] -> HtmlT m ()
renderCategoryList cats =
renderCategoryList cats = cached CacheCategoryList $ do
div_ [id_ "categories"] $
for_ cats $ \category -> do
-- TODO: this link shouldn't be absolute [absolute-links]
@ -539,8 +544,8 @@ renderCategoryList cats =
toHtml (category^.title)
br_ []
renderCategoryTitle :: Monad m => Category -> HtmlT m ()
renderCategoryTitle category = do
renderCategoryTitle :: MonadIO m => Category -> HtmlT m ()
renderCategoryTitle category = cached (CacheCategoryTitle (category^.uid)) $ do
let thisId = "category-title-" <> uidToText (category^.uid)
this = JS.selectId thisId
h2_ [id_ thisId, class_ "category-title"] $ do
@ -572,7 +577,7 @@ renderCategoryTitle category = do
JS.switchSection (this, "normal" :: Text)
renderCategoryNotes :: (MonadIO m, MonadRandom m) => Category -> HtmlT m ()
renderCategoryNotes category = do
renderCategoryNotes category = cached (CacheCategoryNotes (category^.uid)) $ do
let thisId = "category-notes-" <> uidToText (category^.uid)
this = JS.selectId thisId
div_ [id_ thisId, class_ "category-notes"] $ do
@ -597,7 +602,7 @@ renderCategoryNotes category = do
(JS.switchSection (this, "normal" :: Text))
renderCategory :: (MonadIO m, MonadRandom m) => Category -> HtmlT m ()
renderCategory category =
renderCategory category = cached (CacheCategory (category^.uid)) $ do
div_ [class_ "category", id_ (categoryNodeId category)] $ do
renderCategoryTitle category
renderCategoryNotes category
@ -618,7 +623,7 @@ getItemHue category item = case item^.group_ of
-- TODO: perhaps use jQuery Touch Punch or something to allow dragging items
-- instead of using arrows? Touch Punch works on mobile, too
renderItem :: (MonadIO m, MonadRandom m) => Category -> Item -> HtmlT m ()
renderItem category item =
renderItem category item = cached (CacheItem (item^.uid)) $ do
-- The id is used for links in feeds, and for anchor links
div_ [id_ (itemNodeId item), class_ "item"] $ do
renderItemInfo category item
@ -663,8 +668,8 @@ renderItemTitle item = do
Nothing -> toHtml (item^.name)
-- TODO: give a link to oldest available docs when the new docs aren't there
renderItemInfo :: MonadRandom m => Category -> Item -> HtmlT m ()
renderItemInfo cat item = do
renderItemInfo :: (MonadIO m, MonadRandom m) => Category -> Item -> HtmlT m ()
renderItemInfo cat item = cached (CacheItemInfo (item^.uid)) $ do
let bg = hueToDarkColor $ getItemHue cat item
let thisId = "item-info-" <> uidToText (item^.uid)
this = JS.selectId thisId
@ -766,8 +771,10 @@ renderItemInfo cat item = do
-- TODO: categories that don't directly compare libraries but just list all
-- libraries about something (e.g. Yesod plugins, or whatever)
renderItemDescription :: MonadRandom m => Item -> HtmlT m ()
renderItemDescription item = do
-- TODO: just make a synonym for “Html with IO and randomness”
renderItemDescription :: (MonadIO m, MonadRandom m) => Item -> HtmlT m ()
renderItemDescription item = cached (CacheItemDescription (item^.uid)) $ do
let thisId = "item-description-" <> uidToText (item^.uid)
this = JS.selectId thisId
div_ [id_ thisId, class_ "item-description"] $ do
@ -795,8 +802,8 @@ renderItemDescription item = do
(\val -> JS.submitItemDescription (this, item^.uid, val))
(JS.switchSection (this, "normal" :: Text))
renderItemEcosystem :: MonadRandom m => Item -> HtmlT m ()
renderItemEcosystem item = do
renderItemEcosystem :: (MonadIO m, MonadRandom m) => Item -> HtmlT m ()
renderItemEcosystem item = cached (CacheItemEcosystem (item^.uid)) $ do
let thisId = "item-ecosystem-" <> uidToText (item^.uid)
this = JS.selectId thisId
div_ [id_ thisId, class_ "item-ecosystem"] $ do
@ -822,8 +829,8 @@ renderItemEcosystem item = do
(\val -> JS.submitItemEcosystem (this, item^.uid, val))
(JS.switchSection (this, "normal" :: Text))
renderItemTraits :: MonadRandom m => Item -> HtmlT m ()
renderItemTraits item = do
renderItemTraits :: (MonadIO m, MonadRandom m) => Item -> HtmlT m ()
renderItemTraits item = cached (CacheItemTraits (item^.uid)) $ do
div_ [class_ "item-traits"] $ do
this <- thisNode
div_ [class_ "traits-groups-container"] $ do
@ -916,7 +923,7 @@ renderTrait itemId trait = do
renderItemNotes
:: (MonadIO m, MonadRandom m)
=> Category -> Item -> HtmlT m ()
renderItemNotes category item = do
renderItemNotes category item = cached (CacheItemNotes (item^.uid)) $ do
-- Don't change this ID, it's used in e.g. 'JS.expandHash'
let thisId = "item-notes-" <> uidToText (item^.uid)
this = JS.selectId thisId