mjml-hamlet (empty) → 0.1.0.0
raw patch · 11 files changed
+1491/−0 lines, 11 filesdep +basedep +blaze-markupdep +containers
Dependencies added: base, blaze-markup, containers, megaparsec, mjml, mjml-hamlet, parsec, shakespeare, template-haskell, text
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.md +97/−0
- mjml-hamlet.cabal +68/−0
- src/Text/Mjml/Hamlet.hs +81/−0
- src/Text/Mjml/Hamlet/Check.hs +119/−0
- src/Text/Mjml/Hamlet/Runtime.hs +211/−0
- src/Text/Mjml/Hamlet/Syntax.hs +334/−0
- src/Text/Mjml/Hamlet/TH.hs +259/−0
- test/Main.hs +199/−0
- test/Readme.hs +97/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for mjml-hamlet++## 0.1.0.0 -- 2026-10-31++* First version.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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|+ <mj-section>+ <mj-column>+ <mj-text font-size="20px">Your order #{order.reference} is on its way+ $forall line <- order.lines+ <mj-text>#{line.name} × #{line.quantity}+ $maybe url <- order.trackingUrl+ <mj-button href=#{url} .primary>Track it+ |]+```++## Syntax++As in Hamlet, nesting is given by indentation and there are no closing tags.++* `<mj-text align="center">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+`<mjml>` as it is, wraps a template made of `<mj-head>` and `<mj-body>` in+`<mjml>`, and wraps anything else in `<mjml><mj-body>`, 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.
+ mjml-hamlet.cabal view
@@ -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
+ src/Text/Mjml/Hamlet.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TemplateHaskell #-}++-- | MJML templates in Hamlet's syntax, checked at compile time.+--+-- > shipped :: Order -> [Node]+-- > shipped order =+-- > [mjml|+-- > <mj-section>+-- > <mj-column>+-- > <mj-text font-size="20px">Your order #{order.reference} is on its way+-- > $forall line <- order.lines+-- > <mj-text>#{line.name} × #{line.quantity}+-- > $maybe url <- order.trackingUrl+-- > <mj-button href=#{url}>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 ""] ""
+ src/Text/Mjml/Hamlet/Check.hs view
@@ -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 <mj-text>, <mj-button> or <mj-raw>"+ )+ ]+ | 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 <mj-text>"+ <> 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
+ src/Text/Mjml/Hamlet/Runtime.hs view
@@ -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)
+ src/Text/Mjml/Hamlet/Syntax.hs view
@@ -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, @\<mj-button href=#{url} .primary>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
+ src/Text/Mjml/Hamlet/TH.hs view
@@ -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))+
+ test/Main.hs view
@@ -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 <wool> & co" 1]+ reference = "TZ-1" :: Text+ tracking = safeUrl "https://t.example"++ same+ "structure, attributes and text"+ [mjml|+ <mj-section background-color="#f0f0f0">+ <mj-column width="70%">+ <mj-text font-size="20px">Order #{reference}+ <mj-column>+ <mj-button href="https://example.com/o?id=#{reference}" .primary>Track+ |]+ "<mjml><mj-body><mj-section background-color=\"#f0f0f0\"><mj-column width=\"70%\"><mj-text font-size=\"20px\">Order TZ-1</mj-text></mj-column><mj-column><mj-button href=\"https://example.com/o?id=TZ-1\" css-class=\"primary\">Track</mj-button></mj-column></mj-section></mj-body></mjml>"++ same+ "$forall with record fields, and escaping"+ [mjml|+ <mj-section>+ <mj-column>+ $forall line <- lines'+ <mj-text>#{line.name} × #{line.quantity}+ |]+ "<mjml><mj-body><mj-section><mj-column><mj-text>Socks × 2</mj-text><mj-text>Hat <wool> & co × 1</mj-text></mj-column></mj-section></mj-body></mjml>"++ same+ "$if, $maybe, $case and HTML inside an ending tag"+ [mjml|+ <mj-section>+ <mj-column>+ $if null lines'+ <mj-text>Empty+ $else+ <mj-text>+ <p>Thank you!+ <p>+ Two lines+ joined by a space+ $maybe url <- tracking+ <mj-button href=#{url}>Track+ $nothing+ <mj-text>No tracking+ $case Pickup "Locker 4"+ $of Pickup place+ <mj-text>Collect it from #{place}+ $of Home+ <mj-text>Delivered home+ |]+ "<mjml><mj-body><mj-section><mj-column><mj-text><p>Thank you!</p><p>Two lines joined by a space</p></mj-text><mj-button href=\"https://t.example\">Track</mj-button><mj-text>Collect it from Locker 4</mj-text></mj-column></mj-section></mj-body></mjml>"++ let signature = preEscapedToMarkup ("<i>Kronor</i>" :: Text)+ footer :: [Node]+ footer =+ [mjml|+ <mj-section>+ <mj-column>+ <mj-text>^{signature}+ |]+ same+ "a whole document, with a head and embedded nodes"+ [mjml|+ <mjml lang="sv">+ <mj-head>+ <mj-title>Order #{reference}+ <mj-attributes>+ <mj-all font-family="Arial">+ <mj-class name="muted" color="#888888">+ <mj-body>+ <mj-section>+ <mj-column>+ <mj-text mj-class="muted">Hej+ ^{footer}+ |]+ "<mjml lang=\"sv\"><mj-head><mj-title>Order TZ-1</mj-title><mj-attributes><mj-all font-family=\"Arial\" /><mj-class name=\"muted\" color=\"#888888\" /></mj-attributes></mj-head><mj-body><mj-section><mj-column><mj-text mj-class=\"muted\">Hej</mj-text></mj-column></mj-section><mj-section><mj-column><mj-text><i>Kronor</i></mj-text></mj-column></mj-section></mj-body></mjml>"++ 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|+ <mj-section>+ <mj-column>+ <mj-button href="https://example.com/o?id=#{quoteBreak}">Go+ |]+ "<mjml><mj-body><mj-section><mj-column><mj-button href=\"https://example.com/o?id=x%22%20onmouseover=%22alert(1)\">Go</mj-button></mj-column></mj-section></mj-body></mjml>"++ same+ "typed and CSS attributes that could add declarations are dropped"+ [mjml|+ <mj-section background-color=#{cssBreak}>+ <mj-column>+ <mj-text font-family=#{fontBreak} color=#{cssBreak}>A+ <mj-text font-family=#{fontOk}>B+ |]+ "<mjml><mj-body><mj-section><mj-column><mj-text>A</mj-text><mj-text font-family=\"'Open Sans', Arial\">B</mj-text></mj-column></mj-section></mj-body></mjml>"++ same+ "a SafeUrl is used whole; HTML style attributes are checked"+ [mjml|+ <mj-section>+ <mj-column>+ $maybe url <- safe+ <mj-button href=#{url}>Go+ <mj-text>+ <span style=#{styleBreak}>Hi+ |]+ "<mjml><mj-body><mj-section><mj-column><mj-button href=\"https://example.com/a?b=1&c=2\">Go</mj-button><mj-text><span>Hi</span></mj-text></mj-column></mj-section></mj-body></mjml>"++ 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" "<mj-button href=\"#{u}/x\">" "must be a single #{...} of type SafeUrl"+ rejects "URL whose scheme an interpolation completes" "<mj-image src=\"java#{u}\">" "must be a single #{...} of type SafeUrl"+ rejects "interpolated event handler" "<mj-text>\n <a onclick=#{x}>" "event handler attributes such as onclick"+ rejects "embed in an attribute" "<mj-text css-class=^{x}>" "cannot be used in an attribute value"+ rejects "unknown element" "<mj-sectoin>" "unknown MJML element <mj-sectoin>"+ rejects "HTML in structure" "<mj-section>\n <div>" "<div> is HTML"+ rejects "misplaced element" "<mj-section>\n <mj-text>Hi" "mj-text cannot be used inside mj-section"+ rejects "undeclared attribute" "<mj-text colour=\"red\">Hi" "Attribute colour is illegal on <mj-text>"+ rejects "bad enum value" "<mj-text align=\"middle\">Hi" "Attribute align has invalid value: middle"+ rejects "bad unit value" "<mj-column width=\"half\">" "Attribute width has invalid value: half"+ rejects "text outside an ending tag" "<mj-column>\n Hello" "text can only appear inside an ending tag"+ rejects "element inside an ending tag" "<mj-text>\n <mj-button>" "<mj-button> 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<mj-section>" "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
+ test/Readme.hs view
@@ -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|+ <mjml>+ <mj-head>+ <mj-title>Order #{order.reference}+ <mj-preview>Thanks for your order, #{order.customer}+ <mj-attributes>+ <mj-all font-family="Helvetica, Arial, sans-serif">+ <mj-text font-size="15px" line-height="22px" color="#333333">+ <mj-body background-color="#f4f4f4">+ <mj-section padding="12px">+ <mj-section background-color="#ffffff" padding="24px">+ <mj-column>+ <mj-text font-size="22px" font-weight="bold">Thanks, #{order.customer}!+ <mj-text>We have received order #{order.reference} and will tell you when it ships.+ $forall item <- order.items+ <mj-section background-color="#ffffff" padding="0 24px">+ <mj-group>+ <mj-column width="70%">+ <mj-text>#{item.quantity} × #{item.name}+ <mj-column width="30%">+ <mj-text align="right">#{item.price}+ <mj-section background-color="#ffffff" padding="0 24px 24px">+ <mj-column>+ <mj-divider border-color="#dddddd" border-width="1px">+ <mj-text align="right" font-weight="bold">Total #{order.total}+ $maybe url <- order.trackingUrl+ <mj-button href=#{url} background-color="#1a73e8">Track your parcel+ ^{footer}+ |]+++footer :: [Node]+footer =+ [mjml|+ <mj-section>+ <mj-column>+ <mj-text font-size="12px" color="#888888" align="center">+ You are receiving this email because you placed an order with us.+ |]+++-- README: "Rendering MJML documents"++welcome :: Text+welcome =+ "<mjml>\+ \ <mj-body>\+ \ <mj-section>\+ \ <mj-column>\+ \ <mj-image src=\"https://example.com/logo.png\" width=\"120px\" />\+ \ <mj-text font-size=\"20px\">Welcome aboard</mj-text>\+ \ <mj-button href=\"https://example.com/start\">Get started</mj-button>\+ \ </mj-column>\+ \ </mj-section>\+ \ </mj-body>\+ \</mjml>"+++renderWelcome :: Either MjmlError Text+renderWelcome = renderText defaultOptions welcome