From d7306dbac8ca9eecbba9d65379d225b5433b19fc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 9 Apr 2009 16:36:50 -0400 Subject: URLs --- CHANGELOG | 1 + include/urweb.h | 2 ++ lib/ur/basis.urs | 6 +++++- src/c/urweb.c | 4 ++++ src/mono_opt.sig | 2 ++ src/mono_opt.sml | 9 +++++++++ src/monoize.sml | 13 +++++++++++-- src/urweb.grm | 14 +++++++++++++- tests/img.ur | 3 +++ tests/img.urp | 3 +++ tests/url.ur | 13 +++++++++++++ tests/url.urp | 3 +++ tests/url.urs | 1 + 13 files changed, 70 insertions(+), 4 deletions(-) create mode 100644 tests/img.ur create mode 100644 tests/img.urp create mode 100644 tests/url.ur create mode 100644 tests/url.urp create mode 100644 tests/url.urs 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 + + 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 + Your pick, boss + + +fun main () : transaction page = return + Google! + Yahoo!
+
+ +
+
 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 -- cgit v1.2.3