From 765ed9176712213b2eb713c16391f8848db9ce71 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 23 Oct 2014 07:33:39 +0300
Subject: [PATCH] Use cached widget for /package

---
 Application.hs         |  2 ++
 Foundation.hs          |  3 ++-
 Handler/PackageList.hs | 21 ++++++++++++++++++++-
 3 files changed, 24 insertions(+), 2 deletions(-)

diff --git a/Application.hs b/Application.hs
index 3a4617b..4dc4ccd 100644
--- a/Application.hs
+++ b/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.
diff --git a/Foundation.hs b/Foundation.hs
index 4af727a..9f904ae 100644
--- a/Foundation.hs
+++ b/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
diff --git a/Handler/PackageList.hs b/Handler/PackageList.hs
index 16fdac2..f5f1477 100644
--- a/Handler/PackageList.hs
+++ b/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)