WIP: Validate doc-index.json on doctarball upload

Distribution/Server/Features/Documentation.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE RankNTypes, FlexibleContexts,
-             NamedFieldPuns, RecordWildCards, PatternGuards #-}
+             NamedFieldPuns, OverloadedStrings,
+             RecordWildCards, PatternGuards #-}
 module Distribution.Server.Features.Documentation (
     DocumentationFeature(..),
     DocumentationResource(..),
@@ -28,9 +29,14 @@ import Distribution.Version (nullVersion)
 
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Map as Map
+import Data.Foldable (for_)
 import Data.Function (fix)
 
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
 import Data.Aeson (toJSON)
+import qualified Text.HTML.TagSoup       as TagSoup
+import qualified Text.HTML.TagSoup.Match as TagSoup
 
 import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
 import System.Directory (getModificationTime)
@@ -316,7 +322,7 @@ documentationFeature name
 
       case pkgVersion pkgid == nullVersion of
         -- if no version is given we want to redirect to the latest version
-        True -> tempRedirect latestPkgPath (toResponse "")
+        True -> tempRedirect latestPkgPath (toResponse BSL.empty)
           where
             latest = packageId pkginfo
             dpath' = [ if var == "package"
@@ -352,13 +358,60 @@ documentationFeature name
 checkDocTarball :: PackageId -> BSL.ByteString -> Either String ()
 checkDocTarball pkgid =
      checkEntries
-   . fmapErr (either id show) . Tar.checkTarbomb (display pkgid ++ "-docs")
+   . fmapErr (either id show) . Tar.checkTarbomb pkgDocsDir
    . fmapErr (either id show) . Tar.checkSecurity
    . fmapErr (either id show) . Tar.checkPortability
    . fmapErr show             . Tar.read
   where
+    pkgDocsDir = display pkgid ++ "-docs"
+
     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 == pkgDocsDir </> "doc-index.json"
+      = case Tar.entryContent entry of
+          Tar.NormalFile content _ -> checkJsonDocIndex content
+          _                        -> Left "doc-index.json not a file"
+      | otherwise
+      = remainder
+
+checkJsonDocIndex :: BSL.ByteString -> Either String ()
+checkJsonDocIndex jsDocIndex
+  | Just (Aeson.Array entries) <- Aeson.decode jsDocIndex
+  = for_ entries $ \entry -> do
+      case extractDisplayHtml entry of
+        Just displayHtml -> checkDisplayHtml displayHtml
+        _                -> Left "Expected display_html property"
+  | otherwise
+  = Left "Expected an array element"
+  where
+    extractDisplayHtml (Aeson.Object o) = do
+      Aeson.String displayHtml <- HashMap.lookup "display_html" o
+      return displayHtml
+    extractDisplayHtml _ = Nothing
+
+    checkDisplayHtml displayHtml =
+      checkTags (TagSoup.parseTagsOptions TagSoup.parseOptionsFast displayHtml)
+
+    checkTags [] = Right ()
+    checkTags (t:tx)
+      | TagSoup.tagOpen hasValidTag hasValidAttrs t
+        || TagSoup.tagClose hasValidTag t
+        || TagSoup.tagText (const True) t
+      = checkTags tx
+      | otherwise
+      = Left "Disallowed element found"
+
+    hasValidTag t   = t `elem` whitelistedTags
+    hasValidAttrs _ = True
+
+    whitelistedTags =
+      [ "a"
+      , "span"
+      , "ul"
+      , "li"
+      ]
 
 {------------------------------------------------------------------------------
   Auxiliary

hackage-server.cabal

@@ -347,6 +347,7 @@ library lib-server
                , split                 ^>= 0.2
                , stm                   ^>= 2.4
                , tagged                ^>= 0.8.5
+               , tagsoup               ^>= 0.14
                , tar                   ^>= 0.5
                , text                  ^>= 1.2.2
                , time-locale-compat    ^>= 0.1.0.1