19b0c72 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Made HTML reader much more forgiving.

19b0c72fiddlosopher17 years ago

src/Text/Pandoc/Readers/HTML.hs+106−29

compare with master

unifiedsplit

@@ -50,6 +50,7 @@ import Data.Maybe ( fromMaybe )

50import Data.List ( isPrefixOf, isSuffixOf, intercalate )

51import Data.Char ( toLower, isAlphaNum )

52import Network.URI ( parseURIReference, URI (..) )

53+import Control.Monad ( liftM )

54-- | Convert HTML-formatted string to 'Pandoc' document.

55-- | Convert HTML-formatted string to 'Pandoc' document.

55readHtml :: ParserState -- ^ Parser state

56readHtml :: ParserState -- ^ Parser state

@@ -71,7 +72,7 @@ inlineHtmlTags = ["a", "abbr", "acronym", "b", "basefont", "bdo", "big",

71 "br", "cite", "code", "dfn", "em", "font", "i", "img",

72 "br", "cite", "code", "dfn", "em", "font", "i", "img",

72 "input", "kbd", "label", "q", "s", "samp", "select",

73 "input", "kbd", "label", "q", "s", "samp", "select",

73 "small", "span", "strike", "strong", "sub", "sup",

74 "small", "span", "strike", "strong", "sub", "sup",

74− "textarea", "tt", "u", "var"] ++ eitherBlockOrInline

75+ "textarea", "tt", "u", "var"]

75-}

76-}

77blockHtmlTags :: [[Char]]

78blockHtmlTags :: [[Char]]

@@ -80,7 +81,7 @@ blockHtmlTags = ["address", "blockquote", "body", "center", "dir", "div",

80 "h5", "h6", "head", "hr", "html", "isindex", "menu", "noframes",

81 "h5", "h6", "head", "hr", "html", "isindex", "menu", "noframes",

81 "noscript", "ol", "p", "pre", "table", "ul", "dd",

82 "noscript", "ol", "p", "pre", "table", "ul", "dd",

82 "dt", "frameset", "li", "tbody", "td", "tfoot",

83 "dt", "frameset", "li", "tbody", "td", "tfoot",

83− "th", "thead", "tr", "script"] ++ eitherBlockOrInline

84+ "th", "thead", "tr", "script", "style"]

85sanitaryTags :: [[Char]]

86sanitaryTags :: [[Char]]

86sanitaryTags = ["a", "abbr", "acronym", "address", "area", "b", "big",

87sanitaryTags = ["a", "abbr", "acronym", "address", "area", "b", "big",

@@ -112,6 +113,40 @@ sanitaryAttributes = ["abbr", "accept", "accept-charset",

112 "summary", "tabindex", "target", "title", "type",

113 "summary", "tabindex", "target", "title", "type",

113 "usemap", "valign", "value", "vspace", "width"]

114 "usemap", "valign", "value", "vspace", "width"]

114

115

116+-- taken from HXT and extended

117+

118+closes :: String -> String -> Bool

119+"EOF" `closes` _ = True

120+_ `closes` "body" = False

121+_ `closes` "html" = False

122+"a" `closes` "a" = True

123+"li" `closes` "li" = True

124+"th" `closes` t | t `elem` ["th","td"] = True

125+"td" `closes` t | t `elem` ["th","td"] = True

126+"tr" `closes` t | t `elem` ["th","td","tr"] = True

127+"dt" `closes` t | t `elem` ["dt","dd"] = True

128+"dd" `closes` t | t `elem` ["dt","dd"] = True

129+"hr" `closes` "p" = True

130+"p" `closes` "p" = True

131+"meta" `closes` "meta" = True

132+"colgroup" `closes` "colgroup" = True

133+"form" `closes` "form" = True

134+"label" `closes` "label" = True

135+"map" `closes` "map" = True

136+"object" `closes` "object" = True

137+_ `closes` t | t `elem` ["option","style","script","textarea","title"] = True

138+t `closes` "select" | t /= "option" = True

139+"thead" `closes` t | t `elem` ["colgroup"] = True

140+"tfoot" `closes` t | t `elem` ["thead","colgroup"] = True

141+"tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True

142+t `closes` t2 |

143+ t `elem` ["h1","h2","h3","h4","h5","h6","dl","ol","ul","table","div","p"] &&

144+ t2 `elem` ["h1","h2","h3","h4","h5","h6","p" ] = True -- not "div"

145+t1 `closes` t2 |

146+ t1 `elem` blockHtmlTags &&

147+ t2 `notElem` (blockHtmlTags ++ eitherBlockOrInline) = True

148+_ `closes` _ = False

149+

115--

150--

116-- HTML utility functions

151-- HTML utility functions

117--

152--

@@ -176,6 +211,19 @@ extractTagType ('<':rest) =

176 map toLower $ takeWhile isAlphaNum $ dropWhile isSpaceOrSlash rest

211 map toLower $ takeWhile isAlphaNum $ dropWhile isSpaceOrSlash rest

177extractTagType _ = ""

212extractTagType _ = ""

178

213

214+-- Parse any HTML tag (opening or self-closing) and return tag type

215+anyOpener :: GenParser Char ParserState [Char]

216+anyOpener = try $ do

217+ char '<'

218+ spaces

219+ tag <- many1 alphaNum

220+ skipMany htmlAttribute

221+ spaces

222+ option "" (string "/")

223+ spaces

224+ char '>'

225+ return $ map toLower tag

226+

179-- | Parse any HTML tag (opening or self-closing) and return text of tag

227-- | Parse any HTML tag (opening or self-closing) and return text of tag

180anyHtmlTag :: GenParser Char ParserState [Char]

228anyHtmlTag :: GenParser Char ParserState [Char]

181anyHtmlTag = try $ do

229anyHtmlTag = try $ do

@@ -257,32 +305,30 @@ htmlRegularAttribute = try $ do

257 (content, quoteStr) <- choice [ (quoted '\''),

305 (content, quoteStr) <- choice [ (quoted '\''),

258 (quoted '"'),

306 (quoted '"'),

259 (do

307 (do

260− a <- many (alphaNum <|> (oneOf "-._:"))

308+ a <- many (noneOf " \t\n\r\"'<>")

261 return (a,"")) ]

309 return (a,"")) ]

262 return (name, content,

310 return (name, content,

263 (name ++ "=" ++ quoteStr ++ content ++ quoteStr))

311 (name ++ "=" ++ quoteStr ++ content ++ quoteStr))

264

312

265-- | Parse an end tag of type 'tag'

313-- | Parse an end tag of type 'tag'

266−htmlEndTag :: [Char] -> GenParser Char st [Char]

314+htmlEndTag :: [Char] -> GenParser Char ParserState [Char]

267htmlEndTag tag = try $ do

315htmlEndTag tag = try $ do

316+ closedByNext <- lookAhead $ option False $ liftM (`closes` tag) $

317+ anyOpener <|> (eof >> return "EOF")

318+ if closedByNext

319+ then return ""

268− char '<'

320+ else do char '<'

269− spaces

321+ spaces

270− char '/'

322+ char '/'

271− spaces

323+ spaces

272− stringAnyCase tag

324+ stringAnyCase tag

273− spaces

325+ spaces

274− char '>'

326+ char '>'

275− return $ "</" ++ tag ++ ">"

327+ return $ "</" ++ tag ++ ">"

276−

277−{-

278−-- | Returns @True@ if the tag is (or can be) an inline tag.

279−isInline :: String -> Bool

280−isInline tag = (extractTagType tag) `elem` inlineHtmlTags

281−-}

282

328

283-- | Returns @True@ if the tag is (or can be) a block tag.

329-- | Returns @True@ if the tag is (or can be) a block tag.

284isBlock :: String -> Bool

330isBlock :: String -> Bool

285−isBlock tag = (extractTagType tag) `elem` blockHtmlTags

331+isBlock tag = (extractTagType tag) `elem` (blockHtmlTags ++ eitherBlockOrInline)

286

332

287anyHtmlBlockTag :: GenParser Char ParserState [Char]

333anyHtmlBlockTag :: GenParser Char ParserState [Char]

288anyHtmlBlockTag = try $ do

334anyHtmlBlockTag = try $ do

@@ -298,18 +344,43 @@ anyHtmlInlineTag = try $ do

298-- Scripts must be treated differently, because they can contain '<>' etc.

344-- Scripts must be treated differently, because they can contain '<>' etc.

299htmlScript :: GenParser Char ParserState [Char]

345htmlScript :: GenParser Char ParserState [Char]

300htmlScript = try $ do

346htmlScript = try $ do

301− open <- string "<script"

347+ lookAhead $ htmlTag "script"

348+ open <- anyHtmlTag

302− rest <- manyTill anyChar (htmlEndTag "script")

349+ rest <- liftM concat $ manyTill scriptChunk (htmlEndTag "script")

303 st <- getState

350 st <- getState

304 if stateSanitizeHTML st && not ("script" `elem` sanitaryTags)

351 if stateSanitizeHTML st && not ("script" `elem` sanitaryTags)

305 then return ""

352 then return ""

306 else return $ open ++ rest ++ "</script>"

353 else return $ open ++ rest ++ "</script>"

307

354

355+scriptChunk :: GenParser Char ParserState [Char]

356+scriptChunk = jsComment <|> jsString <|> jsChars

357+ where jsComment = jsEndlineComment <|> jsMultilineComment

358+ jsString = jsSingleQuoteString <|> jsDoubleQuoteString

359+ jsChars = many1 (noneOf "<\"'*/") <|> count 1 anyChar

360+ jsEndlineComment = try $ do

361+ string "//"

362+ res <- manyTill anyChar newline

363+ return ("//" ++ res)

364+ jsMultilineComment = try $ do

365+ string "/*"

366+ res <- manyTill anyChar (try $ string "*/")

367+ return ("/*" ++ res ++ "*/")

368+ jsSingleQuoteString = stringwith '\''

369+ jsDoubleQuoteString = stringwith '"'

370+ charWithEsc escapable = try $

371+ (try $ char '\\' >> oneOf ('\\':escapable) >>= \x -> return ['\\',x])

372+ <|> count 1 anyChar

373+ stringwith c = try $ do

374+ char c

375+ res <- liftM concat $ manyTill (charWithEsc [c]) (char c)

376+ return (c : (res ++ [c]))

377+

308-- | Parses material between style tags.

378-- | Parses material between style tags.

309-- Style tags must be treated differently, because they can contain CSS

379-- Style tags must be treated differently, because they can contain CSS

310htmlStyle :: GenParser Char ParserState [Char]

380htmlStyle :: GenParser Char ParserState [Char]

311htmlStyle = try $ do

381htmlStyle = try $ do

312− open <- string "<style"

382+ lookAhead $ htmlTag "style"

383+ open <- anyHtmlTag

313 rest <- manyTill anyChar (htmlEndTag "style")

384 rest <- manyTill anyChar (htmlEndTag "style")

314 st <- getState

385 st <- getState

315 if stateSanitizeHTML st && not ("style" `elem` sanitaryTags)

386 if stateSanitizeHTML st && not ("style" `elem` sanitaryTags)

@@ -404,6 +475,14 @@ bodyTitle = try $ do

404 _ -> fail "not title"

475 _ -> fail "not title"

405 inlinesTilEnd "h1"

476 inlinesTilEnd "h1"

406

477

478+endOfDoc :: GenParser Char ParserState ()

479+endOfDoc = try $ do

480+ spaces

481+ optional (htmlEndTag "body")

482+ spaces

483+ optional (htmlEndTag "html" >> many anyChar) -- ignore stuff after </html>

484+ eof

485+

407parseHtml :: GenParser Char ParserState Pandoc

486parseHtml :: GenParser Char ParserState Pandoc

408parseHtml = do

487parseHtml = do

409 sepEndBy (choice [xmlDec, definition, htmlComment]) spaces

488 sepEndBy (choice [xmlDec, definition, htmlComment]) spaces

@@ -415,11 +494,7 @@ parseHtml = do

415 spaces

494 spaces

416 optional bodyTitle -- skip title in body, because it's represented in meta

495 optional bodyTitle -- skip title in body, because it's represented in meta

417 blocks <- parseBlocks

496 blocks <- parseBlocks

418− spaces

497+ endOfDoc

419− optional (htmlEndTag "body")

420− spaces

421− optional (htmlEndTag "html" >> many anyChar) -- ignore anything after </html>

422− eof

423 return $ Pandoc meta blocks

498 return $ Pandoc meta blocks

424

499

425--

500--

@@ -438,6 +513,7 @@ block = choice [ codeBlock

438 , para

513 , para

439 , plain

514 , plain

440 , rawHtmlBlock'

515 , rawHtmlBlock'

516+ , notFollowedBy' endOfDoc >> char '<' >> return Null

441 ] <?> "block"

517 ] <?> "block"

442

518

443--

519--

@@ -586,6 +662,7 @@ inline = choice [ charRef

586 , link

662 , link

587 , image

663 , image

588 , rawHtmlInline

664 , rawHtmlInline

665+ , char '&' >> return (Str "&") -- common HTML error

589 ] <?> "inline"

666 ] <?> "inline"

590

667

591code :: GenParser Char ParserState Inline

668code :: GenParser Char ParserState Inline

@@ -599,7 +676,7 @@ code = try $ do

599

676

600rawHtmlInline :: GenParser Char ParserState Inline

677rawHtmlInline :: GenParser Char ParserState Inline

601rawHtmlInline = do

678rawHtmlInline = do

602− result <- htmlScript <|> htmlStyle <|> htmlComment <|> anyHtmlInlineTag

679+ result <- anyHtmlInlineTag <|> htmlComment

603 state <- getState

680 state <- getState

604 if stateParseRaw state then return (HtmlInline result) else return (Str "")

681 if stateParseRaw state then return (HtmlInline result) else return (Str "")

605

682

@@ -640,7 +717,7 @@ linebreak :: GenParser Char ParserState Inline

640linebreak = htmlTag "br" >> optional newline >> return LineBreak

717linebreak = htmlTag "br" >> optional newline >> return LineBreak

641

718

642str :: GenParser Char st Inline

719str :: GenParser Char st Inline

643−str = many1 (noneOf "<& \t\n") >>= return . Str

720+str = many1 (noneOf "< \t\n&") >>= return . Str

644

721

645--

722--

646-- links and images

723-- links and images