hsp-0.8.0: src/HSP/HTML4.hs
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : HSP.HTML4
-- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008-2012
-- License : BSD-style (see the file LICENSE.txt)
--
-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com
-- Stability : experimental
-- Portability : Haskell 98
--
-- Attempt to render XHTML as well-formed HTML 4.01:
--
-- 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>
--
-- 2. the end tag is forbidden for some elements, for these we:
--
-- * render only the open tag, e.g., \<br\>
--
-- * throw an error if the tag contains children
--
-- 3. optional end tags are always rendered
--
-- Currently no validation is performed.
-----------------------------------------------------------------------------
module HSP.HTML4
( -- * Functions
renderAsHTML
, htmlEscapeChars
-- * Predefined XMLMetaData
, html4Strict
, html4StrictFrag
) where
import Data.List (intersperse)
import Data.Monoid ((<>), mconcat)
import Data.String (fromString)
import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText)
import Data.Text.Lazy (Text)
import HSP.XML ( Attribute(..), Attributes, AttrValue(..), Children
, Name, XML(..), XMLMetaData(..))
import HSP.XML.PCDATA (escaper)
data TagType = Open | Close
-- This list should be extended.
htmlEscapeChars :: [(Char, Builder)]
htmlEscapeChars = [
('&', fromString "amp" ),
('\"', fromString "quot" ),
('<', fromString "lt" ),
('>', fromString "gt" )
]
renderTag :: TagType -> Int -> Name -> Attributes -> Builder
renderTag typ n name attrs =
let (start,end) = case typ of
Open -> (singleton '<', singleton '>')
Close -> (fromString "</", singleton '>')
nam = showName name
as = renderAttrs attrs
in mconcat [start, nam, as, end]
where renderAttrs :: Attributes -> Builder
renderAttrs [] = nl
renderAttrs attrs' = singleton ' ' <> mconcat ats <> nl
where ats = intersperse (singleton ' ') $ fmap renderAttr attrs'
renderAttr :: Attribute -> Builder
renderAttr (MkAttr (nam, (Value needsEscape val))) =
showName nam <> singleton '=' <> renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else fromLazyText val)
renderAttrVal :: Builder -> Builder
renderAttrVal s = singleton '\"' <> s <> singleton '\"'
showName (Nothing, s) = fromLazyText s
showName (Just d, s) = fromLazyText d <> singleton ':' <> fromLazyText s
nl = singleton '\n' <> fromString (replicate n ' ')
renderElement :: Int -> XML -> Builder
renderElement n (Element name attrs children) =
let open = renderTag Open n name attrs
cs = renderChildren n children
close = renderTag Close n name []
in open <> cs <> close
where renderChildren :: Int -> Children -> Builder
renderChildren n' cs = mconcat $ map (renderAsHTML' (n'+2)) cs
renderElement _ _ = error "internal error: renderElement only suports the Element constructor."
renderAsHTML' :: Int -> XML -> Builder
renderAsHTML' _ (CDATA needsEscape cd) = if needsEscape then (escaper htmlEscapeChars cd) else fromLazyText cd
renderAsHTML' n elm@(Element name@(Nothing,nm) attrs children)
| nm == "area" = renderTagEmpty children
| nm == "base" = renderTagEmpty children
| nm == "br" = renderTagEmpty children
| nm == "col" = renderTagEmpty children
| nm == "hr" = renderTagEmpty children
| nm == "img" = renderTagEmpty children
| nm == "input" = renderTagEmpty children
| nm == "link" = renderTagEmpty children
| nm == "meta" = renderTagEmpty children
| nm == "param" = renderTagEmpty children
| nm == "script" = renderElement n (Element name attrs (map asCDATA children))
| nm == "style" = renderElement n (Element name attrs (map asCDATA children))
where
renderTagEmpty [] = renderTag Open n name attrs
renderTagEmpty _ = renderElement n elm -- this case should not happen in valid HTML
-- for and script\/style, render text in element as CDATA not PCDATA
asCDATA :: XML -> XML
asCDATA (CDATA _ cd) = (CDATA False cd)
asCDATA o = o -- this case should not happen in valid HTML
renderAsHTML' n e = renderElement n e
-- | Pretty-prints HTML values.
--
-- Error Handling:
--
-- Some tags (such as img) can not contain children in HTML. However,
-- there is nothing to stop the caller from passing in XML which
-- contains an img tag with children. There are three basic ways to
-- handle this:
--
-- 1. drop the bogus children silently
--
-- 2. call 'error' \/ raise an exception
--
-- 3. render the img tag with children -- even though it is invalid
--
-- Currently we are taking approach #3, since no other attempts to
-- validate the data are made in this function. Instead, you can run
-- the output through a full HTML validator to detect the errors.
--
-- #1 seems like a poor choice, since it makes is easy to overlook the
-- fact that data went missing.
--
-- We could raising errors, but you have to be in the IO monad to
-- catch them. Also, you have to use evaluate if you want to check for
-- errors. This means you can not start sending the page until the
-- whole page has been rendered. And you have to store the whole page
-- in RAM at once. Similar problems occur if we return Either
-- instead. We mostly care about catching errors and showing them in
-- the browser during testing, so perhaps this can be configurable.
--
-- Another solution would be a compile time error if an empty-only
-- tag contained children.
--
-- FIXME: also verify that the domain is correct
--
-- FIXME: what to do if a namespace is encountered
renderAsHTML :: XML -> Text
renderAsHTML xml = toLazyText $ renderAsHTML' 0 xml
-- * Pre-defined XMLMetaData
html4Strict :: Maybe XMLMetaData
html4Strict = Just $
XMLMetaData { doctype = (True, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
, contentType = "text/html;charset=utf-8"
, preferredRenderer = renderAsHTML' 0
}
html4StrictFrag :: Maybe XMLMetaData
html4StrictFrag = Just $
XMLMetaData { doctype = (False, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
, contentType = "text/html;charset=utf-8"
, preferredRenderer = renderAsHTML' 0
}