diff --git a/Distribution/Server/Features/Documentation.hs b/Distribution/Server/Features/Documentation.hs index 63a7d8607..3f7687c2c 100644 --- a/Distribution/Server/Features/Documentation.hs +++ b/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 diff --git a/hackage-server.cabal b/hackage-server.cabal index a075ee5a3..32a181735 100644 --- a/hackage-server.cabal +++ b/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