Read haddocks new meta.json and prepare for QuickNav (#614)

* Teach hackage to read haddocks new meta.json
* Load QuickNav on package page
* Doc upload: Check for valid meta.json (if present)
* Compat with pre AMP
* Use correct tarball path
* Hide "Quick jump" menu item

Distribution/Server/Features/Documentation.hs

@@ -18,6 +18,7 @@ import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
 import Distribution.Server.Framework.BlobStorage (BlobId)
 import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
 import qualified Distribution.Server.Util.ServeTarball as ServerTarball
+import qualified Distribution.Server.Util.DocMeta as DocMeta
 import Data.TarIndex (TarIndex)
 import qualified Codec.Archive.Tar       as Tar
 import qualified Codec.Archive.Tar.Check as Tar
@@ -358,7 +359,25 @@ checkDocTarball pkgid =
    . fmapErr show             . Tar.read
   where
     fmapErr f    = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f)
-    checkEntries = Tar.foldEntries (\_ remainder -> remainder) (Right ()) Left
+    checkEntries = Tar.foldEntries checkEntry (Right ()) Left
+
+    checkEntry entry remainder
+      | Tar.entryPath entry == docMetaPath = checkDocMeta entry remainder
+      | otherwise                          = remainder
+
+    checkDocMeta entry remainder =
+      case Tar.entryContent entry of
+        Tar.NormalFile content size
+          | size <= maxDocMetaFileSize ->
+              case DocMeta.parseDocMeta content of
+                Just _ -> remainder
+                Nothing -> Left "meta.json is invalid"
+          | otherwise -> Left "meta.json too large"
+        _ -> Left "meta.json not a file"
+
+    maxDocMetaFileSize = 16 * 1024 -- 16KiB
+    docMetaPath = DocMeta.packageDocMetaTarPath pkgid
+
 
 {------------------------------------------------------------------------------
   Auxiliary

Distribution/Server/Features/Html.hs

@@ -5,6 +5,7 @@ module Distribution.Server.Features.Html (
   ) where
 
 import Distribution.Server.Framework
+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
 import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
 import Distribution.Server.Framework.Templating
 
@@ -48,6 +49,7 @@ import qualified Distribution.Server.Pages.Group as Pages
 -- [reverse index disabled] import qualified Distribution.Server.Pages.Reverse as Pages
 import qualified Distribution.Server.Pages.Index as Pages
 import Distribution.Server.Util.CountingMap (cmFind, cmToList)
+import Distribution.Server.Util.DocMeta (loadTarDocMeta)
 import Distribution.Server.Util.ServeTarball (loadTarEntry)
 import Distribution.Simple.Utils ( cabalVersion )
 
@@ -464,7 +466,7 @@ mkHtmlCore :: ServerEnv
            -> ListFeature
            -> SearchFeature
            -> HtmlCore
-mkHtmlCore ServerEnv{serverBaseURI}
+mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
            utilities@HtmlUtilities{..}
            UserFeature{queryGetUserDb, checkAuthenticated}
            CoreFeature{coreResource, queryGetPackageIndex}
@@ -568,6 +570,19 @@ mkHtmlCore ServerEnv{serverBaseURI}
         mdocIndex     <- maybe (return Nothing)
           (liftM Just . liftIO . cachedTarIndex) mdoctarblob
 
+        let
+          loadDocMeta
+            | Just doctarblob <- mdoctarblob
+            , Just docIndex   <- mdocIndex
+            = loadTarDocMeta
+                (BlobStorage.filepath serverBlobStore doctarblob)
+                docIndex
+                pkgid
+            | otherwise
+            = return Nothing
+
+        mdocMeta <- loadDocMeta
+
         let infoUrl = fmap (\_ -> preferredPackageUri versions "" pkgname) $
               sumRange prefInfo
 
@@ -592,7 +607,7 @@ mkHtmlCore ServerEnv{serverBaseURI}
           ] ++
           -- Items not related to IO (mostly pure functions)
           PagesNew.packagePageTemplate render
-            mdocIndex mreadme
+            mdocIndex mdocMeta mreadme
             docURL distributions
             deprs
             utilities

Distribution/Server/Pages/PackageFromTemplate.hs

@@ -8,6 +8,7 @@ module Distribution.Server.Pages.PackageFromTemplate
 import Distribution.Server.Framework.Templating
 import Distribution.Server.Features.PreferredVersions
 
+import Distribution.Server.Util.DocMeta
 import Distribution.Server.Packages.Render
 import Distribution.Server.Users.Types (userStatus, userName, isActiveAccount)
 import Data.TarIndex (TarIndex)
@@ -73,18 +74,19 @@ import Distribution.Server.Features.Html.HtmlUtilities
 --    package's upload time, the last time it was updated, and the number of
 --    votes it has.
 packagePageTemplate :: PackageRender
-            -> Maybe TarIndex -> Maybe BS.ByteString
+            -> Maybe TarIndex -> Maybe DocMeta -> Maybe BS.ByteString
             -> URL -> [(DistroName, DistroPackageInfo)]
             -> Maybe [PackageName]
             -> HtmlUtilities
             -> [TemplateAttr]
 packagePageTemplate render
-            mdocIndex mreadme
+            mdocIndex mdocMeta mreadme
             docURL distributions
             deprs utilities =
   -- The main two namespaces
   [ "package"           $= packageFieldsTemplate
   , "hackage"           $= hackageFieldsTemplate
+  , "doc"               $= docFieldsTemplate
   ] ++
 
   -- Miscellaneous things that could still stand to be refactored a bit.
@@ -136,6 +138,11 @@ packagePageTemplate render
       , templateVal "optional"      optionalPackageInfoTemplate
       ]
 
+    docFieldsTemplate = 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$"
     optionalPackageInfoTemplate = templateDict $
@@ -243,6 +250,14 @@ packagePageTemplate render
                 map (packageNameLink utilities) $ fors
       Nothing -> noHtml
 
+    hasQuickNavGen :: Maybe DocMeta -> Version -> Bool
+    hasQuickNavGen (Just docMeta) expected =
+      docMetaHaddockVersion docMeta == expected
+    hasQuickNavGen _ _ = False
+
+    hasQuickNavV1 :: Bool
+    hasQuickNavV1 = hasQuickNavGen mdocMeta (mkVersion [2, 18, 2])
+
 -- #ToDo: Pick out several interesting versions to display, with a link to
 -- display all versions.
 renderVersion :: PackageId -> [(Version, VersionStatus)] -> Maybe String -> Html

Distribution/Server/Util/DocMeta.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Distribution.Server.Util.DocMeta (
+    DocMeta(..)
+  , loadTarDocMeta
+  , parseDocMeta
+  , packageDocMetaTarPath
+  ) where
+
+import Control.Monad (mzero)
+import Control.Monad.IO.Class
+import Data.Aeson
+import qualified Data.ByteString.Lazy
+import Data.TarIndex (TarIndex)
+import qualified Data.TarIndex as TarIndex
+import qualified Data.Text as Text
+import Distribution.Package
+import Distribution.Text (display, simpleParse)
+import Distribution.Version (Version)
+import System.FilePath ((</>))
+
+import Distribution.Server.Util.ServeTarball (loadTarEntry)
+
+newtype JsonVersion = JV Version
+
+instance FromJSON JsonVersion where
+  parseJSON = withText "Version" $ \s ->
+    case simpleParse (Text.unpack s) of
+      Just version -> return (JV version)
+      Nothing      -> mzero
+
+data DocMeta = DocMeta {
+  docMetaHaddockVersion :: !Version
+}
+
+instance FromJSON DocMeta where
+  parseJSON = withObject "DocMeta" $ \o -> do
+    JV haddockVersion <- o .: "haddock_version"
+    return DocMeta { docMetaHaddockVersion = haddockVersion }
+
+loadTarDocMeta :: MonadIO m => FilePath -> TarIndex -> PackageId -> m (Maybe DocMeta)
+loadTarDocMeta tarball docIndex pkgid =
+  case TarIndex.lookup docIndex docMetaPath of
+    Just (TarIndex.TarFileEntry docMetaEntryOff) -> do
+      docMetaEntryContent <- liftIO (loadTarEntry tarball docMetaEntryOff)
+      case docMetaEntryContent of
+        Right (_, docMetaContent) ->
+          return (parseDocMeta docMetaContent)
+        Left _ -> return Nothing
+    _ -> return Nothing
+  where
+    docMetaPath = packageDocMetaTarPath pkgid
+
+parseDocMeta :: Data.ByteString.Lazy.ByteString -> Maybe DocMeta
+parseDocMeta = decode
+
+packageDocMetaTarPath :: PackageId -> FilePath
+packageDocMetaTarPath pkgid =
+  display pkgid ++ "-docs" </> "meta.json"

datafiles/templates/Html/package-page.html.st

@@ -220,5 +220,11 @@
   $packagePageAssets()$
   $footer()$
 
+  $if(doc.hasQuickNavV1)$
+  <script src="$doc.baseUrl$/preact.js" type="text/javascript"></script>
+  <script src="$doc.baseUrl$/fuse.js" type="text/javascript"></script>
+  <script src="$doc.baseUrl$/index.js" type="text/javascript"></script>
+  <script type="text/javascript"> quickNav.init("$doc.baseUrl$", function() {}); </script>
+  $endif$
 </body>
 </html>

hackage-server.cabal

@@ -188,6 +188,7 @@ library lib-server
     Distribution.Server.Util.Histogram
     Distribution.Server.Util.CountingMap
     Distribution.Server.Util.CabalRevisions
+    Distribution.Server.Util.DocMeta              
     Distribution.Server.Util.Parse
     Distribution.Server.Util.ServeTarball
     -- [unused] Distribution.Server.Util.TarIndex