From e5cb6869c8d12c1a5ac66ac05edb72f074ec39bf Mon Sep 17 00:00:00 2001
From: Jonathan Coates <git@squiddev.cc>
Date: Sat, 3 Jun 2023 11:21:13 +0100
Subject: [PATCH] Add cachebusters to CSS and JS

---
 support/shake/1lab-shake.cabal      |  1 +
 support/shake/app/Main.hs           |  2 ++
 support/shake/app/Shake/Digest.hs   | 28 ++++++++++++++++++++++++++++
 support/shake/app/Shake/Markdown.hs | 12 ++++++++++--
 support/web/template.html           |  4 ++--
 5 files changed, 43 insertions(+), 4 deletions(-)
 create mode 100644 support/shake/app/Shake/Digest.hs

diff --git a/support/shake/1lab-shake.cabal b/support/shake/1lab-shake.cabal
index 25e951c9d..2a5e46cd3 100644
--- a/support/shake/1lab-shake.cabal
+++ b/support/shake/1lab-shake.cabal
@@ -78,6 +78,7 @@ executable shake
     , Shake.AgdaCompile
     , Shake.AgdaRefs
     , Shake.Diagram
+    , Shake.Digest
     , Shake.Git
     , Shake.KaTeX
     , Shake.LinkGraph
diff --git a/support/shake/app/Main.hs b/support/shake/app/Main.hs
index 5ed10f467..371f26e1c 100755
--- a/support/shake/app/Main.hs
+++ b/support/shake/app/Main.hs
@@ -34,6 +34,7 @@ import Shake.LinkGraph
 import Shake.Markdown
 import Shake.Modules
 import Shake.Diagram
+import Shake.Digest
 import Shake.KaTeX
 import Shake.Git
 import Shake.Utils
@@ -50,6 +51,7 @@ rules :: Rules ()
 rules = do
   agdaRules
   agdaRefs <- getAgdaRefs
+  digestRules
   gitRules
   katexRules
   moduleRules
diff --git a/support/shake/app/Shake/Digest.hs b/support/shake/app/Shake/Digest.hs
new file mode 100644
index 000000000..a860dd74e
--- /dev/null
+++ b/support/shake/app/Shake/Digest.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE BlockArguments, GeneralizedNewtypeDeriving, TypeFamilies #-}
+
+-- | Take the
+module Shake.Digest (digestRules, getFileDigest) where
+
+import qualified Data.ByteString.Lazy as LazyBS
+import Data.Digest.Pure.SHA
+import Data.Typeable
+
+import Development.Shake.Classes (Hashable, Binary, NFData)
+import Development.Shake
+
+newtype FileDigest = FileDigest FilePath
+  deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+type instance RuleResult FileDigest = String
+
+-- | Shake rules required for compiling KaTeX equations.
+digestRules :: Rules ()
+digestRules = versioned 1 do
+  _ <- addOracle \(FileDigest f) -> do
+    need [f]
+    take 8 . showDigest . sha256 <$> liftIO (LazyBS.readFile f)
+  pure ()
+
+-- | Get parsed preamble
+getFileDigest :: FilePath -> Action String
+getFileDigest = askOracle . FileDigest
diff --git a/support/shake/app/Shake/Markdown.hs b/support/shake/app/Shake/Markdown.hs
index 70eff7e06..a6d062a6a 100644
--- a/support/shake/app/Shake/Markdown.hs
+++ b/support/shake/app/Shake/Markdown.hs
@@ -45,6 +45,7 @@ import Shake.LinkReferences
 import Shake.SearchData
 import Shake.AgdaRefs
 import Shake.Options
+import Shake.Digest
 import Shake.KaTeX
 import Shake.Git
 
@@ -149,8 +150,11 @@ buildMarkdown refs modname input output = do
   (markdown, MarkdownState references dependencies) <- runWriterT (walkM patchBlock markdown)
   need dependencies
 
+  cssDigest <- getFileDigest "_build/html/css/default.css"
+  jsDigest <- getFileDigest "_build/html/main.js"
+
   text <- liftIO $ either (fail . show) pure =<<
-    runIO (renderMarkdown authors references modname markdown)
+    runIO (renderMarkdown authors references cssDigest jsDigest modname markdown)
 
   tags <- mapM (parseAgdaLink modname refs) . foldEquations False $ parseTags text
   traverse_ (checkMarkup input) tags
@@ -284,9 +288,11 @@ patchBlock h = pure h
 renderMarkdown :: PandocMonad m
                => [Text]     -- ^ List of authors
                -> [Val Text] -- ^ List of references
+               -> String     -- ^ Digest of the CSS file
+               -> String     -- ^ Digest of the JS file
                -> String     -- ^ Name of the current module
                -> Pandoc -> m Text
-renderMarkdown authors references modname markdown = do
+renderMarkdown authors references cssDigest jsDigest modname markdown = do
   template <- getTemplate templateName >>= runWithPartials . compileTemplate templateName
                 >>= either (throwError . PandocTemplateError . Text.pack) pure
 
@@ -300,6 +306,8 @@ renderMarkdown authors references modname markdown = do
       [ ("is-index",  toVal (modname == "index"))
       , ("authors",   toVal authors')
       , ("reference", toVal references)
+      , ("cssDigest", toVal $ Text.pack cssDigest)
+      , ("jsDigest",  toVal $ Text.pack jsDigest)
       ]
 
     options = def { writerTemplate = Just template
diff --git a/support/web/template.html b/support/web/template.html
index 6910c09d0..4d0e7feb8 100644
--- a/support/web/template.html
+++ b/support/web/template.html
@@ -7,7 +7,7 @@
 
   <title>$pagetitle$ - 1Lab</title>
 
-  <link rel="stylesheet" href="/css/default.css" />
+  <link rel="stylesheet" href="/css/default.css?v=$cssDigest$" />
   <link rel="stylesheet" href="/css/katex.min.css" />
 
   <meta name="twitter:card" content="summary" />
@@ -29,7 +29,7 @@
   <meta name="description" content="A formalised, explorable online resource for Homotopy Type Theory." />
   $endif$
 
-  <script defer src="/main.js"></script>
+  <script defer src="/main.js?v=$jsDigest$"></script>
 
   <noscript>
     <style>