uncheckedHsx + customHsx

ihp-hsx/IHP/HSX/Parser.hs

@@ -15,6 +15,7 @@ module IHP.HSX.Parser
 , Attribute (..)
 , AttributeValue (..)
 , collapseSpace
+, HsxSettings (..)
 ) where
 
 import Prelude
@@ -34,6 +35,12 @@ import qualified Data.Set as Set
 import qualified Data.Containers.ListUtils as List
 import qualified IHP.HSX.HaskellParser as HaskellParser
 
+data HsxSettings = HsxSettings
+    { checkMarkup :: Bool
+    , additionalTagNames :: Set Text
+    , additionalAttributeNames :: Set Text
+    }
+
 data AttributeValue = TextValue !Text | ExpressionValue !Haskell.Exp deriving (Eq, Show)
 
 data Attribute = StaticAttribute !Text !AttributeValue | SpreadAttributes !Haskell.Exp deriving (Eq, Show)
@@ -57,15 +64,16 @@ data Node = Node !Text ![Attribute] ![Node] !Bool
 -- > let position = Megaparsec.SourcePos filePath (Megaparsec.mkPos line) (Megaparsec.mkPos col)
 -- > let hsxText = "<strong>Hello</strong>"
 -- >
--- > let (Right node) = parseHsx position [] hsxText
-parseHsx :: SourcePos -> [TH.Extension] -> Text -> Either (ParseErrorBundle Text Void) Node
-parseHsx position extensions code =
+-- > let (Right node) = parseHsx settings position [] hsxText
+parseHsx :: HsxSettings -> SourcePos -> [TH.Extension] -> Text -> Either (ParseErrorBundle Text Void) Node
+parseHsx settings position extensions code =
     let
         ?extensions = extensions
+        ?settings = settings
     in
         runParser (setPosition position *> parser) "" code
 
-type Parser a = (?extensions :: [TH.Extension]) => Parsec Void Text a
+type Parser a = (?extensions :: [TH.Extension], ?settings :: HsxSettings) => Parsec Void Text a
 
 setPosition pstateSourcePos = updateParserState (\state -> state {
         statePosState = (statePosState state) { pstateSourcePos }
@@ -211,15 +219,16 @@ hsxNodeAttribute = do
 hsxAttributeName :: Parser Text
 hsxAttributeName = do
         name <- rawAttribute
-        unless (isValidAttributeName name) (fail $ "Invalid attribute name: " <> cs name)
+        let checkingMarkup = ?settings.checkMarkup
+        unless (isValidAttributeName name || not checkingMarkup) (fail $ "Invalid attribute name: " <> cs name)
         pure name
     where
         isValidAttributeName name =
             "data-" `Text.isPrefixOf` name
             || "aria-" `Text.isPrefixOf` name
             || "hx-" `Text.isPrefixOf` name
-            || "hx-" `Text.isPrefixOf` name
             || name `Set.member` attributes
+            || name `Set.member` ?settings.additionalAttributeNames
 
         rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-' || c == '_')
 
@@ -285,13 +294,18 @@ hsxSplicedNode = do
         treeToString acc (TokenNode (x:xs)) = ((treeToString (acc <> "{") x) <> (Text.concat $ fmap (treeToString "") xs)) <> "}"
 
 
+
 hsxElementName :: Parser Text
 hsxElementName = do
     name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_' || c == '-' || c == '!')
     let isValidParent = name `Set.member` parents
     let isValidLeaf = name `Set.member` leafs
-    let isValidCustomWebComponent = "-" `Text.isInfixOf` name
-    unless (isValidParent || isValidLeaf || isValidCustomWebComponent) (fail $ "Invalid tag name: " <> cs name)
+    let isValidCustomWebComponent = "-" `Text.isInfixOf` name 
+                                  && not (Text.isPrefixOf "-" name)
+                                  && not (Char.isNumber (Text.head name))
+    let isValidAdditionalTag = name `Set.member` ?settings.additionalTagNames
+    let checkingMarkup = ?settings.checkMarkup
+    unless (isValidParent || isValidLeaf || isValidCustomWebComponent || isValidAdditionalTag || not checkingMarkup) (fail $ "Invalid tag name: " <> cs name)
     space
     pure name
 

ihp-hsx/IHP/HSX/QQ.hs

@@ -5,7 +5,7 @@ Module: IHP.HSX.QQ
 Description: Defines the @[hsx||]@ syntax
 Copyright: (c) digitally induced GmbH, 2022
 -}
-module IHP.HSX.QQ (hsx) where
+module IHP.HSX.QQ (hsx, uncheckedHsx, customHsx) where
 
 import           Prelude
 import Data.Text (Text)
@@ -27,20 +27,39 @@ import Data.List (foldl')
 import IHP.HSX.Attribute
 import qualified Text.Blaze.Html5.Attributes as Attributes
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
 
 hsx :: QuasiQuoter
-hsx = QuasiQuoter {
-        quoteExp = quoteHsxExpression,
+hsx = customHsx 
+        (HsxSettings 
+            { checkMarkup = True
+            , additionalTagNames = Set.empty
+            , additionalAttributeNames = Set.empty
+            }
+        )
+
+uncheckedHsx :: QuasiQuoter
+uncheckedHsx = customHsx
+        (HsxSettings 
+            { checkMarkup = False
+            , additionalTagNames = Set.empty
+            , additionalAttributeNames = Set.empty
+            }
+    )
+
+customHsx :: HsxSettings -> QuasiQuoter
+customHsx settings = QuasiQuoter {
+        quoteExp = quoteHsxExpression settings,
         quotePat = error "quotePat: not defined",
         quoteDec = error "quoteDec: not defined",
         quoteType = error "quoteType: not defined"
     }
 
-quoteHsxExpression :: String -> TH.ExpQ
-quoteHsxExpression code = do
+quoteHsxExpression :: HsxSettings -> String -> TH.ExpQ
+quoteHsxExpression settings code = do
         hsxPosition <- findHSXPosition
         extensions <- TH.extsEnabled
-        expression <- case parseHsx hsxPosition extensions (cs code) of
+        expression <- case parseHsx settings hsxPosition extensions (cs code) of
                 Left error   -> fail (Megaparsec.errorBundlePretty error)
                 Right result -> pure result
         compileToHaskell expression
@@ -458,4 +477,4 @@ textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 te
 {-# INLINE textToStaticString #-}
 
 instance Show (MarkupM ()) where
-    show html = BlazeString.renderHtml html
+    show html = BlazeString.renderHtml html

ihp-hsx/Test/IHP/HSX/CustomHsxCases.hs

@@ -0,0 +1,38 @@
+{-|
+Module: Test.HSX.CustomHsxCases
+Description: Test helpers for HSX tests with custom tags and attributes
+-}
+module IHP.HSX.CustomHsxCases where
+
+import Test.Hspec
+import Prelude
+import IHP.HSX.QQ
+import qualified Text.Blaze.Renderer.Text as Blaze
+import Data.Text
+import Language.Haskell.TH.Quote
+import IHP.HSX.Parser
+import qualified Data.Set as Set
+
+myCustomHsx :: QuasiQuoter
+myCustomHsx = customHsx 
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList ["mycustomtag", "anothercustomtag"]
+                 , additionalAttributeNames = Set.fromList ["my-custom-attr", "anothercustomattr"] 
+                 }
+    )
+
+myTagsOnlyHsx :: QuasiQuoter
+myTagsOnlyHsx = customHsx
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList ["mycustomtag", "anothercustomtag"]
+                 , additionalAttributeNames = Set.fromList []
+                 }
+    )
+
+myAttrsOnlyHsx :: QuasiQuoter
+myAttrsOnlyHsx = customHsx
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList []
+                 , additionalAttributeNames = Set.fromList ["my-custom-attr", "anothercustomattr"]
+                 }
+    )

ihp-hsx/Test/IHP/HSX/ParserSpec.hs

@@ -11,68 +11,162 @@ import qualified Text.Megaparsec as Megaparsec
 import qualified Text.Megaparsec.Error as Megaparsec
 import qualified "template-haskell" Language.Haskell.TH as TH
 import qualified "template-haskell" Language.Haskell.TH.Syntax as TH
+import qualified Data.Set as Set
+
 
 tests = do
     let position = Megaparsec.SourcePos "" (Megaparsec.mkPos 1) (Megaparsec.mkPos 1)
     let extensions = []
+
     describe "HSX Parser" do
+        let settings = HsxSettings True Set.empty Set.empty
         it "should fail on invalid html tags" do
             let errorText = "1:13:\n  |\n1 | <myinvalidel>\n  |             ^\nInvalid tag name: myinvalidel\n"
-            let (Left error) = parseHsx position extensions "<myinvalidel>"
+            let (Left error) = parseHsx settings position extensions "<myinvalidel>"
             (Megaparsec.errorBundlePretty error) `shouldBe` errorText
 
         it "should fail on invalid attribute names" do
             let errorText = "1:23:\n  |\n1 | <div invalid-attribute=\"test\">\n  |                       ^\nInvalid attribute name: invalid-attribute\n"
-            let (Left error) = parseHsx position extensions "<div invalid-attribute=\"test\">"
+            let (Left error) = parseHsx settings position extensions "<div invalid-attribute=\"test\">"
             (Megaparsec.errorBundlePretty error) `shouldBe` errorText
 
         it "should fail on unmatched tags" do
             let errorText = "1:7:\n  |\n1 | <div></span>\n  |       ^\nunexpected '/'\nexpecting \"</div>\", identifier, or white space\n"
-            let (Left error) = parseHsx position extensions "<div></span>"
+            let (Left error) = parseHsx settings position extensions "<div></span>"
             (Megaparsec.errorBundlePretty error) `shouldBe` errorText
 
         it "should parse a closing tag with spaces" do
-            let p = parseHsx position extensions "<div></div >"
+            let p = parseHsx settings position extensions "<div></div >"
             p `shouldBe` (Right (Children [Node "div" [] [] False]))
 
         it "should strip spaces around nodes" do
-            let p = parseHsx position extensions "<div> <span> </span> </div>"
+            let p = parseHsx settings position extensions "<div> <span> </span> </div>"
             p `shouldBe` (Right (Children [Node "div" [] [Node "span" [] [] False] False]))
 
         it "should strip spaces after self closing tags" do
-            let p = parseHsx position extensions "<head>{\"meta\"}\n\n                        <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"></head>"
+            let p = parseHsx settings position extensions "<head>{\"meta\"}\n\n                        <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"></head>"
             p `shouldBe` (Right (Children [Node "head" [] [SplicedNode (TH.LitE (TH.StringL "meta")),Node "link" [StaticAttribute "rel" (TextValue "stylesheet"),StaticAttribute "href" (TextValue "/vendor/bootstrap.min.css")] [] True] False]))
 
         it "should not strip spaces in a text node" do
-            let p = parseHsx position extensions " Hello World "
+            let p = parseHsx settings position extensions " Hello World "
             p `shouldBe` (Right (Children [TextNode "Hello World"]))
 
         it "should deal with variables in text nodes" do
-            let p = parseHsx position extensions "<div>\n    Hello {\"name\"}! \n</div>"
+            let p = parseHsx settings position extensions "<div>\n    Hello {\"name\"}! \n</div>"
             p `shouldBe`  (Right (Children [Node "div" [] [TextNode "Hello ",SplicedNode (TH.LitE (TH.StringL "name")),TextNode "!"] False]))
 
         it "should parse self closing tags with spaces around it" do
-            let p = parseHsx position extensions " <div/> "
+            let p = parseHsx settings position extensions " <div/> "
             p `shouldBe`  (Right (Children [Node "div" [] [] False]))
 
         it "should collapse spaces" do
-            let p = parseHsx position extensions "\n    Hello\n    World\n    !    "
+            let p = parseHsx settings position extensions "\n    Hello\n    World\n    !    "
             p `shouldBe`  (Right (Children [TextNode "Hello World !"]))
 
         it "should parse spread values" do
-            let p = parseHsx position extensions "<div {...variables}/>"
+            let p = parseHsx settings position extensions "<div {...variables}/>"
             -- We cannot easily construct the @VarE variables@ expression, therefore we use show here for comparison
             show p `shouldBe` "Right (Children [Node \"div\" [SpreadAttributes (VarE variables)] [] False])"
 
         it "should parse spread values with a space" do
             -- See https://github.com/digitallyinduced/ihp/issues/1588
-            let p = parseHsx position extensions "<div { ...variables }/>"
+            let p = parseHsx settings position extensions "<div { ...variables }/>"
             show p `shouldBe` "Right (Children [Node \"div\" [SpreadAttributes (VarE variables)] [] False])"
 
         it "should accept underscores in data attributes" do
-            let p = parseHsx position extensions "<div data-client_id=\"test\"/>"
+            let p = parseHsx settings position extensions "<div data-client_id=\"test\"/>"
             p `shouldBe` (Right (Children [Node "div" [StaticAttribute "data-client_id" (TextValue "test")] [] False]))
 
         it "should accept doctype" do
-            let p = parseHsx position extensions "<!DOCTYPE html><html lang=\"en\"><body>hello</body></html>"
-            p `shouldBe` (Right (Children [Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True, Node "html" [StaticAttribute "lang" (TextValue "en")] [Node "body" [] [TextNode "hello"] False] False]))
+            let p = parseHsx settings position extensions "<!DOCTYPE html><html lang=\"en\"><body>hello</body></html>"
+            p `shouldBe` (Right (Children [Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True, Node "html" [StaticAttribute "lang" (TextValue "en")] [Node "body" [] [TextNode "hello"] False] False]))
+
+    describe "uncheckedHsx" do
+        let settings = HsxSettings False Set.empty Set.empty
+        it "should not check markup" do
+            let p = parseHsx settings position extensions "<invalid-tag invalid-attribute=\"invalid\"/>"
+            p `shouldBe` (Right (Children [Node "invalid-tag" [StaticAttribute "invalid-attribute" (TextValue "invalid")] [] False]))
+
+        it "should not check attribute names" do
+            let p = parseHsx settings position extensions "<div invalid-attribute=\"invalid\"/>"
+            p `shouldBe` (Right (Children [Node "div" [StaticAttribute "invalid-attribute" (TextValue "invalid")] [] False]))
+
+        it "should fail on unmatched tags" do
+            let errorText = "1:7:\n  |\n1 | <div></span>\n  |       ^\nunexpected '/'\nexpecting \"</div>\", identifier, or white space\n"
+            let (Left error) = parseHsx settings position extensions "<div></span>"
+            (Megaparsec.errorBundlePretty error) `shouldBe` errorText
+
+        it "should parse a closing tag with spaces" do
+            let p = parseHsx settings position extensions "<div></div >"
+            p `shouldBe` (Right (Children [Node "div" [] [] False]))
+
+        it "should strip spaces around nodes" do
+            let p = parseHsx settings position extensions "<div> <span> </span> </div>"
+            p `shouldBe` (Right (Children [Node "div" [] [Node "span" [] [] False] False]))
+
+        it "should strip spaces after self closing tags" do
+            let p = parseHsx settings position extensions "<head>{\"meta\"}\n\n                        <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"></head>"
+            p `shouldBe` (Right (Children [Node "head" [] [SplicedNode (TH.LitE (TH.StringL "meta")),Node "link" [StaticAttribute "rel" (TextValue "stylesheet"),StaticAttribute "href" (TextValue "/vendor/bootstrap.min.css")] [] True] False]))
+
+        it "should not strip spaces in a text node" do
+            let p = parseHsx settings position extensions " Hello World "
+            p `shouldBe` (Right (Children [TextNode "Hello World"]))
+
+        it "should deal with variables in text nodes" do
+            let p = parseHsx settings position extensions "<div>\n    Hello {\"name\"}! \n</div>"
+            p `shouldBe`  (Right (Children [Node "div" [] [TextNode "Hello ",SplicedNode (TH.LitE (TH.StringL "name")),TextNode "!"] False]))
+
+        it "should parse self closing tags with spaces around it" do
+            let p = parseHsx settings position extensions " <div/> "
+            p `shouldBe`  (Right (Children [Node "div" [] [] False]))
+
+        it "should collapse spaces" do
+            let p = parseHsx settings position extensions "\n    Hello\n    World\n    !    "
+            p `shouldBe`  (Right (Children [TextNode "Hello World !"]))
+
+        it "should parse spread values" do
+            let p = parseHsx settings position extensions "<div {...variables}/>"
+            -- We cannot easily construct the @VarE variables@ expression, therefore we use show here for comparison
+            show p `shouldBe` "Right (Children [Node \"div\" [SpreadAttributes (VarE variables)] [] False])"
+
+        it "should parse spread values with a space" do
+            -- See https://github.com/digitallyinduced/ihp/issues/1588
+            let p = parseHsx settings position extensions "<div { ...variables }/>"
+            show p `shouldBe` "Right (Children [Node \"div\" [SpreadAttributes (VarE variables)] [] False])"
+
+        it "should accept underscores in data attributes" do
+            let p = parseHsx settings position extensions "<div data-client_id=\"test\"/>"
+            p `shouldBe` (Right (Children [Node "div" [StaticAttribute "data-client_id" (TextValue "test")] [] False]))
+
+        it "should accept doctype" do
+            let p = parseHsx settings position extensions "<!DOCTYPE html><html lang=\"en\"><body>hello</body></html>"
+            p `shouldBe` (Right (Children [Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True, Node "html" [StaticAttribute "lang" (TextValue "en")] [Node "body" [] [TextNode "hello"] False] False]))
+
+    describe "customHsx" do
+        let customSettings = HsxSettings True 
+                (Set.fromList ["mycustomtag"])
+                (Set.fromList ["my-custom-attr"])
+
+        it "should allow specified custom tags" do
+            let p = parseHsx customSettings position extensions "<mycustomtag>hello</mycustomtag>"
+            p `shouldBe` (Right (Children [Node "mycustomtag" [] [TextNode "hello"] False]))
+
+        it "should reject non-specified custom tags" do
+            let errorText = "1:15:\n  |\n1 | <notallowedtag>hello</notallowedtag>\n  |               ^\nInvalid tag name: notallowedtag\n"
+            case parseHsx customSettings position extensions "<notallowedtag>hello</notallowedtag>" of
+                Left error -> (Megaparsec.errorBundlePretty error) `shouldBe` errorText
+                Right _ -> fail "Expected parser to fail with invalid tag name"
+
+        it "should allow specified custom attributes" do
+            let p = parseHsx customSettings position extensions "<div my-custom-attr=\"hello\">test</div>"
+            p `shouldBe` (Right (Children [Node "div" [StaticAttribute "my-custom-attr" (TextValue "hello")] [TextNode "test"] False]))
+
+        it "should reject non-specified custom attributes" do
+            let errorText = "1:22:\n  |\n1 | <div not-allowed-attr=\"test\">\n  |                      ^\nInvalid attribute name: not-allowed-attr\n"
+            case parseHsx customSettings position extensions "<div not-allowed-attr=\"test\">" of
+                Left error -> (Megaparsec.errorBundlePretty error) `shouldBe` errorText
+                Right _ -> fail "Expected parser to fail with invalid attribute name"
+
+        it "should allow mixing custom and standard elements" do
+            let p = parseHsx customSettings position extensions "<mycustomtag class=\"hello\" my-custom-attr=\"world\">test</mycustomtag>"
+            p `shouldBe` (Right (Children [Node "mycustomtag" [StaticAttribute "class" (TextValue "hello"), StaticAttribute "my-custom-attr" (TextValue "world")] [TextNode "test"] False]))