Runtime.hs

-- | What the code generated by the quasiquoter calls, and the policy it
-- applies to interpolated attribute values.
--
-- Escaping keeps a value inside its attribute, but MJML copies many
-- attributes into CSS, and a URL attribute can name a @javascript:@ link.
-- So an interpolated value is also checked for where it is going:
--
--   * a typed attribute (colour, unit, enumeration, …) must match its type;
--   * an attribute that ends up in CSS must not be able to add declarations;
--   * a URL attribute is either a 'SafeUrl' or a literal that fixes the
--     scheme, with the interpolated part percent-encoded.
--
-- A value that fails is dropped, as if the attribute had not been written.
module Text.Mjml.Hamlet.Runtime (
    -- * URLs
    SafeUrl,
    safeUrl,
    fromSafeUrl,
    ToUrl (..),
    urlPart,
    -- * Attribute policy
    urlAttributes,
    safeUrlPrefix,
    guardMjml,
    guardStyle,
    -- * Generated code
    escape,
    ToNodes (..),
    ToRawHtml (..),
    element,
) where

import Data.Char (isControl, isSpace, toLower)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Text.Blaze (Markup, ToMarkup (..))
import Text.Blaze.Renderer.Text (renderMarkup)

import Text.Mjml (Node (..), defaultRegistry)
import Text.Mjml.Schema (allowedAttributesOf, checkAttribute)


-- | @#{x}@: the value as escaped HTML.
escape :: (ToMarkup a) => a -> Text
escape = TL.toStrict . renderMarkup . toMarkup


-- | An absolute @http@, @https@ or @mailto@ URL with nothing in it that could
-- end a quoted attribute or a CSS @url('...')@.
newtype SafeUrl = SafeUrl Text
    deriving stock (Eq, Ord, Show)


safeUrl :: Text -> Maybe SafeUrl
safeUrl raw
    | hasSafeScheme t && not (T.any unsafe t) = Just (SafeUrl t)
    | otherwise = Nothing
  where
    t = T.strip raw
    hasSafeScheme u = any (`T.isPrefixOf` T.toLower u) ["https://", "http://", "mailto:"]
    unsafe c = isSpace c || isControl c || c `elem` ("'\"<>\\`" :: String)


fromSafeUrl :: SafeUrl -> Text
fromSafeUrl (SafeUrl t) = t


-- | What a URL attribute accepts as its whole value.
class ToUrl a where
    toUrl :: a -> Text


instance ToUrl SafeUrl where
    toUrl (SafeUrl t) = escape t


-- | An interpolation inside a URL whose scheme the template already fixed:
-- escaped, with the characters that could end a quoted URL percent-encoded.
urlPart :: (ToMarkup a) => a -> Text
urlPart =
    T.replace "&#39;" "%27"
        . T.replace "&quot;" "%22"
        . T.replace "&lt;" "%3C"
        . T.replace "&gt;" "%3E"
        . T.concatMap encode
        . escape
  where
    encode c
        | c == '\\' = "%5C"
        | c == '`' = "%60"
        | isSpace c || isControl c = T.pack ('%' : pad (showHex' (fromEnum c)))
        | otherwise = T.singleton c
    pad s = if length s < 2 then '0' : s else s
    showHex' n = let (q, r) = n `divMod` 16 in (if q > 0 then showHex' q else "") <> [hexDigit r]
    hexDigit d = "0123456789ABCDEF" !! d


-- | Attributes that hold a URL, on MJML elements and in HTML.
urlAttributes :: [Text]
urlAttributes =
    [ "href"
    , "src"
    , "background-url"
    , "base-url"
    , "icon-wrapped-url"
    , "icon-unwrapped-url"
    , "share-url"
    , "thumbnails-src"
    , "left-icon"
    , "right-icon"
    , "action"
    , "formaction"
    , "poster"
    , "background"
    ]


-- | Whether a URL attribute's literal start fixes what kind of URL it is,
-- so an interpolation after it cannot change the scheme.
safeUrlPrefix :: Text -> Bool
safeUrlPrefix lit =
    let l = T.toLower lit
     in any (`T.isPrefixOf` l) ["https://", "http://", "mailto:", "/", "#", "?"]


-- | String attributes of MJML elements that are plain HTML text, never CSS.
plainAttributes :: [Text]
plainAttributes =
    [ "alt"
    , "title"
    , "name"
    , "rel"
    , "target"
    , "id"
    , "sizes"
    , "srcset"
    , "usemap"
    , "mode"
    , "icon-wrapped-alt"
    , "icon-unwrapped-alt"
    , "hamburger"
    , "ico-open"
    , "ico-close"
    , "css-class"
    , "mj-class"
    , "lang"
    , "dir"
    ]


-- | An interpolated attribute of an MJML element: kept when its value suits
-- the attribute, dropped otherwise. The value is already escaped.
guardMjml :: Text -> Text -> Text -> Maybe (Text, Text)
guardMjml tag attrName value
    | attrName `elem` plainAttributes = keep
    | Just ty <- declaredType, not ("string" `T.isPrefixOf` ty) =
        case checkAttribute defaultRegistry tag attrName (Just value) of
            Nothing -> keep
            Just _ -> Nothing
    | cssSafe value = keep
    | otherwise = Nothing
  where
    keep = Just (attrName, value)
    declaredType = allowedAttributesOf defaultRegistry tag >>= lookup attrName


-- | An interpolated @style@ attribute in HTML.
guardStyle :: Text -> Maybe (Text, Text)
guardStyle value = if cssSafe value then Just ("style", value) else Nothing


-- | Whether an escaped value can sit inside a CSS declaration without adding
-- another one, opening a block, or loading anything. A single quote is
-- allowed (font names need it); any other escaped character is not.
cssSafe :: Text -> Bool
cssSafe value =
    not (T.any (`elem` (";{}\\&" :: String)) unquoted)
        && not (any (`T.isInfixOf` T.map toLower unquoted) ["url(", "expression(", "/*", "@import", "javascript:"])
  where
    unquoted = T.replace "&#39;" "'" value


-- | What @^{x}@ embeds among MJML elements.
class ToNodes a where
    toNodes :: a -> [Node]


instance ToNodes Node where
    toNodes = pure


instance (ToNodes a) => ToNodes [a] where
    toNodes = concatMap toNodes


instance (ToNodes a) => ToNodes (Maybe a) where
    toNodes = maybe [] toNodes


-- | What @^{x}@ embeds inside an ending tag: markup that is already HTML.
class ToRawHtml a where
    toRawHtml :: a -> Text


instance ToRawHtml Markup where
    toRawHtml = TL.toStrict . renderMarkup


element :: Text -> [(Text, Text)] -> [Node] -> Text -> Node
element name attrs kids body = Node name attrs kids (T.strip body)