URLs

13 files changed, 70 insertions, 4 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 51d5b05b..ee860622 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -4,6 +4,7 @@ Next
 
 - Reimplement constructor class resolution to be more general and Prolog-like
 - SQL table constraints
+- URLs, with configurable gatekeeper function Basis.bless
 
 ========
 20090405
diff --git a/include/urweb.h b/include/urweb.h
index 759fc5ac..2154a8ed 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -149,3 +149,5 @@ uw_Basis_channel uw_Basis_new_channel(uw_context, uw_unit);
 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 --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index f652165d..f2f378ee 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -486,7 +486,11 @@ val ul : bodyTag []
 
 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 --git a/src/c/urweb.c b/src/c/urweb.c
index 67985d35..89358a06 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1973,3 +1973,7 @@ failure_kind uw_initialize(uw_context ctx) {
 
   return r;
 }
+
+uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
+  return s;
+}
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index d0268087..b1652c71 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -30,4 +30,6 @@ signature MONO_OPT = sig
     val optimize : Mono.file -> Mono.file
     val optExp : Mono.exp -> Mono.exp
 
+    val bless : (string -> bool) ref
+
 end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index dfa0420c..205ae3fb 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -30,6 +30,8 @@ structure MonoOpt :> MONO_OPT = struct
 open Mono
 structure U = MonoUtil
 
+val bless = ref (fn _ : string => true)
+
 fun typ t = t
 fun decl d = d
 
@@ -371,6 +373,13 @@ fun exp e =
 
       | 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 --git a/src/monoize.sml b/src/monoize.sml
index 950de1e1..bf26fda2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -126,6 +126,7 @@ fun monoType env =
                   | 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                       let
                                           val fooify =
                                               case x of
-                                                  "Href" => urlifyExp
-                                                | "Link" => urlifyExp
+                                                  "Link" => urlifyExp
+                                                | "Action" => urlifyExp
                                                 | _ => attrifyExp
 
                                           val xp = " " ^ lowercaseFirst x ^ "=\""
diff --git a/src/urweb.grm b/src/urweb.grm
index 7e1f6757..7288359a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1280,7 +1280,19 @@ tagHead: BEGIN_TAG                      (let
 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 --git a/tests/img.ur b/tests/img.ur
new file mode 100644
index 00000000..70896647
--- /dev/null
+++ b/tests/img.ur
@@ -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 --git a/tests/img.urp b/tests/img.urp
new file mode 100644
index 00000000..ff71adee
--- /dev/null
+++ b/tests/img.urp
@@ -0,0 +1,3 @@
+debug
+
+img
diff --git a/tests/url.ur b/tests/url.ur
new file mode 100644
index 00000000..c45681e0
--- /dev/null
+++ b/tests/url.ur
@@ -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 --git a/tests/url.urp b/tests/url.urp
new file mode 100644
index 00000000..3d4961ef
--- /dev/null
+++ b/tests/url.urp
@@ -0,0 +1,3 @@
+debug
+
+url
diff --git a/tests/url.urs b/tests/url.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/url.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page