Commits

Alex Suraci committed d466e14

auto-escape contents, and don't use the HTML object directly whenever possible

  • Participants
  • Parent commits 04faab7

Comments (0)

Files changed (1)

 
 Self-Closing = "base meta link hr br param img area input col frame" words
 
-HTML new :=
-    HTML clone do: {
-        tag = ""
-        attributes = []
-        content = []
-        attribute-mode? = False
+(h: HTML) new :=
+  h clone do:
+    { tag = ""
+      attributes = []
+      content = []
+      attribute-mode? = False
     }
 
-HTML new: c := HTML new do: c
+(h: HTML) new: c := h new do: c
 
 
 -- creating elements with no content
 -- keyword dispatch adds attributes
-(h: HTML) did-not-understand: (m: Message) := {
-    elem = element-from: m particle name attrs: [] attr-mode: True
+(h: HTML) did-not-understand: (m: Message) :=
+  { elem = h element-from: m particle name attrs: [] attr-mode: True
 
     h content = h content << elem
 
     elem
-} call
+  } call
 
-element-from: s attrs: as :=
-    element-from: s attrs: as attr-mode: False
+-- creating elements with content
+(h: HTML) did-not-understand: (m: Message) at: 0 :=
+  if: h attribute-mode?
+    then: {
+      attr-names = m particle names
+      attr-values = m targets tail
+      attrs = attr-names zip: attr-values
+      h attributes = h attributes .. attrs
+    }
+    else: {
+      content = m targets (at: 1)
+      attr-names = m particle names tail
+      attr-values = m targets (drop: 2)
 
-element-from: selector attrs: as attr-mode: am := {
+      elem =
+        h element-from: m particle names (at: 0)
+            attrs: (attr-names zip: attr-values)
+
+      if: (content is-a?: Block)
+        then: { elem do: content }
+        else: { elem content = [content] }
+
+      h content = h content << elem
+    }
+
+(h: HTML) cdata: x :=
+  h content = h content << @(cdata: x)
+
+(h: HTML) doctype :=
+  h cdata: "<!DOCTYPE html>"
+
+(h: HTML) as: String :=
+  { content = h content (map:
+      { c |
+        c match: {
+          @(cdata: x) -> x
+          String -> c html-escape
+          _ -> c as: String
+        }
+      }) join
+
+    attrs = h attributes (map:
+      { a |
+        " " .. a from .. "=\"" .. a to .. "\""
+      }) join
+
+    condition: {
+      h tag empty? -> content
+
+      content empty? && (h tag in?: Self-Closing) ->
+        "<" .. h tag .. attrs .. " />"
+
+      otherwise ->
+        "<" .. h tag .. attrs .. ">" .. content .. "</" .. h tag .. ">"
+    }
+  } call
+
+"" html-escape := ""
+($< . ss) html-escape := "&lt;" .. ss html-escape
+($> . ss) html-escape := "&gt;" .. ss html-escape
+($& . ss) html-escape := "&amp;" .. ss html-escape
+(s: String) html-escape := s head singleton .. s tail html-escape
+
+(h: HTML) element-from: s attrs: as :=
+    h element-from: s attrs: as attr-mode: False
+
+(h: HTML) element-from: selector attrs: as attr-mode: am := {
     element = selector (split-on: $.) head (split-on: $#) head
     classes = selector (split-on: $.) tail map: { c | c (split-on: $#) head }
     id = selector (split-on: $#) tail map: { c | c (split-on: $.) head }
     when: id empty? not
         do: { as = ("id" -> id head) >> as }
 
-    HTML new do: {
+    h new do: {
         tag = element
         attributes = as
         attribute-mode? = am
     }
 } call
 
--- creating elements with content
-(h: HTML) did-not-understand: (m: Message) at: 0 :=
-    if: h attribute-mode?
-        then: {
-            attr-names = m particle names
-            attr-values = m targets tail
-            attrs = attr-names zip: attr-values
-            h attributes = h attributes .. attrs
-        }
-        else: {
-            content = m targets (at: 1)
-            attr-names = m particle names tail
-            attr-values = m targets (drop: 2)
-
-            elem =
-                element-from: m particle names (at: 0)
-                    attrs: (attr-names zip: attr-values)
-
-            if: (content is-a?: Block)
-                then: { elem do: content }
-                else: { elem content = [content] }
-
-            h content = h content << elem
-        }
-
-(h: HTML) cdata: x :=
-    h content = h content << x
-
-(h: HTML) doctype :=
-    h cdata: "<!DOCTYPE html>"
-
-(h: HTML) as: String := {
-    content = h content (map: @(as: String)) join
-
-    attrs = h attributes (map: { a |
-        " " .. a from .. "=\"" .. a to .. "\""
-    }) join
-
-    condition: {
-        h tag empty? -> content
-
-        content empty? && (h tag in?: Self-Closing) ->
-            "<" .. h tag .. attrs .. " />"
-
-        otherwise ->
-            "<" .. h tag .. attrs .. ">" .. content .. "</" .. h tag .. ">"
-    }
-} call