summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGELOG1
-rw-r--r--include/urweb.h2
-rw-r--r--lib/ur/basis.urs6
-rw-r--r--src/c/urweb.c4
-rw-r--r--src/mono_opt.sig2
-rw-r--r--src/mono_opt.sml9
-rw-r--r--src/monoize.sml13
-rw-r--r--src/urweb.grm14
-rw-r--r--tests/img.ur3
-rw-r--r--tests/img.urp3
-rw-r--r--tests/url.ur13
-rw-r--r--tests/url.urp3
-rw-r--r--tests/url.urs1
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