# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1336334928 14400
# Node ID e9587120831aae16f442f3e87fe7ddada7da3207
# Parent  a1380fc15cb5fe3a07dcae6fa2b63c6cf4ee2fb1
Run-time CSS style validation

diff -r a1380fc15cb5 -r e9587120831a include/urweb/urweb.h
--- a/include/urweb/urweb.h	Sun May 06 15:46:25 2012 -0400
+++ b/include/urweb/urweb.h	Sun May 06 16:08:48 2012 -0400
@@ -356,4 +356,8 @@
 uw_Basis_int uw_Basis_trunc(uw_context, uw_Basis_float);
 uw_Basis_int uw_Basis_round(uw_context, uw_Basis_float);
 
+uw_Basis_string uw_Basis_atom(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_css_url(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_property(uw_context, uw_Basis_string);
+
 #endif
diff -r a1380fc15cb5 -r e9587120831a lib/js/urweb.js
--- a/lib/js/urweb.js	Sun May 06 15:46:25 2012 -0400
+++ b/lib/js/urweb.js	Sun May 06 16:08:48 2012 -0400
@@ -1748,6 +1748,46 @@
 }
 
 
+// CSS validation
+
+function atom(s) {
+    for (var i = 0; i < s.length; ++i) {
+        var c = s[i];
+        if (!isAlnum(c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')
+            er("Disallowed character in CSS atom");
+    }
+
+    return s;
+}
+
+function css_url(s) {
+    for (var i = 0; i < s.length; ++i) {
+        var c = s[i];
+        if (!isAlnum(c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+'
+            && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')
+            er("Disallowed character in CSS URL");
+    }
+
+    return s;
+}
+
+function property(s) {
+    if (s.length <= 0)
+        er("Empty CSS property");
+
+    if (!isLower(s[0]) && s[0] != '_')
+        er("Bad initial character in CSS property");
+
+    for (var i = 0; i < s.length; ++i) {
+        var c = s[i];
+        if (!isLower(c) && !isDigit(c) && c != '_' && c != '-')
+            er("Disallowed character in CSS property");
+    }
+
+    return s;
+}
+
+
 // ID generation
 
 var nextId = 0;
diff -r a1380fc15cb5 -r e9587120831a src/c/urweb.c
--- a/src/c/urweb.c	Sun May 06 15:46:25 2012 -0400
+++ b/src/c/urweb.c	Sun May 06 16:08:48 2012 -0400
@@ -4021,3 +4021,46 @@
 uw_Basis_int uw_Basis_round(uw_context ctx, uw_Basis_float n) {
   return round(n);
 }
+
+uw_Basis_string uw_Basis_atom(uw_context ctx, uw_Basis_string s) {
+  char *p;
+
+  for (p = s; *p; ++p) {
+    char c = *p;
+    if (!isalnum(c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')
+      uw_error(ctx, FATAL, "Disallowed character in CSS atom");
+  }
+
+  return s;
+}
+
+uw_Basis_string uw_Basis_css_url(uw_context ctx, uw_Basis_string s) {
+  char *p;
+
+  for (p = s; *p; ++p) {
+    char c = *p;
+    if (!isalnum(c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+'
+        && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')
+      uw_error(ctx, FATAL, "Disallowed character in CSS URL");
+  }
+
+  return s;
+}
+
+uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) {
+  char *p;
+
+  if (!*s)
+    uw_error(ctx, FATAL, "Empty CSS property");
+
+  if (!islower(s[0]) && s[0] != '_')
+    uw_error(ctx, FATAL, "Bad initial character in CSS property");
+
+  for (p = s; *p; ++p) {
+    char c = *p;
+    if (!islower(c) && !isdigit(c) && c != '_' && c != '-')
+      uw_error(ctx, FATAL, "Disallowed character in CSS property");
+  }
+
+  return s;
+}
diff -r a1380fc15cb5 -r e9587120831a src/mono_opt.sml
--- a/src/mono_opt.sml	Sun May 06 15:46:25 2012 -0400
+++ b/src/mono_opt.sml	Sun May 06 16:08:48 2012 -0400
@@ -129,6 +129,7 @@
                                            orelse ch = #"/"
                                            orelse ch = #"."
                                            orelse ch = #"_"
+                                           orelse ch = #"+"
                                            orelse ch = #"-"
                                            orelse ch = #"%"
                                            orelse ch = #"?"
diff -r a1380fc15cb5 -r e9587120831a src/settings.sml
--- a/src/settings.sml	Sun May 06 15:46:25 2012 -0400
+++ b/src/settings.sml	Sun May 06 16:08:48 2012 -0400
@@ -315,7 +315,11 @@
                           ("preventDefault", "uw_preventDefault"),
                           ("stopPropagation", "uw_stopPropagation"),
 
-                          ("fresh", "fresh")]
+                          ("fresh", "fresh"),
+
+                          ("atom", "atom"),
+                          ("css_url", "css_url"),
+                          ("property", "property")]
 val jsFuncs = ref jsFuncsBase
 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
 fun jsFunc x = M.find (!jsFuncs, x)
diff -r a1380fc15cb5 -r e9587120831a tests/styleRt.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/styleRt.ur	Sun May 06 16:08:48 2012 -0400
@@ -0,0 +1,38 @@
+fun handler r =
+    return <xml><body>
+      <span style={oneProperty
+                       (oneProperty noStyle (value (property r.Prop) (atom r.Valu)))
+                       (value (property "background") (css_url (bless r.Url)))}>
+        Teeeest
+      </span>
+    </body></xml>
+
+fun main () =
+    prop <- source "";
+    valu <- source "";
+    url <- source "";
+    xm <- source <xml/>;
+    return <xml><body>
+      Property: <ctextbox source={prop}/><br/>
+      Value: <ctextbox source={valu}/><br/>
+      URL: <ctextbox source={url}/><br/>
+      <button value="Go!" onclick={prop <- get prop;
+                                   valu <- get valu;
+                                   url <- get url;
+                                   set xm <xml><span style={oneProperty
+                                                                (oneProperty noStyle (value (property prop) (atom valu)))
+                                                                (value (property "background") (css_url (bless url)))}>
+                                     Teeeest
+                                   </span></xml>}/>
+      <hr/>
+      <dyn signal={signal xm}/>
+      <hr/>
+      <h2>Or the old fashioned way...</h2>
+
+      <form>
+        Property: <textbox{#Prop}/><br/>
+        Value: <textbox{#Valu}/><br/>
+        URL: <textbox{#Url}/><br/>
+        <submit action={handler}/>
+      </form>
+    </body></xml>
diff -r a1380fc15cb5 -r e9587120831a tests/styleRt.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/styleRt.urp	Sun May 06 16:08:48 2012 -0400
@@ -0,0 +1,4 @@
+rewrite all StyleRt/*
+allow url http://www.google.com/*
+
+styleRt
diff -r a1380fc15cb5 -r e9587120831a tests/styleRt.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/styleRt.urs	Sun May 06 16:08:48 2012 -0400
@@ -0,0 +1,1 @@
+val main : {} -> transaction page