Add "Quick Jump" to candidate package page (#1122)

mpickering · web-flow · commit 0a2ffe8e5c5e · 2023-01-01T13:36:44.000-05:00
This allows the testing of quick jump for a candidate.
diff --git a/datafiles/templates/Html/candidate-page.html.st b/datafiles/templates/Html/candidate-page.html.st
@@ -1,6 +1,9 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
+  $if(doc.hasQuickNavV1)$
+  <link href="$doc.baseUrl$/quick-jump.css" rel="stylesheet" type="text/css" title="QuickJump" />
+  $endif$
   $hackageCssTheme()$
   <title>
     $package.name$$if(package.optional.hasSynopsis)$: $package.optional.synopsis$$endif$
@@ -152,5 +155,10 @@
     $package.optional.readme$
     $endif$
 
+    $if(doc.hasQuickNavV1)$
+    <script src="$doc.baseUrl$/quick-jump.min.js" type="text/javascript"></script>
+    <script type="text/javascript"> quickNav.init("$doc.baseUrl$", function(toggle) {var t = document.getElementById('quickjump-trigger');if (t) {t.onclick = function(e) { e.preventDefault(); toggle(); };}}); </script>
+    $endif$
+
 </body>
 </html>
diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs
@@ -293,7 +293,7 @@ htmlFeature env@ServerEnv{..}
     htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates
     htmlDownloads  = mkHtmlDownloads  utilities download
     htmlReports    = mkHtmlReports    utilities core upload user reportsCore templates
-    htmlCandidates = mkHtmlCandidates utilities core versions upload
+    htmlCandidates = mkHtmlCandidates env utilities core versions upload
                                       docsCandidates tarIndexCache
                                       candidates user templates
     htmlPreferred  = mkHtmlPreferred  utilities core versions
@@ -1081,7 +1081,8 @@ data HtmlCandidates = HtmlCandidates {
     htmlCandidatesResources :: [Resource]
   }
 
-mkHtmlCandidates :: HtmlUtilities
+mkHtmlCandidates :: ServerEnv
+                 -> HtmlUtilities
                  -> CoreFeature
                  -> VersionsFeature
                  -> UploadFeature
@@ -1091,7 +1092,7 @@ mkHtmlCandidates :: HtmlUtilities
                  -> UserFeature
                  -> Templates
                  -> HtmlCandidates
-mkHtmlCandidates utilities@HtmlUtilities{..}
+mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..}
                  CoreFeature{ coreResource = CoreResource{packageInPath}
                             , queryGetPackageIndex
                             }
@@ -1250,9 +1251,20 @@ mkHtmlCandidates utilities@HtmlUtilities{..}
       mdocIndex   <- maybe (return Nothing)
                            (liftM Just . liftIO . cachedTarIndex)
                            mdoctarblob
-      let docURL = packageDocsContentUri docs (packageId cand)
 
       mreadme     <- makeReadme render
+      let loadDocMeta
+            | Just doctarblob <- mdoctarblob
+            , Just docIndex   <- mdocIndex
+            = loadTarDocMeta
+                (BlobStorage.filepath serverBlobStore doctarblob)
+                docIndex
+                (packageId cand)
+            | otherwise
+            = return Nothing
+      mdocMeta <- loadDocMeta
+
+      let docURL = packageDocsContentUri docs (packageId cand)
 
       -- also utilize hasIndexedPackage :: Bool
       let warningBox = case renderWarnings candRender of
@@ -1270,7 +1282,7 @@ mkHtmlCandidates utilities@HtmlUtilities{..}
         , "maintainers"       $= listGroupCompact (map (Users.userIdToName userDb) (Group.toList maintainerlist))
         ] ++
         PagesNew.packagePageTemplate render
-            mdocIndex Nothing mreadme
+            mdocIndex mdocMeta mreadme
             docURL Nothing [] Nothing
             utilities
             True
diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs
@@ -97,7 +97,7 @@ packagePageTemplate render
     , "doc"               $= docFieldsTemplate
     ] ++
     -- Miscellaneous things that could still stand to be refactored a bit.
-    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL mPkgId False
+    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL mPkgId hasQuickNav
     , "downloadSection"   $= Old.downloadSection render
     ]
     else
@@ -173,11 +173,8 @@ packagePageTemplate render
       ]
 
     docFieldsTemplate =
-      if isCandidate
-        then templateDict [ templateVal "baseUrl" docURL ]
-        else templateDict [ templateVal "hasQuickNavV1" hasQuickNavV1
-        , templateVal "baseUrl" docURL
-        ]
+      templateDict [ templateVal "hasQuickNavV1" hasQuickNavV1
+                   , templateVal "baseUrl" docURL ]
 
     -- Fields that may be empty, along with booleans to see if they're present.
     -- Access via "$package.optional.varname$"
