Mercurial > urweb
changeset 717:e28637743279
URLs
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 09 Apr 2009 16:36:50 -0400 |
| parents | a6941960f459 |
| children | f152f215a02c |
| files | CHANGELOG include/urweb.h lib/ur/basis.urs src/c/urweb.c src/mono_opt.sig src/mono_opt.sml src/monoize.sml src/urweb.grm tests/img.ur tests/img.urp tests/url.ur tests/url.urp tests/url.urs |
| diffstat | 13 files changed, 70 insertions(+), 4 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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);
--- 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] =>
--- 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; +}
--- 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
--- 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) =
--- 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 ^ "=\""
--- 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))
--- /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>
--- /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
--- /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>