haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-17 21:35:48 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fix the Haddock mangling code (fixes #176)

Browse Source
This commit is contained in:
Michael Snoyman 2016-05-25 17:53:38 +03:00
parent 307d7bb8af
commit d49f3f5aaf
2 changed files with 21 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
Handler/Haddock.hs
View File

@ -5,8 +5,9 @@ module Handler.Haddock
import Import import Import
import Stackage.Database import Stackage.Database
import Text.HTML.TagStream.Types (Token' (..)) import Text.HTML.DOM (eventConduit)
import Text.HTML.TagStream.ByteString (tokenStream, showToken) import Text.XML (fromEvents)
import Data.XML.Types (Event (..), Content (..))
makeURL :: SnapName -> [Text] -> Text makeURL :: SnapName -> [Text] -> Text
makeURL slug rest = concat makeURL slug rest = concat
@ -15,7 +16,7 @@ makeURL slug rest = concat
: map (cons '/') rest : map (cons '/') rest
shouldRedirect :: Bool shouldRedirect :: Bool
shouldRedirect = True shouldRedirect = False
getHaddockR :: SnapName -> [Text] -> Handler TypedContent getHaddockR :: SnapName -> [Text] -> Handler TypedContent
getHaddockR slug rest getHaddockR slug rest
@ -23,20 +24,20 @@ getHaddockR slug rest
| final:_ <- reverse rest, ".html" `isSuffixOf` final = do | final:_ <- reverse rest, ".html" `isSuffixOf` final = do
render <- getUrlRender render <- getUrlRender
let stylesheet = encodeUtf8 $ render $ StaticR haddock_style_css let stylesheet = render' $ StaticR haddock_style_css
script = encodeUtf8 $ render $ StaticR haddock_script_js script = render' $ StaticR haddock_script_js
render' = return . ContentText . render
addExtra t@(TagClose "head") = addExtra t@(EventEndElement "head") =
[ TagOpen "link" [ EventBeginElement "link"
[ ("rel", "stylesheet") [ ("rel", [ContentText "stylesheet"])
, ("href", stylesheet) , ("href", stylesheet)
] ]
False , EventEndElement "link"
, TagOpen "script" , EventBeginElement "script"
[ ("src", script) [ ("src", script)
] ]
False , EventEndElement "script"
, TagClose "script"
, t , t
] ]
addExtra t = [t] addExtra t = [t]
@ -44,12 +45,13 @@ getHaddockR slug rest
req <- parseUrl $ unpack $ makeURL slug rest req <- parseUrl $ unpack $ makeURL slug rest
(_, res) <- acquireResponse req >>= allocateAcquire (_, res) <- acquireResponse req >>= allocateAcquire
respondSource typeHtml doc <- responseBody res
$ responseBody res $$ eventConduit
$= tokenStream =$ concatMapC addExtra
$= concatMapC addExtra =$ mapC (Nothing, )
-- FIXME showToken does not encode HTML entities =$ fromEvents
$= mapC (Chunk . showToken id)
sendResponse $ toHtml doc
| otherwise = redirect $ makeURL slug rest | otherwise = redirect $ makeURL slug rest
getHaddockBackupR :: [Text] -> Handler () getHaddockBackupR :: [Text] -> Handler ()

1
stackage-server.cabal
View File

@ -132,6 +132,7 @@ library
, wai-logger >= 2.2 && < 2.3 , wai-logger >= 2.2 && < 2.3
, warp >= 3.2 && < 3.3 , warp >= 3.2 && < 3.3
, xml-conduit >= 1.3 && < 1.4 , xml-conduit >= 1.3 && < 1.4
, xml-types
, yaml >= 0.8 && < 0.9 , yaml >= 0.8 && < 0.9
, yesod >= 1.4 && < 1.5 , yesod >= 1.4 && < 1.5
, yesod-auth >= 1.4 && < 1.5 , yesod-auth >= 1.4 && < 1.5