-- | A HTML type, useful for implementing type-safe conversion between plain
-- text and HTML.
-- The HTML representation used here assumed Unicode throughout, and UTF-8
-- should be used as the encoding when sending @Html@ objects as responses to a
-- HTTP client.
{-#LANGUAGE GeneralizedNewtypeDeriving #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE FlexibleInstances #-}
module Text.Ginger.Html
( Html
, unsafeRawHtml
, html
, htmlSource
, ToHtml (..)
)
where

import Data.Text (Text)
import qualified Data.Text as Text
import Data.Semigroup as Semigroup

-- | A chunk of HTML source.
newtype Html = Html { Html -> Text
unHtml :: Text }
    deriving (NonEmpty Html -> Html
Html -> Html -> Html
forall b. Integral b => b -> Html -> Html
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Html -> Html
$cstimes :: forall b. Integral b => b -> Html -> Html
sconcat :: NonEmpty Html -> Html
$csconcat :: NonEmpty Html -> Html
<> :: Html -> Html -> Html
$c<> :: Html -> Html -> Html
Semigroup.Semigroup, Semigroup Html
Html
[Html] -> Html
Html -> Html -> Html
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Html] -> Html
$cmconcat :: [Html] -> Html
mappend :: Html -> Html -> Html
$cmappend :: Html -> Html -> Html
mempty :: Html
$cmempty :: Html
Monoid, Int -> Html -> ShowS
[Html] -> ShowS
Html -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Html] -> ShowS
$cshowList :: [Html] -> ShowS
show :: Html -> String
$cshow :: Html -> String
showsPrec :: Int -> Html -> ShowS
$cshowsPrec :: Int -> Html -> ShowS
Show, Html -> Html -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Html -> Html -> Bool
$c/= :: Html -> Html -> Bool
== :: Html -> Html -> Bool
$c== :: Html -> Html -> Bool
Eq, Eq Html
Html -> Html -> Bool
Html -> Html -> Ordering
Html -> Html -> Html
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Html -> Html -> Html
$cmin :: Html -> Html -> Html
max :: Html -> Html -> Html
$cmax :: Html -> Html -> Html
>= :: Html -> Html -> Bool
$c>= :: Html -> Html -> Bool
> :: Html -> Html -> Bool
$c> :: Html -> Html -> Bool
<= :: Html -> Html -> Bool
$c<= :: Html -> Html -> Bool
< :: Html -> Html -> Bool
$c< :: Html -> Html -> Bool
compare :: Html -> Html -> Ordering
$ccompare :: Html -> Html -> Ordering
Ord)

-- | Types that support conversion to HTML.
class ToHtml s where
    toHtml :: s -> Html

-- | Text is automatically HTML-encoded
instance ToHtml Text where
    toHtml :: Text -> Html
toHtml = Text -> Html
html

-- | String is automatically HTML-encoded and converted to 'Text'
instance ToHtml [Char] where
    toHtml :: String -> Html
toHtml = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Html
htmlEncodeChar

-- | Html itself is a trivial instance
instance ToHtml Html where
    toHtml :: Html -> Html
toHtml = forall a. a -> a
id

-- | Extract HTML source code from an @Html@ value.
htmlSource :: Html -> Text
htmlSource :: Html -> Text
htmlSource = Html -> Text
unHtml

-- | Convert a chunk of HTML source code into an @Html@ value as-is. Note that
-- this bypasses any and all HTML encoding; the caller is responsible for
-- taking appropriate measures against XSS and other potential vulnerabilities.
-- In other words, the input to this function is considered pre-sanitized.
unsafeRawHtml :: Text -> Html
unsafeRawHtml :: Text -> Html
unsafeRawHtml = Text -> Html
Html

-- | Safely convert plain text to HTML.
html :: Text -> Html
html :: Text -> Html
html = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Html
htmlEncodeChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

-- | HTML-encode an individual character.
htmlEncodeChar :: Char -> Html
htmlEncodeChar :: Char -> Html
htmlEncodeChar Char
'&' = Text -> Html
Html Text
"&amp;"
htmlEncodeChar Char
'"' = Text -> Html
Html Text
"&quot;"
htmlEncodeChar Char
'\'' = Text -> Html
Html Text
"&apos;"
htmlEncodeChar Char
'<' = Text -> Html
Html Text
"&lt;"
htmlEncodeChar Char
'>' = Text -> Html
Html Text
"&gt;"
htmlEncodeChar Char
c = Text -> Html
Html forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
c