Add per-request entity caching support

Different areas of the app need access to entities - for example both
the entry handler needs the entry itself to render it, but the
breadcrumbs also need the entry to decide what to label its breadcrumb.
Previously this was achieved by fetching entities from the database
twice. This sucks, so now it's implemented by fetching entities once and
caching them using Yesod's per-request cache.

src/Foundation.hs

@@ -22,6 +22,7 @@ import qualified Yesod.Core.Unsafe as Unsafe
 
 import Package
 import Entry.Kind ( EntryKind, allEntryKinds, pluralise )
+import Model.Cache ( getCached )
 
 import Data.Aeson ( encode, object )
 import qualified Text.Blaze.Internal as B
@@ -177,7 +178,7 @@ instance YesodBreadcrumbs App where
   breadcrumb (AuthR _) = return ("log in", Just HomeR)
   breadcrumb (EntriesR kind) = return (pluralise kind, Just HomeR)
   breadcrumb (EntryR kind entryId) = do
-    entry <- runDB . get404 $ entryId
+    (Entity _ entry) <- getCached entryId
     return (entryName entry, Just $ EntriesR kind)
   breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId
   breadcrumb _ = return ("home", Nothing)

src/Handler/Entries.hs

@@ -9,6 +9,7 @@ import Yesod.AtomFeed ( atomLink )
 import qualified Data.Text as T
 
 import qualified Entry.Kind as K
+import Model.Cache ( getCached )
 import Widget.Entry ( entryR, hEntry )
 import Widget.Feed ( hFeed )
 
@@ -22,13 +23,13 @@ getEntriesR kind = do
         $(widgetFile "entries")
 
 getEntryR :: a -> EntryId -> Handler Html
-getEntryR _ entryId = getEntry <=< fmap (Entity entryId) . runDB . get404 $ entryId
+getEntryR _ = renderEntry <=< getCached
 
 getEntryWithSlugR :: a -> EntryId -> b -> Handler Html
 getEntryWithSlugR kind = const . getEntryR kind
 
-getEntry :: (Entity Entry) -> Handler Html
-getEntry entry = do
+renderEntry :: (Entity Entry) -> Handler Html
+renderEntry entry = do
     let correctRoute = entryR entry
     actualRoute <- getCurrentRoute
     when (actualRoute /= Just correctRoute) $

src/Model/Cache.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+module Model.Cache ( getCached ) where
+
+import Data.Typeable ( Typeable )
+import Database.Persist ( Entity (..), Key (..), PersistStore, PersistRecordBackend, keyToValues )
+import Yesod ( MonadHandler, HandlerSite, YesodPersist, YesodPersistBackend, cachedBy, get404, liftHandlerT, runDB )
+
+import qualified Data.ByteString.Char8 as C
+
+newtype CachedEntity t = CachedEntity { unCachedEntity :: Entity t } deriving Typeable
+
+getCached :: ( MonadHandler m
+             , YesodPersist (HandlerSite m)
+             , PersistStore (YesodPersistBackend (HandlerSite m))
+             , PersistRecordBackend entity (YesodPersistBackend (HandlerSite m))
+             , Typeable entity
+             ) => Key entity -> m (Entity entity)
+getCached entId = liftHandlerT . cached . runDB . withId . get404 $ entId
+    where key = C.pack . show . keyToValues $ entId
+          withId = fmap $ Entity entId
+          cached = fmap unCachedEntity . cachedBy key . fmap CachedEntity