From ed1e426e73bece3a3c061353a0a0802691e517d7 Mon Sep 17 00:00:00 2001
From: Lia Lenckowski <lialenck@protonmail.com>
Date: Thu, 27 Jul 2023 01:40:51 +0200
Subject: add some caching

---
 src/BangState.hs | 16 ++++++++++++++--
 src/Main.hs      | 27 ++++++++++++++++++++-------
 2 files changed, 34 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/BangState.hs b/src/BangState.hs
index fd3bbaa..8eba764 100644
--- a/src/BangState.hs
+++ b/src/BangState.hs
@@ -6,15 +6,19 @@ module BangState (
     getBangsJSON,
     getBangsBrotli,
     addBang,
+    getBangsHash,
 ) where
 
 import Codec.Compression.Brotli (compress)
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM.TChan
 import Control.Monad (forever)
+import Crypto.Hash (hashlazy, Digest, SHA512)
 import Data.Aeson
-import Data.ByteString (ByteString, toStrict, empty)
+import Data.ByteArray.Encoding (convertToBase, Base(Base64))
+import Data.ByteString (ByteString, toStrict, empty, take)
 import Data.Text (Text)
+import Data.Text.Encoding (decodeASCII)
 import GHC.Conc
 import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
 import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
@@ -26,6 +30,7 @@ data BangState = BangState {
     ddgBangs :: TVar Bangs,
     serializedBangs :: TVar ByteString,
     brotliBangs :: TVar ByteString,
+    serializedHash :: TVar Text,
     syncFileNotifications :: TChan ()
 }
 
@@ -33,10 +38,13 @@ reserialize :: BangState -> STM ()
 reserialize s = do
     own <- readTVar $ ownBangs s
     ddg <- readTVar $ ddgBangs s
-
     let jsonBs = encode $ own <> ddg -- left biased union
+
     writeTVar (serializedBangs s) $ toStrict $ jsonBs
     writeTVar (brotliBangs s)     $ toStrict $ compress jsonBs
+    -- hash: for now, base64 of the first 120 bits of the SHA512 of the bangs
+    writeTVar (serializedHash s)  $ decodeASCII $ Data.ByteString.take 20
+        $ convertToBase Base64 $ (hashlazy jsonBs :: Digest SHA512)
     writeTChan (syncFileNotifications s) ()
 
 -- spawns a thread for syncing the current state to disk. do *NOT* use forkIO on this
@@ -68,6 +76,7 @@ initBangState = do
         <*> newTVarIO (toBangs $ getResponseBody ans)
         <*> newTVarIO empty -- initially filled in by 'spawnFileSyncThread'
         <*> newTVarIO empty -- same as above
+        <*> newTVarIO ""    -- same as above
         <*> newBroadcastTChanIO
 
     spawnFileSyncThread s
@@ -81,3 +90,6 @@ getBangsBrotli s = readTVarIO $ brotliBangs s
 
 addBang :: Text -> Text -> Text -> BangState -> IO ()
 addBang _ _ _ _ = error $ "TODO"
+
+getBangsHash :: BangState -> IO Text
+getBangsHash s = readTVarIO $ serializedHash s
diff --git a/src/Main.hs b/src/Main.hs
index 69cbdb4..55ad17d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -54,24 +54,36 @@ instance YesodPersist Search where
     runDB action = getYesod >>= runSqlPool action . sqlPool
 
 getHomeR :: Handler ()
-getHomeR = sendFile typeHtml "index.html"
+getHomeR = do
+    cacheSeconds $ 60 * 60 * 24 * 7
+    sendFile typeHtml "index.html"
 
 getBundleR :: Handler ()
-getBundleR = sendFile typeJavascript "bundle.js"
+getBundleR = do
+    cacheSeconds $ 60 * 60 * 24 * 7
+    sendFile typeJavascript "bundle.js"
 
 getStyleR :: Handler ()
-getStyleR = sendFile typeCss "style.css"
+getStyleR = do
+    cacheSeconds $ 60 * 60 * 24 * 7
+    sendFile typeCss "style.css"
 
 getBangsR :: Handler TypedContent
 getBangsR = do
-    bangsAccessor <- lookupHeader "accept-encoding" >>= \case
+    st <- bangState <$> getYesod
+
+    -- changes here should propagate quicker, so we're using 1h.
+    -- besides, we're using an eTag as well.
+    cacheSeconds $ 60 * 60
+    setEtag =<< liftIO (getBangsHash st)
+
+    bs <- lookupHeader "accept-encoding" >>= \case
         Just ae | "br" `BS.isInfixOf` ae -> do
             addHeader "content-encoding" "br"
-            return getBangsBrotli
+            liftIO $ getBangsBrotli st
         _ -> do
-            return getBangsJSON
+            liftIO $ getBangsJSON st
 
-    bs <- liftIO . bangsAccessor . bangState =<< getYesod
     return $ TypedContent typeJson $ toContent bs
 
 postSubmitR :: Handler ()
@@ -86,6 +98,7 @@ postSubmitR = sequence (map lookupPostParam ["bang", "url", "name"])
 
 getOpenSearchR :: Handler TypedContent
 getOpenSearchR = do
+    neverExpires
     baseUrl <- liftIO getBaseUrl
     url <- lookupGetParam "default" <&> \case
         Nothing -> baseUrl <> "/#{searchTerms}"
-- 
cgit v1.2.3-70-g09d2