# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1239309410 14400
# Node ID e28637743279301d453f4884318c38d12403b84e
# Parent  a6941960f459fc4fc79027599f3efb4143a16931
URLs

diff -r a6941960f459 -r e28637743279 CHANGELOG
--- a/CHANGELOG	Thu Apr 09 15:58:36 2009 -0400
+++ b/CHANGELOG	Thu Apr 09 16:36:50 2009 -0400
@@ -4,6 +4,7 @@
 
 - Reimplement constructor class resolution to be more general and Prolog-like
 - SQL table constraints
+- URLs, with configurable gatekeeper function Basis.bless
 
 ========
 20090405
diff -r a6941960f459 -r e28637743279 include/urweb.h
--- a/include/urweb.h	Thu Apr 09 15:58:36 2009 -0400
+++ b/include/urweb.h	Thu Apr 09 16:36:50 2009 -0400
@@ -149,3 +149,5 @@
 uw_unit uw_Basis_send(uw_context, uw_Basis_channel, uw_Basis_string);
 
 uw_Basis_client uw_Basis_self(uw_context, uw_unit);
+
+uw_Basis_string uw_Basis_bless(uw_context, uw_Basis_string);
diff -r a6941960f459 -r e28637743279 lib/ur/basis.urs
--- a/lib/ur/basis.urs	Thu Apr 09 15:58:36 2009 -0400
+++ b/lib/ur/basis.urs	Thu Apr 09 16:36:50 2009 -0400
@@ -486,7 +486,11 @@
 
 val hr : bodyTag []
 
-val a : bodyTag [Link = transaction page, Onclick = transaction unit]
+type url
+val bless : string -> url
+val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit]
+
+val img : bodyTag [Src = url]
 
 val form : ctx ::: {Unit} -> bind ::: {Type}
             -> [[Body] ~ ctx] =>
diff -r a6941960f459 -r e28637743279 src/c/urweb.c
--- a/src/c/urweb.c	Thu Apr 09 15:58:36 2009 -0400
+++ b/src/c/urweb.c	Thu Apr 09 16:36:50 2009 -0400
@@ -1973,3 +1973,7 @@
 
   return r;
 }
+
+uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
+  return s;
+}
diff -r a6941960f459 -r e28637743279 src/mono_opt.sig
--- a/src/mono_opt.sig	Thu Apr 09 15:58:36 2009 -0400
+++ b/src/mono_opt.sig	Thu Apr 09 16:36:50 2009 -0400
@@ -30,4 +30,6 @@
     val optimize : Mono.file -> Mono.file
     val optExp : Mono.exp -> Mono.exp
 
+    val bless : (string -> bool) ref
+
 end
diff -r a6941960f459 -r e28637743279 src/mono_opt.sml
--- a/src/mono_opt.sml	Thu Apr 09 15:58:36 2009 -0400
+++ b/src/mono_opt.sml	Thu Apr 09 16:36:50 2009 -0400
@@ -30,6 +30,8 @@
 open Mono
 structure U = MonoUtil
 
+val bless = ref (fn _ : string => true)
+
 fun typ t = t
 fun decl d = d
 
@@ -371,6 +373,13 @@
 
       | EJavaScript (_, _, SOME (e, _)) => e
 
+      | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
+        (if !bless s then
+             ()
+         else
+             ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
+         se)
+
       | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => 
         let
             fun uwify (cs, acc) =
diff -r a6941960f459 -r e28637743279 src/monoize.sml
--- a/src/monoize.sml	Thu Apr 09 15:58:36 2009 -0400
+++ b/src/monoize.sml	Thu Apr 09 16:36:50 2009 -0400
@@ -126,6 +126,7 @@
                   | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
                     readType (mt env dtmap t, loc)
 
+                  | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
@@ -2075,6 +2076,14 @@
                                 L'.ERecord xes => xes
                               | _ => raise Fail "Non-record attributes!"
 
+                val attrs =
+                    if List.exists (fn ("Link", _, _) => true
+                                     | _ => false) attrs then
+                        List.filter (fn ("Href", _, _) => false
+                                      | _ => true) attrs
+                    else
+                        attrs
+
                 fun findOnload (attrs, acc) =
                     case attrs of
                         [] => (NONE, acc)
@@ -2137,8 +2146,8 @@
                                       let
                                           val fooify =
                                               case x of
-                                                  "Href" => urlifyExp
-                                                | "Link" => urlifyExp
+                                                  "Link" => urlifyExp
+                                                | "Action" => urlifyExp
                                                 | _ => attrifyExp
 
                                           val xp = " " ^ lowercaseFirst x ^ "=\""
diff -r a6941960f459 -r e28637743279 src/urweb.grm
--- a/src/urweb.grm	Thu Apr 09 15:58:36 2009 -0400
+++ b/src/urweb.grm	Thu Apr 09 16:36:50 2009 -0400
@@ -1280,7 +1280,19 @@
 attrs  :                                ([])
        | attr attrs                     (attr :: attrs)
 
-attr   : SYMBOL EQ attrv                ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
+attr   : SYMBOL EQ attrv                ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
+                                         if (SYMBOL = "href" orelse SYMBOL = "src")
+                                            andalso (case #1 attrv of
+                                                         EPrim _ => true
+                                                       | _ => false) then
+                                             let
+                                                 val loc = s (attrvleft, attrvright)
+                                             in
+                                                 (EApp ((EVar (["Basis"], "bless", Infer), loc),
+                                                        attrv), loc)
+                                             end
+                                         else
+                                             attrv)
                 
 attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
diff -r a6941960f459 -r e28637743279 tests/img.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/img.ur	Thu Apr 09 16:36:50 2009 -0400
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+  <img src="http://www.google.com/intl/en_ALL/images/logo.gif"/>
+</body></xml>
diff -r a6941960f459 -r e28637743279 tests/img.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/img.urp	Thu Apr 09 16:36:50 2009 -0400
@@ -0,0 +1,3 @@
+debug
+
+img
diff -r a6941960f459 -r e28637743279 tests/url.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/url.ur	Thu Apr 09 16:36:50 2009 -0400
@@ -0,0 +1,13 @@
+val url = "http://www.yahoo.com/"
+
+fun readersChoice r = return <xml><body>
+  <a href={bless r.Url}>Your pick, boss</a>
+</body></xml>
+
+fun main () : transaction page = return <xml><body>
+  <a href="http://www.google.com/">Google!</a>
+  <a href={bless url}>Yahoo!</a><br/>
+  <br/>
+
+  <form><textbox{#Url}/> <submit action={readersChoice}/></form>
+</body></xml>
diff -r a6941960f459 -r e28637743279 tests/url.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/url.urp	Thu Apr 09 16:36:50 2009 -0400
@@ -0,0 +1,3 @@
+debug
+
+url
diff -r a6941960f459 -r e28637743279 tests/url.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/url.urs	Thu Apr 09 16:36:50 2009 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page