Use cached widget for /package

Application.hs

@@ -138,6 +138,7 @@ makeFoundation useEcho conf = do
 
     let haddockRootDir' = "/tmp/stackage-server-haddocks"
     unpacker <- createHaddockUnpacker haddockRootDir' blobStore'
+    widgetCache' <- newIORef mempty
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App
@@ -153,6 +154,7 @@ makeFoundation useEcho conf = do
             , nextProgressKey = nextProgressKey'
             , haddockRootDir = haddockRootDir'
             , haddockUnpacker = unpacker
+            , widgetCache = widgetCache'
             }
 
     -- Perform database migration using our application's logging settings.

Foundation.hs

@@ -16,7 +16,7 @@ import           Types
 import           Yesod.Auth
 import           Yesod.Auth.BrowserId
 import           Yesod.Auth.GoogleEmail
-import           Yesod.Core.Types (Logger)
+import           Yesod.Core.Types (Logger, GWData)
 import           Yesod.Default.Config
 import           Yesod.Default.Util (addStaticContentExternal)
 
@@ -41,6 +41,7 @@ data App = App
     -- things at once, (2) we never unpack the same thing twice at the same
     -- time, and (3) so that even if the client connection dies, we finish the
     -- unpack job.
+    , widgetCache :: !(IORef (HashMap Text (UTCTime, GWData (Route App))))
     }
 
 data Progress = ProgressWorking !Text

Handler/PackageList.hs

@@ -2,6 +2,8 @@ module Handler.PackageList where
 
 import Import
 import qualified Database.Esqueleto as E
+import Yesod.Core.Types (WidgetT (WidgetT), unWidgetT)
+import Data.Time (NominalDiffTime, addUTCTime)
 
 getPackageListR :: Handler Html
 getPackageListR = do
@@ -10,4 +12,21 @@ getPackageListR = do
         return $ u E.^. UploadedName
     defaultLayout $ do
         setTitle "Package list"
-        $(widgetFile "package-list")
+        cachedWidget (5 * 60) "package-list" $(widgetFile "package-list")
+
+-- FIXME move somewhere else, maybe even yesod-core
+cachedWidget :: NominalDiffTime -> Text -> Widget -> Widget
+cachedWidget diff key widget = do
+    ref <- widgetCache <$> getYesod
+    now <- liftIO getCurrentTime
+    mpair <- lookup key <$> readIORef ref
+    case mpair of
+        Just (expires, gw) | expires > now -> do
+            $logDebug "Using cached widget"
+            WidgetT $ \_ -> return ((), gw)
+        _ -> do
+            $logDebug "Not using cached widget"
+            WidgetT $ \hd -> do
+                ((), gw) <- unWidgetT widget hd
+                atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ())
+                return ((), gw)