ihp-hsx-1.5.0: Test/IHP/HSX/QQSpec.hs
{-|
Module: IHP.HSX.QQSpec
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.HSX.QQSpec where
import Test.Hspec
import Prelude
import Control.Monad.State.Strict (State, get, put, evalState)
import qualified IHP.HSX.QQ as Blaze
import qualified IHP.HSX.Lucid2.QQ as Lucid2
import qualified IHP.HSX.Lucid2.Attribute as Lucid2
import qualified Text.Blaze.Renderer.Text as Blaze
import qualified Text.Blaze as Blaze
import Text.Blaze (preEscapedTextValue)
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import IHP.HSX.CustomHsxCases
import qualified "lucid2" Lucid.Base as Lucid2 (Html, HtmlT, renderText, renderTextT)
tests :: SpecWith ()
tests = do
describe "HSX" do
it "should work with static html" do
[hsx|<strong>hello world</strong>|] `shouldBeSameHtml` "<strong>hello world</strong>"
[hsx|<h1>hello world</h1>|] `shouldBeSameHtml` "<h1>hello world</h1>"
[hsx|<blink>web scale</blink>|] `shouldBeSameHtml` "<blink>web scale</blink>"
it "should work with an empty input" do
[hsx||] `shouldBeSameHtml` ""
it "should support multiple root nodes" do
[hsx|<u>underlined</u><i>italic</i>|] `shouldBeSameHtml` "<u>underlined</u><i>italic</i>"
it "should work with text variables" do
let myString :: Text = "World!"
[hsx|Hello {myString}|] `shouldBeSameHtml` "Hello World!"
it "should work with complex haskell expressions" do
let project = Project { name = "Testproject" }
[hsx|<h1>Project: {project.name}</h1>|] `shouldBeSameHtml` "<h1>Project: Testproject</h1>"
it "should support lambdas and pattern matching on constructors" do
let placeData = PlaceId "Punches Cross"
[hsx|<h1>{(\(PlaceId x) -> x)(placeData)}</h1>|] `shouldBeSameHtml` "<h1>Punches Cross</h1>"
it "should support infix notation for standard constructors e.g. (:):" do
[hsx| <h1>{show $ (:) 1 [2,3,42]}</h1> |] `shouldBeSameHtml` "<h1>[1,2,3,42]</h1>"
it "should support infix notation for standard constructors e.g. (,):" do
[hsx|<h1>{show $ ((,) 1 2)}</h1>|] `shouldBeSameHtml` "<h1>(1,2)</h1>"
it "should support self closing tags" do
[hsx|<input>|] `shouldBeSameHtml` "<input>"
[hsx|<br><br/>|] `shouldBeSameHtml` "<br><br>"
it "should support boolean attributes" do
[hsx|<input disabled>|] `shouldBeSameHtml` "<input disabled=\"disabled\">"
[hsx|<input disabled={True}>|] `shouldBeSameHtml` "<input disabled=\"disabled\">"
[hsx|<input disabled={False}>|] `shouldBeSameHtml` "<input>"
it "should correctly output True and False values in data attributes" do
[hsx|<form data-disabled-javascript-submission></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"true\"></form>"
[hsx|<form data-disabled-javascript-submission={True}></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"true\"></form>"
[hsx|<form data-disabled-javascript-submission={False}></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"false\"></form>"
it "should work with inline JS" do
[hsx|<script>var a = { hello: true }; alert('hello world');</script>|] `shouldBeSameHtml` "<script>var a = { hello: true }; alert('hello world');</script>"
[hsx|<script>{haskellCodeNotWorkingHere}</script>|] `shouldBeSameHtml` "<script>{haskellCodeNotWorkingHere}</script>"
it "should work with inline CSS" do
[hsx|<style>.blue { background: blue; }</style>|] `shouldBeSameHtml` "<style>.blue { background: blue; }</style>"
[hsx|<style>{haskellCodeNotWorkingHere}</style>|] `shouldBeSameHtml` "<style>{haskellCodeNotWorkingHere}</style>"
it "should strip whitespace around script tags" do
[hsx|
<script>
var apiKey = document.currentScript.dataset.apiKey;
</script>
|] `shouldBeSameHtml` "<script>var apiKey = document.currentScript.dataset.apiKey;</script>"
it "should strip whitespace around text nodes" do
[hsx| <strong> Hello World </strong> |] `shouldBeSameHtml` "<strong>Hello World</strong>"
[hsx|<i> a</i>|] `shouldBeSameHtml` "<i>a</i>"
[hsx|<i> a b</i>|] `shouldBeSameHtml` "<i>a b</i>"
[hsx|<i> a b c </i>|] `shouldBeSameHtml` "<i>a b c</i>"
it "should collapse spaces" do
[hsx|
Hello
World
!
|] `shouldBeSameHtml` "Hello World !"
it "should not strip whitespace around variables near to text nodes" do
let name :: Text = "Tester"
[hsx| <strong> Hello {name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello Tester !</strong>"
[hsx| <strong> Hello {name}{name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello TesterTester !</strong>"
[hsx| <strong> Hello {name} {name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello Tester Tester !</strong>"
[hsx|{name}|] `shouldBeSameHtml` "Tester"
let question :: Text = "Q"
let answer :: Text = "A"
[hsx|<td>{question} → {answer}</td>|] `shouldBeSameHtml` "<td>Q → A</td>"
it "should work with html comments" do
[Blaze.hsx|<div><!--my comment--></div>|] `shouldBeBlazeHtml` "<div><!-- my comment --></div>"
[Lucid2.hsx|<div><!--my comment--></div>|] `shouldBeLucid2Html` "<div><!--my comment--></div>"
it "should work with no render comments" do
[hsx|<div>{- my comment -}</div>|] `shouldBeSameHtml` "<div></div>"
it "should escape variables to avoid XSS" do
let variableContent :: Text = "<script>alert(1);</script>"
[hsx|{variableContent}|] `shouldBeSameHtml` "<script>alert(1);</script>"
it "should parse custom web component tags" do
[hsx|<confetti-effect></confetti-effect>|] `shouldBeSameHtml` "<confetti-effect></confetti-effect>"
[hsx|<confetti-effect/>|] `shouldBeSameHtml` "<confetti-effect></confetti-effect>" -- Currently we cannot deal with self closing tags as expected
[hsx|<div is="confetti-effect"></div>|] `shouldBeSameHtml` "<div is=\"confetti-effect\"></div>"
it "should parse a small hsx document" do
let metaTags = [hsx|
<meta charset="utf-8">
|]
let stylesheets = [hsx|
<link rel="stylesheet" href="/vendor/bootstrap.min.css"/>
<link rel="stylesheet" href="/vendor/flatpickr.min.css"/>
<link rel="stylesheet" href="/app.css"/>
|]
let scripts = [hsx|
<script src="/prod.js"></script>
|]
[hsx|
<html>
<head>
{metaTags}
{stylesheets}
{scripts}
<title>IHP Forum</title>
</head>
</html>
|] `shouldBeSameHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head></html>"
it "should parse an example hsx document" do
let metaTags = [hsx|
<meta charset="utf-8">
|]
metaTags `shouldBeSameHtml` "<meta charset=\"utf-8\">"
let stylesheets = [hsx|
<link rel="stylesheet" href="/vendor/bootstrap.min.css"/>
<link rel="stylesheet" href="/vendor/flatpickr.min.css"/>
<link rel="stylesheet" href="/app.css"/>
|]
let scripts = [hsx|
<script src="/prod.js"></script>
|]
[hsx|
<html>
<head>
{metaTags}
{stylesheets}
{scripts}
<title>IHP Forum</title>
</head>
<body>
<div class="container mt-4">
<nav class="navbar navbar-expand-lg navbar-light mb-4">
<a class="navbar-brand" href="/">λ IHP Forum</a>
</nav>
</div>
</body>
</html>
|] `shouldBeSameHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head><body><div class=\"container mt-4\"><nav class=\"navbar navbar-expand-lg navbar-light mb-4\"><a class=\"navbar-brand\" href=\"/\">\955 IHP Forum</a></nav></div></body></html>"
it "should handle spread attributes with a variable" do
let customAttributes :: [(Text, Text)] = [
("hello", "world")
]
[hsx|<div {...customAttributes}></div>|] `shouldBeSameHtml` "<div hello=\"world\"></div>"
it "should handle spread attributes with a list" do
-- See https://github.com/digitallyinduced/ihp/issues/1226
[hsx|<div {...[ ("data-hoge" :: Text, "Hello World!" :: Text) ]}></div>|] `shouldBeSameHtml` "<div data-hoge=\"Hello World!\"></div>"
it "should support pre escaped class names for Blaze" do
-- See https://github.com/digitallyinduced/ihp/issues/1527
let className = preEscapedTextValue "a&"
[Blaze.hsx|<div class={className}></div>|] `shouldBeBlazeHtml` "<div class=\"a&\"></div>"
it "should support pre escaped class names for Lucid2" do
-- See https://github.com/digitallyinduced/ihp/issues/1527
let className = Lucid2.MkLucidAttributeRaw "a&"
[Lucid2.hsx|<div class={className}></div>|] `shouldBeLucid2Html` "<div class=\"a&\"></div>"
it "should support support doctype" do
-- See https://github.com/digitallyinduced/ihp/issues/1717
[Blaze.hsx|<!DOCTYPE html><html lang="en"><body>hello</body></html>|] `shouldBeBlazeHtml` "<!DOCTYPE HTML>\n<html lang=\"en\"><body>hello</body></html>"
[Lucid2.hsx|<!DOCTYPE html><html lang="en"><body>hello</body></html>|] `shouldBeLucid2Html` "<!DOCTYPE HTML><html lang=\"en\"><body>hello</body></html>"
it "should support non-Identity effects for Lucid2" do
let increment :: State Int String = do
x <- get
put $! (x + 1)
pure $! show x
monadFragment :: Lucid2.HtmlT (State Int) ()
monadFragment = [Lucid2.hsxM|<div>{increment}</div><div>{increment}</div><div>{increment}</div>|]
textFragment :: TL.Text
textFragment = evalState (Lucid2.renderTextT monadFragment) 1
insertMonadFragment :: Lucid2.HtmlT (State Int) ()
insertMonadFragment = [Lucid2.hsxM|<div>{monadFragment}</div><div>{monadFragment}</div>|]
doubleTextFragment :: TL.Text
doubleTextFragment = evalState (Lucid2.renderTextT insertMonadFragment) 1
textFragment `shouldBe` "<div>1</div><div>2</div><div>3</div>"
doubleTextFragment `shouldBe` "<div><div>1</div><div>2</div><div>3</div></div><div><div>4</div><div>5</div><div>6</div></div>"
describe "customHsx" do
it "should allow specified custom tags" do
[myTagsOnlyHsx|<mycustomtag>hello</mycustomtag>|] `shouldBeSameHtml` "<mycustomtag>hello</mycustomtag>"
[myTagsOnlyHsx|<anothercustomtag>world</anothercustomtag>|] `shouldBeSameHtml` "<anothercustomtag>world</anothercustomtag>"
it "should allow specified custom attributes" do
[myAttrsOnlyHsx|<div my-custom-attr="hello">test</div>|] `shouldBeSameHtml` "<div my-custom-attr=\"hello\">test</div>"
[myAttrsOnlyHsx|<div anothercustomattr="world">test</div>|] `shouldBeSameHtml` "<div anothercustomattr=\"world\">test</div>"
it "should allow combining custom tags and attributes" do
[myCustomHsx|<mycustomtag my-custom-attr="hello">test</mycustomtag>|] `shouldBeSameHtml` "<mycustomtag my-custom-attr=\"hello\">test</mycustomtag>"
it "should work with regular HTML tags and attributes too" do
[myCustomHsx|<div class="hello" my-custom-attr="test">world</div>|] `shouldBeSameHtml` "<div class=\"hello\" my-custom-attr=\"test\">world</div>"
data Project = Project { name :: Text }
data PlaceId = PlaceId Text
data LocationId = LocationId Int PlaceId
newtype NewPlaceId = NewPlaceId Text
newPlaceData = NewPlaceId "New Punches Cross"
locationId = LocationId 17 (PlaceId "Punches Cross")
shouldBeSameHtml :: HasCallStack => AllBackends -> TL.Text -> Expectation
shouldBeSameHtml MkAllBackends {..} expectedHtml = do
Blaze.renderMarkup blazeMarkup `shouldBe` expectedHtml
Lucid2.renderText lucid2Html `shouldBe` expectedHtml
Lucid2.renderText lucid2HtmlM `shouldBe` expectedHtml
shouldBeBlazeHtml :: HasCallStack => Blaze.Markup -> TL.Text -> Expectation
shouldBeBlazeHtml blazeMarkup expectedHtml =
Blaze.renderMarkup blazeMarkup `shouldBe` expectedHtml
shouldBeLucid2Html :: HasCallStack => Lucid2.Html () -> TL.Text -> Expectation
shouldBeLucid2Html lucid2Html expectedHtml =
Lucid2.renderText lucid2Html `shouldBe` expectedHtml