Add caching

Fixes #21

guide.cabal

@@ -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

src/Cache.hs

@@ -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

src/Main.hs

@@ -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
 

src/Markdown.hs

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

src/Types.hs

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

src/Utils.hs

@@ -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

src/View.hs

@@ -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