diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mjml-hamlet + +## 0.1.0.0 -- 2026-10-31 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Kronor + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,97 @@ +# mjml-hamlet + +[MJML](https://mjml.io) email templates written in Hamlet's syntax and checked +at compile time. Rendering goes through the [`mjml`](https://github.com/kronor-io/mjml/tree/main/mjml) package, so +there is no Node.js involved at build time or at runtime. For what MJML is and +a full example with screenshots, see the [repository README](https://github.com/kronor-io/mjml#readme). + +```haskell +{-# LANGUAGE QuasiQuotes #-} + +import Text.Mjml.Hamlet (mjml, renderMjml) + +shipped :: Order -> Either MjmlError Text +shipped order = + renderMjml + [mjml| + + + Your order #{order.reference} is on its way + $forall line <- order.lines + #{line.name} × #{line.quantity} + $maybe url <- order.trackingUrl + Track it + |] +``` + +## Syntax + +As in Hamlet, nesting is given by indentation and there are no closing tags. + +* `Hi` is an element; text after the tag on the same + line is its content. Attribute values may be quoted, unquoted, or an + interpolation (`href=#{url}`). `.name` adds a class (`css-class` on MJML + elements, `class` on HTML ones). +* `#{expr}` interpolates any `ToMarkup` value, escaped. Expressions are + Hamlet's: variables, application, operators, literals and record fields + (`order.lines`), but no type annotations or lambdas. +* `^{expr}` embeds what was built elsewhere: nodes (`Node`, `[Node]`, + `Maybe Node`) among MJML elements, or blaze `Markup` inside an ending tag. +* `$forall pattern <- expr`, `$if` / `$elseif` / `$else`, + `$maybe pattern <- expr` / `$nothing`, `$case expr` with nested + `$of pattern` lines, and `$with pattern <- expr` work as in Hamlet. `$#` + starts a comment line. +* Inside an ending tag (`mj-text`, `mj-button`, `mj-raw`, `mj-table`, …) the + nested lines are HTML. Consecutive text lines are joined with a space; a + leading `\` keeps a line's leading space. + +`mjmlFile "templates/shipped.mjml"` reads the same syntax from a file and +recompiles when the file changes. + +A template is a list of nodes. `renderMjml` renders a whole document rooted at +`` as it is, wraps a template made of `` and `` in +``, and wraps anything else in ``, so a template can be +just the sections of an email. + +## Escaping and injection + +`#{...}` escapes `<`, `>`, `&`, `"` and `'`, so an interpolated value cannot +leave its text or attribute. Because MJML copies many attributes into CSS and +some are URLs, interpolated attribute values are also checked for where they +are going: + +* **URLs** (`href`, `src`, `background-url`, …) take either a single + `#{url}` of type `SafeUrl`, which `safeUrl` only builds for `https`, + `http` and `mailto` URLs with no quotes or spaces in them, or a literal that + fixes the scheme, as in `href="https://example.com/o/#{ref}"`, where the + interpolated part is percent-encoded. Anything else does not compile. +* **Typed attributes** (colours, units, enumerations) must match their type + when the email is rendered. +* **Other attributes that end up in CSS**, and `style` on HTML elements, must + not contain anything that could add a declaration: `;`, braces, + backslashes, comments, `url(` or `@import`. +* **Event handlers** (`onclick`, …) cannot be interpolated at all. + +A value that fails at render time is dropped, as if the attribute had not been +written. `^{...}` embeds markup without escaping and cannot be used in +attribute values. + +## What does not compile + +The checks MJML's validator makes at runtime happen at compile time, with the +template's line and column: + +``` +Shipped.hs:12:39: Attribute align has invalid value: middle for type Enum, only accepts left, right, center, justify +``` + +* an unknown element, or HTML outside an ending tag; +* an element inside a parent MJML does not allow (`mj-text` directly in + `mj-section`); +* an attribute the element does not declare; +* a literal attribute value of the wrong type (units, colours, enumerations); +* text outside an ending tag. + +## License + +MIT. diff --git a/mjml-hamlet.cabal b/mjml-hamlet.cabal new file mode 100644 --- /dev/null +++ b/mjml-hamlet.cabal @@ -0,0 +1,68 @@ +cabal-version: 3.0 +name: mjml-hamlet +version: 0.1.0.0 +synopsis: MJML email templates in Hamlet syntax, checked at compile time +description: + A quasiquoter for MJML documents written with Hamlet's indentation-based + syntax and interpolation. Unknown elements, misplaced elements, undeclared + attributes and attribute values of the wrong type are compile errors. +license: MIT +license-file: LICENSE +author: José Lorenzo Rodríguez +maintainer: lorenzo@kronor.io +copyright: 2026 Kronor +category: Text, Web, Email +build-type: Simple +extra-doc-files: CHANGELOG.md + README.md +tested-with: GHC ==9.10.3 || ==9.12.4 || ==9.14.1 + +common warnings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + +library + import: warnings + hs-source-dirs: src + default-language: GHC2021 + default-extensions: + OverloadedStrings + LambdaCase + MultiWayIf + DerivingStrategies + OverloadedRecordDot + exposed-modules: + Text.Mjml.Hamlet + Text.Mjml.Hamlet.Check + Text.Mjml.Hamlet.Runtime + Text.Mjml.Hamlet.Syntax + Text.Mjml.Hamlet.TH + build-depends: + base >=4.20 && <5 + , blaze-markup >=0.8 && <0.9 + , containers >=0.6 && <0.9 + , megaparsec >=9.6 && <9.9 + , mjml ==0.1.* + , parsec >=3.1 && <3.2 + , shakespeare >=2.1 && <2.3 + , template-haskell >=2.22 && <2.25 + , text >=2.0 && <2.2 + +test-suite spec + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Readme + default-language: GHC2021 + default-extensions: + OverloadedStrings + QuasiQuotes + OverloadedRecordDot + build-depends: + base + , blaze-markup + , containers + , mjml + , mjml-hamlet + , text diff --git a/src/Text/Mjml/Hamlet.hs b/src/Text/Mjml/Hamlet.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mjml/Hamlet.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | MJML templates in Hamlet's syntax, checked at compile time. +-- +-- > shipped :: Order -> [Node] +-- > shipped order = +-- > [mjml| +-- > +-- > +-- > Your order #{order.reference} is on its way +-- > $forall line <- order.lines +-- > #{line.name} × #{line.quantity} +-- > $maybe url <- order.trackingUrl +-- > Track it +-- > |] +-- +-- Nesting is by indentation, with no closing tags. @$forall@, @$if@, +-- @$maybe@, @$case@ and @$with@ work as in Hamlet; @#{...}@ interpolates an +-- escaped value and @^{...}@ embeds nodes, or markup inside an ending tag. +-- +-- A template that names an unknown element, puts an element where MJML does +-- not allow it, uses an attribute the element does not declare, or gives a +-- literal attribute a value of the wrong type does not compile. +module Text.Mjml.Hamlet ( + mjml, + mjmlFile, + renderMjml, + SafeUrl, + safeUrl, + fromSafeUrl, + ToNodes (..), + ToRawHtml (..), +) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Language.Haskell.TH (Exp, Q, runIO) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax (Loc (..), addDependentFile, location) + +import Text.Mjml (MjmlError, Node (..), defaultOptions, defaultRegistry, endingTagNames, renderNode) +import Text.Mjml.Hamlet.Runtime (SafeUrl, ToNodes (..), ToRawHtml (..), fromSafeUrl, safeUrl) +import Text.Mjml.Hamlet.TH (Source (..), compileTemplate) + + +-- | A template, as an expression of type @['Node']@. +mjml :: QuasiQuoter +mjml = + QuasiQuoter + { quoteExp = \s -> do + loc <- location + let (l, c) = loc_start loc + compile (Source (loc_filename loc) l (c + length ("[mjml|" :: String))) (T.pack s) + , quotePat = const (fail "mjml: only expressions are supported") + , quoteType = const (fail "mjml: only expressions are supported") + , quoteDec = const (fail "mjml: only expressions are supported") + } + + +-- | A template read from a file, recompiled when the file changes. +mjmlFile :: FilePath -> Q Exp +mjmlFile path = do + addDependentFile path + body <- runIO (T.readFile path) + compile (Source path 1 1) body + + +compile :: Source -> Text -> Q Exp +compile = compileTemplate defaultRegistry (endingTagNames defaultRegistry) + + +-- | Render a template. A template that is a whole document (rooted at +-- @mjml@) renders as it is; one made of @mj-head@ and @mj-body@ is wrapped +-- in @mjml@, and anything else in @mjml@ and @mj-body@. +renderMjml :: [Node] -> Either MjmlError Text +renderMjml nodes = renderNode defaultOptions $ case nodes of + [n] | tagName n == "mjml" -> n + _ + | any ((`elem` ["mj-head", "mj-body"]) . tagName) nodes -> Node "mjml" [] nodes "" + | otherwise -> Node "mjml" [] [Node "mj-body" [] nodes ""] "" diff --git a/src/Text/Mjml/Hamlet/Check.hs b/src/Text/Mjml/Hamlet/Check.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mjml/Hamlet/Check.hs @@ -0,0 +1,119 @@ +-- | What the quasiquoter rejects before generating any code: the checks +-- MJML's validator makes, done at compile time. +-- +-- Every element must be an MJML element, sit inside a parent that accepts it, +-- and carry only attributes it declares; an attribute written as a literal +-- must also have a value of the declared type. HTML is only allowed inside +-- ending tags such as @mj-text@, and text only there too. +module Text.Mjml.Hamlet.Check ( + checkTemplate, +) where + +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T + +import Text.Mjml (Registry) +import Text.Mjml.Hamlet.Runtime (safeUrlPrefix, urlAttributes) +import Text.Mjml.Hamlet.Syntax +import Text.Mjml.Schema (checkAttribute, checkChild, knownTag) + + +-- | Every problem found, in template order. +checkTemplate :: Registry -> Set Text -> [Doc] -> [(Pos, Text)] +checkTemplate reg ending = concatMap (structure Nothing) + where + -- Inside MJML structure: the parent, if there is one in the template. + structure :: Maybe Text -> Doc -> [(Pos, Text)] + structure parent = \case + DTag p name as kids + | not (knownTag reg name) -> + [ ( p + , if "mj" `T.isPrefixOf` name + then "unknown MJML element <" <> name <> ">" + else "<" <> name <> "> is HTML, which can only appear inside an ending tag such as , or " + ) + ] + | otherwise -> + placement p parent name + <> concatMap (attribute name) as + <> if + | name `Set.member` ending -> concatMap html kids + | name `elem` ["mj-attributes", "mj-class"] -> [] + | otherwise -> concatMap (structure (Just name)) kids + DText p _ -> + [ ( p + , "text can only appear inside an ending tag such as " + <> maybe "" (\n -> ", not directly inside <" <> n <> ">") parent + ) + ] + DEmbed _ _ -> [] + DForall _ _ _ kids -> concatMap (structure parent) kids + DWith _ _ _ kids -> concatMap (structure parent) kids + DIf _ branches final -> + concat [concatMap (structure parent) ks | (_, _, ks) <- branches] <> maybe [] (concatMap (structure parent)) final + DMaybe _ _ _ kids nothing -> concatMap (structure parent) kids <> maybe [] (concatMap (structure parent)) nothing + DCase _ _ alts -> concat [concatMap (structure parent) ks | (_, _, ks) <- alts] + DOf p _ _ -> [(p, "$of without a matching $case")] + + placement p parent child = case parent of + Just par | Just why <- checkChild reg par child -> [(p, why)] + _ -> [] + + attribute tag = \case + Attr p attrName value -> + maybe [] (\why -> [(p, why)]) (checkAttribute reg tag attrName (value >>= literal)) + <> interpolation p attrName (maybe [] id value) + ClassAttr p ps -> + maybe [] (\why -> [(p, why)]) (checkAttribute reg tag "css-class" Nothing) + <> interpolation p "class" ps + + -- Where an interpolation may go in an attribute value. + interpolation p attrName ps + | any isEmbed ps = [(p, "^{...} cannot be used in an attribute value; use #{...}")] + | not (any isInterp ps) = [] + | attrName `elem` urlAttributes = case ps of + [PInterp _ _] -> [] + PLit lit : _ | safeUrlPrefix lit -> [] + _ -> + [ ( p + , "the URL in " + <> attrName + <> " must be a single #{...} of type SafeUrl, or start with a literal https://, http://, mailto:, /, # or ?" + ) + ] + | "on" `T.isPrefixOf` T.toLower attrName = [(p, "event handler attributes such as " <> attrName <> " cannot be interpolated")] + | otherwise = [] + + isEmbed = \case + PEmbed _ _ -> True + _ -> False + isInterp = \case + PInterp _ _ -> True + _ -> False + + literal = \case + [] -> Just "" + [PLit t] -> Just t + _ -> Nothing + + -- Inside an ending tag everything is HTML, which MJML copies as it is. + html = \case + DTag p name as kids + | "mj-" `T.isPrefixOf` name -> + [(p, "<" <> name <> "> inside an ending tag would be copied as HTML; close the ending tag first")] + | otherwise -> concatMap htmlAttribute as <> concatMap html kids + DForall _ _ _ kids -> concatMap html kids + DWith _ _ _ kids -> concatMap html kids + DIf _ branches final -> concat [concatMap html ks | (_, _, ks) <- branches] <> maybe [] (concatMap html) final + DMaybe _ _ _ kids nothing -> concatMap html kids <> maybe [] (concatMap html) nothing + DCase _ _ alts -> concat [concatMap html ks | (_, _, ks) <- alts] + DText _ _ -> [] + DEmbed _ _ -> [] + DOf p _ _ -> [(p, "$of without a matching $case")] + + where + htmlAttribute = \case + Attr p attrName value -> interpolation p attrName (maybe [] id value) + ClassAttr p ps -> interpolation p "class" ps diff --git a/src/Text/Mjml/Hamlet/Runtime.hs b/src/Text/Mjml/Hamlet/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mjml/Hamlet/Runtime.hs @@ -0,0 +1,211 @@ +-- | 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 "'" "%27" + . T.replace """ "%22" + . T.replace "<" "%3C" + . T.replace ">" "%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 "'" "'" 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) diff --git a/src/Text/Mjml/Hamlet/Syntax.hs b/src/Text/Mjml/Hamlet/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mjml/Hamlet/Syntax.hs @@ -0,0 +1,334 @@ +-- | The template syntax: Hamlet's, applied to MJML. +-- +-- A template is a sequence of lines whose indentation gives the nesting, as in +-- Hamlet. Each line is one of: +-- +-- * a tag, @\Pay now@, whose children are +-- the more indented lines below it and whose text may follow it on the +-- same line; +-- * a control line: @$forall@, @$if@ \/ @$elseif@ \/ @$else@, @$maybe@ \/ +-- @$nothing@, @$case@ \/ @$of@, @$with@, or a @$#@ comment; +-- * @^{expr}@ alone, embedding nodes or markup built elsewhere; +-- * text, in which @#{expr}@ interpolates an escaped value and @^{expr}@ +-- raw markup. A leading backslash is dropped, so @\\ #{a}@ keeps its space. +-- +-- Parsing produces a 'Doc' tree with the Haskell fragments still as source +-- text; "Text.Mjml.Hamlet.TH" turns them into code. +module Text.Mjml.Hamlet.Syntax ( + Pos (..), + Doc (..), + Attr (..), + Piece (..), + parseTemplate, +) where + +import Control.Monad (void) +import Data.Char (isAlphaNum, isSpace) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Text.Megaparsec hiding (Pos) +import Text.Megaparsec.Char + + +-- | A line and column in the template, both from 1. +data Pos = Pos {line :: Int, column :: Int} + deriving stock (Show, Eq, Ord) + + +data Doc + = DTag Pos Text [Attr] [Doc] + | DText Pos [Piece] + | DEmbed Pos String + | DForall Pos String String [Doc] + -- ^ Pattern, expression, body. + | DIf Pos [(Pos, String, [Doc])] (Maybe [Doc]) + | DMaybe Pos String String [Doc] (Maybe [Doc]) + | DCase Pos String [(Pos, String, [Doc])] + | DWith Pos String String [Doc] + | DOf Pos String [Doc] + -- ^ Only while parsing: an @$of@ before it joins its @$case@. + deriving stock (Show, Eq) + + +data Attr + = Attr Pos Text (Maybe [Piece]) + -- ^ 'Nothing' for a bare attribute. + | ClassAttr Pos [Piece] + -- ^ @.name@: a class, @css-class@ on MJML elements. + deriving stock (Show, Eq) + + +data Piece + = PLit Text + | PInterp Pos String + | PEmbed Pos String + deriving stock (Show, Eq) + + +-- | A line before nesting: its indentation and what it holds. +data Line + = LTag Text [Attr] [Piece] + | LText [Piece] + | LEmbed String + | LForall String String + | LIf String + | LElseIf String + | LElse + | LMaybe String String + | LNothing + | LCase String + | LOf String + | LWith String String + deriving stock (Show) + + +type Parser = Parsec Void Text + + +-- | Parse a template. The error is rendered with the template's own line and +-- column numbers; the caller adds where the template sits in its file. +parseTemplate :: Text -> Either (Pos, Text) [Doc] +parseTemplate src = do + ls <- traverse parseLine (numbered src) + nest ls + + +numbered :: Text -> [(Int, Int, Text)] +numbered src = + [ (n, T.length indent + 1, body) + | (n, raw) <- zip [1 ..] (T.lines src) + , let (indent, body) = T.span (== ' ') (T.dropWhileEnd isSpace raw) + , not (T.null body) + , not ("$#" `T.isPrefixOf` body) + ] + + +parseLine :: (Int, Int, Text) -> Either (Pos, Text) (Pos, Line) +parseLine (n, col, body) + | "\t" `T.isPrefixOf` body = Left (Pos n col, "tabs are not allowed for indentation; use spaces") + | otherwise = + let initial = + State + { stateInput = body + , stateOffset = 0 + , statePosState = + PosState + { pstateInput = body + , pstateOffset = 0 + , pstateSourcePos = SourcePos "" (mkPos n) (mkPos col) + , pstateTabWidth = defaultTabWidth + , pstateLinePrefix = "" + } + , stateParseErrors = [] + } + in case snd (runParser' (lineP <* eof) initial) of + Right l -> Right (Pos n col, l) + Left bundle -> case bundleErrors bundle of + e :| _ -> + Left (Pos n (col + errorOffset e), T.strip (T.pack (parseErrorTextPretty e))) + + +lineP :: Parser Line +lineP = + choice + [ controlP + , tagP + , try (LEmbed <$> (string "^{" *> balanced) <* eof) + , LText <$> piecesP (const False) + ] + + +controlP :: Parser Line +controlP = do + void (char '$') + keyword <- takeWhile1P (Just "a control keyword") isAlphaNum + let rest = T.unpack . T.strip <$> takeRest + binding = do + space1 + src <- takeRest + case T.breakOn "<-" src of + (pat, expr) + | not (T.null expr) -> + pure (T.unpack (T.strip pat), T.unpack (T.strip (T.drop 2 expr))) + _ -> fail ("$" <> T.unpack keyword <> " needs a binding: $" <> T.unpack keyword <> " pattern <- expression") + needs what = space1 *> (rest >>= \r -> if null r then fail ("$" <> T.unpack keyword <> " needs " <> what) else pure r) + case keyword of + "forall" -> uncurry LForall <$> binding + "maybe" -> uncurry LMaybe <$> binding + "with" -> uncurry LWith <$> binding + "if" -> LIf <$> needs "a condition" + "elseif" -> LElseIf <$> needs "a condition" + "else" -> LElse <$ eof + "nothing" -> LNothing <$ eof + "case" -> LCase <$> needs "an expression" + "of" -> LOf <$> needs "a pattern" + other -> fail ("unknown control keyword $" <> T.unpack other) + + +tagP :: Parser Line +tagP = do + void (char '<') + name <- takeWhile1P (Just "a tag name") (\c -> isAlphaNum c || c == '-' || c == ':' || c == '_') + as <- many (try (space1 *> attrP)) + space + void (char '>') "'>' closing the tag" + inline <- optional (piecesP (const False)) + pure (LTag (T.toLower name) as (maybe [] id inline)) + + +attrP :: Parser Attr +attrP = do + pos <- getPos + choice + [ ClassAttr pos <$> (char '.' *> valueP) + , do + name <- takeWhile1P (Just "an attribute name") (\c -> isAlphaNum c || c `elem` ("-_:" :: String)) + value <- optional (char '=' *> valueP) + pure (Attr pos name value) + ] + + +valueP :: Parser [Piece] +valueP = + choice + [ between (char '"') (char '"') (piecesP (== '"')) + , between (char '\'') (char '\'') (piecesP (== '\'')) + , piecesP (\c -> isSpace c || c == '>') + ] + + +-- | Literal text and interpolations, up to a character the caller stops at. +piecesP :: (Char -> Bool) -> Parser [Piece] +piecesP stop = do + merge <$> many piece + where + piece = + choice + [ try (PInterp <$> getPos <*> (string "#{" *> balanced)) + , try (PEmbed <$> getPos <*> (string "^{" *> balanced)) + , PLit . T.singleton <$> satisfy (not . stop) + ] + merge = \case + PLit a : PLit b : rest -> merge (PLit (a <> b) : rest) + x : rest -> x : merge rest + [] -> [] + + +-- | The Haskell source inside @{...}@, up to the matching brace. +balanced :: Parser String +balanced = go (0 :: Int) + where + go depth = do + c <- anySingle "a closing '}'" + case c of + '}' | depth == 0 -> pure [] + '}' -> (c :) <$> go (depth - 1) + '{' -> (c :) <$> go (depth + 1) + '"' -> do + s <- stringLit + (\r -> '"' : s <> r) <$> go depth + _ -> (c :) <$> go depth + stringLit = do + c <- anySingle + case c of + '"' -> pure "\"" + '\\' -> do + e <- anySingle + (\r -> '\\' : e : r) <$> stringLit + _ -> (c :) <$> stringLit + + +getPos :: Parser Pos +getPos = do + p <- getSourcePos + pure (Pos (unPos (sourceLine p)) (unPos (sourceColumn p))) + + +-- | Turn indented lines into a tree, pairing each control line with its +-- continuations (@$else@, @$nothing@, @$of@). +nest :: [(Pos, Line)] -> Either (Pos, Text) [Doc] +nest = fmap fst . block 0 + where + -- Parse sibling lines whose column is exactly the first one's, returning + -- the docs and the remaining lines. + block :: Int -> [(Pos, Line)] -> Either (Pos, Text) ([Doc], [(Pos, Line)]) + block _ [] = Right ([], []) + block minCol ls@((p, _) : _) + | column p <= minCol = Right ([], ls) + | otherwise = siblings (column p) ls + + siblings col = \case + (p, l) : rest + | column p == col -> do + (kids, rest') <- block col rest + (doc, rest'') <- assemble col p l kids rest' + (more, rest''') <- siblings col rest'' + pure (doc : more, rest''') + | column p > col -> Left (p, "unexpected indentation") + rest -> Right ([], rest) + + -- Continuations at the same column belong to the control line above. + continuation col = \case + (p, l) : rest | column p == col -> Just (p, l, rest) + _ -> Nothing + + assemble col p l kids rest = case l of + LTag name as inline -> + let inlineDoc = [DText p inline | not (null inline)] + in Right (DTag p name as (inlineDoc <> kids), rest) + LText ps -> do + noChildren p kids + Right (DText p (dropBackslash ps), rest) + LEmbed e -> noChildren p kids >> Right (DEmbed p e, rest) + LForall pat e -> Right (DForall p pat e kids, rest) + LWith pat e -> Right (DWith p pat e kids, rest) + LIf c -> do + (branches, final, rest') <- ifChain col rest + Right (DIf p ((p, c, kids) : branches) final, rest') + LMaybe pat e -> case continuation col rest of + Just (_, LNothing, rest') -> do + (kids', rest'') <- block col rest' + Right (DMaybe p pat e kids (Just kids'), rest'') + _ -> Right (DMaybe p pat e kids Nothing, rest) + LCase e -> do + alts <- traverse asAlternative kids + if null alts then Left (p, "$case needs at least one nested $of") else Right (DCase p e alts, rest) + LElseIf _ -> Left (p, "$elseif without a matching $if") + LElse -> Left (p, "$else without a matching $if") + LNothing -> Left (p, "$nothing without a matching $maybe") + LOf pat -> Right (DOf p pat kids, rest) + + ifChain col rest = case continuation col rest of + Just (p', LElseIf c, rest') -> do + (kids, rest'') <- block col rest' + (more, final, rest''') <- ifChain col rest'' + Right ((p', c, kids) : more, final, rest''') + Just (_, LElse, rest') -> do + (kids, rest'') <- block col rest' + Right ([], Just kids, rest'') + _ -> Right ([], Nothing, rest) + + asAlternative = \case + DOf p pat kids -> Right (p, pat, kids) + d -> Left (docPos d, "only $of lines can be nested under $case") + + noChildren p kids = if null kids then Right () else Left (p, "only tags and control lines can have nested lines") + + dropBackslash = \case + PLit t : more | Just ('\\', t') <- T.uncons t -> [PLit t' | not (T.null t')] <> more + ps -> ps + + +docPos :: Doc -> Pos +docPos = \case + DTag p _ _ _ -> p + DText p _ -> p + DEmbed p _ -> p + DForall p _ _ _ -> p + DIf p _ _ -> p + DMaybe p _ _ _ _ -> p + DCase p _ _ -> p + DWith p _ _ _ -> p + DOf p _ _ -> p diff --git a/src/Text/Mjml/Hamlet/TH.hs b/src/Text/Mjml/Hamlet/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/Mjml/Hamlet/TH.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code generation: a checked 'Doc' tree becomes an expression of type +-- @['Node']@. +-- +-- Interpolated values are escaped as they go into the tree, because MJML +-- copies attribute values and ending-tag content into its output verbatim. +module Text.Mjml.Hamlet.TH ( + compileTemplate, + Source (..), +) where + +import Data.Char (isAlphaNum, isLower, isUpper) +import Data.Maybe (catMaybes) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Language.Haskell.TH +import Text.Megaparsec qualified as M +import Text.Megaparsec.Char qualified as M +import Text.Parsec qualified as P +import Text.Shakespeare.Base (derefToExp, parseDeref) + +import Text.Mjml (Registry) +import Text.Mjml.Hamlet.Check (checkTemplate) +import Text.Mjml.Hamlet.Runtime (ToNodes (..), ToRawHtml (..), ToUrl (..), element, escape, guardMjml, guardStyle, urlAttributes, urlPart) +import Text.Mjml.Hamlet.Syntax + + +-- | Where the template text came from, for error messages. +data Source = Source + { file :: FilePath + , startLine :: Int + , firstLineColumn :: Int + -- ^ The column, in the file, of the template's first character. + } + + +compileTemplate :: Registry -> Set Text -> Source -> Text -> Q Exp +compileTemplate reg ending src body = case parseTemplate body of + Left (p, why) -> failAt src p why + Right docs -> case checkTemplate reg ending docs of + (p, why) : _ -> failAt src p why + [] -> structure src ending docs + + +failAt :: Source -> Pos -> Text -> Q a +failAt src (Pos l c) why = + let absLine = startLine src + l - 1 + absCol = if l == 1 then firstLineColumn src + c - 1 else c + in fail (file src <> ":" <> show absLine <> ":" <> show absCol <> ": " <> T.unpack why) + + +-- | MJML elements, as @['Node']@. +structure :: Source -> Set Text -> [Doc] -> Q Exp +structure src ending docs = [|concat $(listE (map one docs))|] + where + one = \case + DTag _ name as kids + | name `Set.member` ending -> + [|[element $(textE name) $(attrsE src name True as) [] $(html src kids)]|] + | name `elem` ["mj-attributes", "mj-class"] -> + [|[element $(textE name) $(attrsE src name True as) $(structureRaw kids) ""]|] + | otherwise -> + [|[element $(textE name) $(attrsE src name True as) $(structure src ending kids) ""]|] + DText p _ -> failAt src p "text can only appear inside an ending tag" + DEmbed p e -> [|toNodes $(expr src p e)|] + d -> control src (structure src ending) d [|[]|] + + -- @mj-attributes@ children name the elements they set defaults for, so + -- they are any tag at all. + structureRaw kids = + listE + [ [|element $(textE name) $(attrsE src name True as) [] ""|] + | DTag _ name as _ <- kids + ] + + +-- | HTML inside an ending tag, as 'Text'. Consecutive text lines are joined +-- with a space. +html :: Source -> [Doc] -> Q Exp +html src docs = [|T.concat $(listE (go docs))|] + where + go = \case + DText _ a : rest@(DText _ _ : _) -> pieces src a : textE " " : go rest + d : rest -> one d : go rest + [] -> [] + one = \case + DTag _ name as kids + | name `elem` voidElements -> [|"<" <> $(textE name) <> $(htmlAttrs name as) <> ">"|] + | otherwise -> + [|"<" <> $(textE name) <> $(htmlAttrs name as) <> ">" <> $(html src kids) <> " $(textE name) <> ">"|] + DText _ ps -> pieces src ps + DEmbed p e -> [|toRawHtml $(expr src p e)|] + d -> control src (html src) d [|""|] + htmlAttrs name as = + [| + T.concat + ( map + (\(k, v) -> " " <> k <> (if T.null v then "" else "=\"" <> v <> "\"")) + $(attrsE src name False as) + ) + |] + + +voidElements :: [Text] +voidElements = ["area", "base", "br", "col", "embed", "hr", "img", "input", "link", "meta", "source", "track", "wbr"] + + +-- | Control lines, for either kind of content. @body@ compiles nested lines and +-- @empty@ is the content of a branch that renders nothing. +control :: Source -> ([Doc] -> Q Exp) -> Doc -> Q Exp -> Q Exp +control src body d empty = case d of + DForall p pat e kids -> do + pt <- patt src p pat + [|foldMap $(lamE [pure pt] (body kids)) $(expr src p e)|] + DWith p pat e kids -> do + pt <- patt src p pat + caseE (expr src p e) [match (pure pt) (normalB (body kids)) []] + DIf _ branches final -> + foldr + (\(p, c, kids) rest -> condE (expr src p c) (body kids) rest) + (maybe empty body final) + branches + DMaybe p pat e kids nothing -> do + pt <- patt src p pat + caseE + (expr src p e) + [ match (conP 'Just [pure pt]) (normalB (body kids)) [] + , match (conP 'Nothing []) (normalB (maybe empty body nothing)) [] + ] + DCase p e alts -> + caseE + (expr src p e) + [ do + pt <- patt src p' pat + match (pure pt) (normalB (body kids)) [] + | (p', pat, kids) <- alts + ] + DTag p _ _ _ -> failAt src p "unexpected tag" + DText p _ -> failAt src p "unexpected text" + DEmbed p _ -> failAt src p "unexpected embed" + DOf p _ _ -> failAt src p "$of without a matching $case" + + +-- | Attributes as @[(Text, Text)]@. Classes written with @.name@ are joined +-- into @css-class@ on MJML elements and @class@ on HTML ones. +-- +-- A literal value is used as written: the checker has already seen it. An +-- interpolated one goes through the policy in "Text.Mjml.Hamlet.Runtime". +attrsE :: Source -> Text -> Bool -> [Attr] -> Q Exp +attrsE src tag isMjml as = + let classKey = if isMjml then "css-class" else "class" + plain = [(name, maybe [] id value) | Attr _ name value <- as, name /= classKey] + explicitClass = [maybe [] id value | Attr _ name value <- as, name == classKey] + shorthand = [ps | ClassAttr _ ps <- as] + classes = explicitClass <> shorthand + classAttr = + [ [|Just ($(textE classKey), T.unwords (filter (not . T.null) $(listE (map (pieces src) classes))))|] + | not (null classes) + ] + one (name, ps) + | not (any interpolated ps) = [|Just ($(textE name), $(pieces src ps))|] + | name `elem` urlAttributes = case ps of + [PInterp p e] -> [|Just ($(textE name), toUrl $(expr src p e))|] + _ -> [|Just ($(textE name), $(urlPieces ps))|] + | isMjml = [|guardMjml $(textE tag) $(textE name) $(pieces src ps)|] + | name == "style" = [|guardStyle $(pieces src ps)|] + | otherwise = [|Just ($(textE name), $(pieces src ps))|] + urlPieces ps = + [| + T.concat + $( listE + [ case piece of + PInterp p e -> [|urlPart $(expr src p e)|] + _ -> pieces src [piece] + | piece <- ps + ] + ) + |] + interpolated = \case + PLit _ -> False + _ -> True + in [|catMaybes $(listE (map one plain <> classAttr))|] + + +-- | Text with interpolations, as 'Text'. +pieces :: Source -> [Piece] -> Q Exp +pieces src ps = case ps of + [] -> textE "" + [PLit t] -> textE t + _ -> [|T.concat $(listE (map one ps))|] + where + one = \case + PLit t -> textE t + PInterp p e -> [|escape $(expr src p e)|] + PEmbed p e -> [|toRawHtml $(expr src p e)|] + + +textE :: Text -> Q Exp +textE t = [|T.pack $(litE (stringL (T.unpack t)))|] + + +-- | A Haskell expression, parsed the way Hamlet parses @#{...}@. +expr :: Source -> Pos -> String -> Q Exp +expr src p s = case P.parse (parseDeref <* P.eof) "" (trim s) of + Right d -> pure (derefToExp [] d) + Left e -> failAt src p ("cannot parse the expression " <> T.pack (show (trim s)) <> ": " <> T.pack (show e)) + where + trim = T.unpack . T.strip . T.pack + + +-- | A pattern in @$forall@, @$maybe@, @$with@ or @$of@: variables, +-- wildcards, constructors, tuples and literals. +patt :: Source -> Pos -> String -> Q Pat +patt src p s = case M.parse (M.space *> pat <* M.eof) "" (T.pack s) of + Right x -> x + Left e -> failAt src p ("cannot parse the pattern " <> T.pack (show s) <> ": " <> T.pack (M.errorBundlePretty e)) + where + lexeme :: M.Parsec Void Text a -> M.Parsec Void Text a + lexeme x = x <* M.space + sym = lexeme . M.string + ident = lexeme (M.takeWhile1P Nothing (\c -> isAlphaNum c || c `elem` ("_'." :: String))) + + pat = M.choice [M.try applied, apat] + + applied = do + x <- ident + case T.uncons x of + Just (c, _) | isUpper c -> do + args <- M.some apat + pure (conP (mkName (T.unpack x)) args) + _ -> fail "not a constructor" + + apat = + M.choice + [ do + ps <- sym "(" *> M.sepBy pat (sym ",") <* sym ")" + pure $ case ps of + [one] -> one + _ -> tupP ps + , do + lit <- lexeme (M.char '"' *> M.manyTill M.anySingle (M.char '"')) + pure (litP (stringL lit)) + , do + x <- ident + pure $ case T.uncons x of + Just (c, _) | isUpper c -> conP (mkName (T.unpack x)) [] + _ -> simple x + ] + + simple x + | x == "_" = wildP + | T.all (`elem` ['0' .. '9']) x = litP (integerL (read (T.unpack x))) + | Just (c, _) <- T.uncons x, isLower c || c == '_' = varP (mkName (T.unpack x)) + | otherwise = varP (mkName (T.unpack x)) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,199 @@ +-- | Each template must render exactly as the same document written in MJML's +-- XML syntax; each rejected template must be rejected for the right reason. +module Main (main) where + +import Control.Monad (unless) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.Exit (exitFailure) +import Text.Blaze (preEscapedToMarkup) + +import Text.Mjml (Node, defaultOptions, defaultRegistry, endingTagNames, renderText) +import Text.Mjml.Hamlet (fromSafeUrl, mjml, renderMjml, safeUrl) +import Text.Mjml.Hamlet.Check (checkTemplate) +import Text.Mjml.Hamlet.Syntax (parseTemplate) + +import Readme qualified + + +data Line = Line {name :: Text, quantity :: Int} + + +data Delivery = Pickup Text | Home + + +main :: IO () +main = do + failures <- newIORef (0 :: Int) + let check label ok detail = unless ok $ do + T.putStrLn ("FAIL " <> label <> "\n" <> detail) + modifyIORef' failures (+ 1) + same label nodes xml = + let a = renderMjml nodes + b = renderText defaultOptions xml + in check label (a == b) (firstDifference (either (T.pack . show) id a) (either (T.pack . show) id b)) + rejects label template expected = + let found = case parseTemplate template of + Left (_, why) -> [why] + Right docs -> map snd (checkTemplate defaultRegistry (endingTagNames defaultRegistry) docs) + in check label (any (expected `T.isInfixOf`) found) ("expected an error mentioning " <> T.pack (show expected) <> ", got " <> T.pack (show found)) + + let lines' = [Line "Socks" 2, Line "Hat & co" 1] + reference = "TZ-1" :: Text + tracking = safeUrl "https://t.example" + + same + "structure, attributes and text" + [mjml| + + + Order #{reference} + + Track + |] + "Order TZ-1Track" + + same + "$forall with record fields, and escaping" + [mjml| + + + $forall line <- lines' + #{line.name} × #{line.quantity} + |] + "Socks × 2Hat <wool> & co × 1" + + same + "$if, $maybe, $case and HTML inside an ending tag" + [mjml| + + + $if null lines' + Empty + $else + +

Thank you! +

+ Two lines + joined by a space + $maybe url <- tracking + Track + $nothing + No tracking + $case Pickup "Locker 4" + $of Pickup place + Collect it from #{place} + $of Home + Delivered home + |] + "

Thank you!

Two lines joined by a space

TrackCollect it from Locker 4" + + let signature = preEscapedToMarkup ("Kronor" :: Text) + footer :: [Node] + footer = + [mjml| + + + ^{signature} + |] + same + "a whole document, with a head and embedded nodes" + [mjml| + + + Order #{reference} + + + + + + + Hej + ^{footer} + |] + "Order TZ-1HejKronor" + + let quoteBreak = "x\" onmouseover=\"alert(1)" :: Text + cssBreak = "red;background:url(https://t.example/p)" :: Text + fontBreak = "Arial;color:red" :: Text + fontOk = "'Open Sans', Arial" :: Text + styleBreak = "color:red}body{display:none" :: Text + safe = safeUrl "https://example.com/a?b=1&c=2" + + same + "an interpolation after a literal scheme is percent-encoded" + [mjml| + + + Go + |] + "Go" + + same + "typed and CSS attributes that could add declarations are dropped" + [mjml| + + + A + B + |] + "AB" + + same + "a SafeUrl is used whole; HTML style attributes are checked" + [mjml| + + + $maybe url <- safe + Go + + Hi + |] + "GoHi" + + check "safeUrl accepts https" (fmap fromSafeUrl (safeUrl " https://a.example/x ") == Just "https://a.example/x") "" + check "safeUrl rejects javascript:" (null (safeUrl "javascript:alert(1)")) "" + check "safeUrl rejects quotes" (null (safeUrl "https://a.example/'x")) "" + check "safeUrl rejects whitespace" (null (safeUrl "https://a.example/ x")) "" + + rejects "URL starting with an interpolation" "" "must be a single #{...} of type SafeUrl" + rejects "URL whose scheme an interpolation completes" "" "must be a single #{...} of type SafeUrl" + rejects "interpolated event handler" "\n " "event handler attributes such as onclick" + rejects "embed in an attribute" "" "cannot be used in an attribute value" + rejects "unknown element" "" "unknown MJML element " + rejects "HTML in structure" "\n
" "
is HTML" + rejects "misplaced element" "\n Hi" "mj-text cannot be used inside mj-section" + rejects "undeclared attribute" "Hi" "Attribute colour is illegal on " + rejects "bad enum value" "Hi" "Attribute align has invalid value: middle" + rejects "bad unit value" "" "Attribute width has invalid value: half" + rejects "text outside an ending tag" "\n Hello" "text can only appear inside an ending tag" + rejects "element inside an ending tag" "\n " " inside an ending tag" + rejects "dangling $else" "$else" "$else without a matching $if" + rejects "dangling $of" "$of Home" "$of without a matching $case" + rejects "tabs" "\t" "tabs are not allowed" + + let readmeOrder = + Readme.Order + { Readme.reference = "TZ-1042" + , Readme.customer = "Ada" + , Readme.items = [Readme.Item "Wool socks" 2 "€18.00", Readme.Item "Beanie" 1 "€25.00"] + , Readme.total = "€43.00" + , Readme.trackingUrl = safeUrl "https://track.example/TZ-1042" + } + rendered = Readme.confirmation readmeOrder + contains t = either (const False) (t `T.isInfixOf`) rendered + check "README order confirmation renders" (all contains ["Thanks, Ada!", "2 × Wool socks", "Total €43.00", "https://track.example/TZ-1042", "mj-column-per-70"]) (T.pack (show (fmap (T.take 200) rendered))) + check "README welcome renders" (either (const False) ("Welcome aboard" `T.isInfixOf`) Readme.renderWelcome) "" + + n <- readIORef failures + if n == 0 then putStrLn "all mjml-hamlet tests passed" else exitFailure + + +-- | The two texts around where they first differ. +firstDifference :: Text -> Text -> Text +firstDifference a b = + let i = maybe 0 (\(common, _, _) -> T.length common) (T.commonPrefixes a b) + around t = T.take 160 (T.drop (max 0 (i - 60)) t) + in " template: " <> around a <> "\n xml: " <> around b diff --git a/test/Readme.hs b/test/Readme.hs new file mode 100644 --- /dev/null +++ b/test/Readme.hs @@ -0,0 +1,97 @@ +-- | The examples in the README, compiled and run by the test suite so they +-- stay correct. Keep the two in sync. +module Readme ( + Order (..), + Item (..), + confirmation, + welcome, + renderWelcome, +) where + +import Data.Text (Text) + +import Text.Mjml (MjmlError, Node, defaultOptions, renderText) +import Text.Mjml.Hamlet (SafeUrl, mjml, renderMjml) + + +-- README: "Writing templates in Haskell" + +data Order = Order + { reference :: Text + , customer :: Text + , items :: [Item] + , total :: Text + , trackingUrl :: Maybe SafeUrl + } + + +data Item = Item + { name :: Text + , quantity :: Int + , price :: Text + } + + +confirmation :: Order -> Either MjmlError Text +confirmation order = + renderMjml + [mjml| + + + Order #{order.reference} + Thanks for your order, #{order.customer} + + + + + + + + Thanks, #{order.customer}! + We have received order #{order.reference} and will tell you when it ships. + $forall item <- order.items + + + + #{item.quantity} × #{item.name} + + #{item.price} + + + + Total #{order.total} + $maybe url <- order.trackingUrl + Track your parcel + ^{footer} + |] + + +footer :: [Node] +footer = + [mjml| + + + + You are receiving this email because you placed an order with us. + |] + + +-- README: "Rendering MJML documents" + +welcome :: Text +welcome = + "\ + \ \ + \ \ + \ \ + \ \ + \ Welcome aboard\ + \ Get started\ + \ \ + \ \ + \ \ + \" + + +renderWelcome :: Either MjmlError Text +renderWelcome = renderText defaultOptions welcome