diff options
| -rw-r--r-- | CHANGELOG | 6 | ||||
| -rw-r--r-- | include/types.h | 2 | ||||
| -rw-r--r-- | include/urweb.h | 1 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 3 | ||||
| -rw-r--r-- | src/c/request.c | 2 | ||||
| -rw-r--r-- | src/c/urweb.c | 46 | ||||
| -rw-r--r-- | src/checknest.sml | 2 | ||||
| -rw-r--r-- | src/cjr.sml | 1 | ||||
| -rw-r--r-- | src/cjr_print.sml | 14 | ||||
| -rw-r--r-- | src/cjrize.sml | 7 | ||||
| -rw-r--r-- | src/jscomp.sml | 7 | ||||
| -rw-r--r-- | src/mono.sml | 1 | ||||
| -rw-r--r-- | src/mono_opt.sml | 9 | ||||
| -rw-r--r-- | src/mono_print.sml | 8 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 2 | ||||
| -rw-r--r-- | src/mono_util.sml | 6 | ||||
| -rw-r--r-- | src/monoize.sml | 420 | ||||
| -rw-r--r-- | src/prepare.sml | 7 | ||||
| -rw-r--r-- | src/scriptcheck.sml | 1 | ||||
| -rw-r--r-- | src/tag.sml | 227 | ||||
| -rw-r--r-- | tests/makeUrl.ur | 3 | ||||
| -rw-r--r-- | tests/makeUrl.urp | 3 | ||||
| -rw-r--r-- | tests/makeUrl.urs | 1 | ||||
| -rw-r--r-- | tests/redirect.ur | 15 | ||||
| -rw-r--r-- | tests/redirect.urp | 4 | ||||
| -rw-r--r-- | tests/redirect.urs | 1 |
26 files changed, 496 insertions, 303 deletions
@@ -1,4 +1,10 @@ ======== +Next +======== + +- Reifying expressions as URLs and redirecting to them explicitly + +======== 20091203 ======== diff --git a/include/types.h b/include/types.h index 19eae5ad..767b2345 100644 --- a/include/types.h +++ b/include/types.h @@ -39,7 +39,7 @@ typedef struct uw_Basis_file { uw_Basis_blob data; } uw_Basis_file; -typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_BLOB } failure_kind; +typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_INDIRECTLY } failure_kind; typedef enum { SERVED, KEEP_OPEN, FAILED } request_result; diff --git a/include/urweb.h b/include/urweb.h index 76bb9f25..0a23018a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -209,6 +209,7 @@ uw_Basis_blob uw_Basis_fileData(uw_context, uw_Basis_file); uw_Basis_int uw_Basis_blobSize(uw_context, uw_Basis_blob); __attribute__((noreturn)) void uw_return_blob(uw_context, uw_Basis_blob, uw_Basis_string mimeType); +__attribute__((noreturn)) void uw_redirect(uw_context, uw_Basis_string url); uw_Basis_time uw_Basis_now(uw_context); extern const uw_Basis_time uw_Basis_minTime; diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 200d9896..b56c5e5e 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -560,8 +560,11 @@ con tabl = [Body, Table] con tr = [Body, Tr] type url +val show_url : show url val bless : string -> url val checkUrl : string -> option url +val url : transaction page -> url +val redirect : t ::: Type -> url -> transaction t val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ body] => unit -> tag [Signal = signal (xml (body ++ ctx) use bind)] (body ++ ctx) [] use bind diff --git a/src/c/request.c b/src/c/request.c index 069de4aa..2357a86b 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -374,7 +374,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx, } strcpy(rc->path_copy, path); fk = uw_begin(ctx, rc->path_copy); - if (fk == SUCCESS || fk == RETURN_BLOB) { + if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { uw_commit(ctx); return SERVED; } else if (fk == BOUNDED_RETRY) { diff --git a/src/c/urweb.c b/src/c/urweb.c index 95142a2d..476e3794 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -199,6 +199,7 @@ static client *find_client(unsigned id) { } static char *on_success = "HTTP/1.1 200 OK\r\n"; +static char *on_redirect = "HTTP/1.1 303 See Other\r\n"; void uw_set_on_success(char *s) { on_success = s; @@ -352,7 +353,7 @@ struct uw_context { void *get_header_data; buf outHeaders, page, heap, script; - int returning_blob; + int returning_indirectly; input *inputs, *subinputs, *cur_container; size_t n_subinputs, used_subinputs; @@ -396,7 +397,7 @@ uw_context uw_init() { buf_init(&ctx->outHeaders, 0); buf_init(&ctx->page, 0); - ctx->returning_blob = 0; + ctx->returning_indirectly = 0; buf_init(&ctx->heap, 0); buf_init(&ctx->script, 1); ctx->script.start[0] = 0; @@ -475,7 +476,7 @@ void uw_reset_keep_error_message(uw_context ctx) { buf_reset(&ctx->script); ctx->script.start[0] = 0; buf_reset(&ctx->page); - ctx->returning_blob = 0; + ctx->returning_indirectly = 0; buf_reset(&ctx->heap); ctx->regions = NULL; ctx->cleanup_front = ctx->cleanup; @@ -2793,7 +2794,7 @@ void uw_commit(uw_context ctx) { ctx->transactionals[i].free(ctx->transactionals[i].data); // Splice script data into appropriate part of page - if (ctx->returning_blob || ctx->script_header[0] == 0) { + if (ctx->returning_indirectly || ctx->script_header[0] == 0) { char *start = strstr(ctx->page.start, "<sc>"); if (start) { memmove(start, start + 4, buf_used(&ctx->page) - (start - ctx->page.start) - 4); @@ -2942,7 +2943,17 @@ failure_kind uw_initialize(uw_context ctx) { extern int uw_check_url(const char *); extern int uw_check_mime(const char *); +static int url_bad(uw_Basis_string s) { + for (; *s; ++s) + if (!isgraph(*s)) + return 1; + + return 0; +} + uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) { + if (url_bad(s)) + uw_error(ctx, FATAL, "Invalid URL %s", uw_Basis_htmlifyString(ctx, s)); if (uw_check_url(s)) return s; else @@ -2950,6 +2961,8 @@ uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) { } uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) { + if (url_bad(s)) + return NULL; if (uw_check_url(s)) return s; else @@ -3024,7 +3037,7 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u cleanup *cl; int len; - ctx->returning_blob = 1; + ctx->returning_indirectly = 1; buf_reset(&ctx->outHeaders); buf_reset(&ctx->page); @@ -3044,7 +3057,28 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u ctx->cleanup_front = ctx->cleanup; - longjmp(ctx->jmp_buf, RETURN_BLOB); + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + +__attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) { + cleanup *cl; + int len; + + ctx->returning_indirectly = 1; + buf_reset(&ctx->outHeaders); + buf_reset(&ctx->page); + + uw_write_header(ctx, on_redirect); + uw_write_header(ctx, "Location: "); + uw_write_header(ctx, url); + uw_write_header(ctx, "\r\n\r\n"); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); } uw_Basis_string uw_Basis_unAs(uw_context ctx, uw_Basis_string s) { diff --git a/src/checknest.sml b/src/checknest.sml index 27a1796c..49519705 100644 --- a/src/checknest.sml +++ b/src/checknest.sml @@ -57,6 +57,7 @@ fun expUses globals = | EError (e, _) => eu e | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType) + | ERedirect (e, _) => eu e | EWrite e => eu e | ESeq (e1, e2) => IS.union (eu e1, eu e2) @@ -117,6 +118,7 @@ fun annotateExp globals = | EError (e, t) => (EError (ae e, t), loc) | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc) + | ERedirect (e, t) => (ERedirect (ae e, t), loc) | EWrite e => (EWrite (ae e), loc) | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc) diff --git a/src/cjr.sml b/src/cjr.sml index 8c4267f6..2b8ce6fe 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -77,6 +77,7 @@ datatype exp' = | EError of exp * typ | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | ERedirect of exp * typ | EWrite of exp | ESeq of exp * exp diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e459db62..a1d5ed2c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1451,6 +1451,20 @@ fun p_exp' par env (e, loc) = string "tmp;", newline, string "})"] + | ERedirect (e, t) => + box [string "({", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_redirect(ctx, ", + p_exp env e, + string ");", + newline, + string "tmp;", + newline, + string "})"] | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => p_exp env (EError (e, ran), loc) | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => diff --git a/src/cjrize.sml b/src/cjrize.sml index c7bf7c9d..703b9477 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -367,6 +367,13 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm) end + | L.ERedirect (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.ERedirect (e, t), loc), sm) + end | L.EStrcat (e1, e2) => let diff --git a/src/jscomp.sml b/src/jscomp.sml index 4be870cb..471711d2 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -870,6 +870,7 @@ fun process file = | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EReturnBlob _ => unsupported "EUnurlify" + | ERedirect _ => unsupported "ERedirect" | ESignalReturn e => let @@ -1081,6 +1082,12 @@ fun process file = in ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) end + | ERedirect (e, t) => + let + val (e, st) = exp outer (e, st) + in + ((ERedirect (e, t), loc), st) + end | EWrite e => let diff --git a/src/mono.sml b/src/mono.sml index 35aada16..92424ee3 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -90,6 +90,7 @@ datatype exp' = | EError of exp * typ | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | ERedirect of exp * typ | EWrite of exp | ESeq of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index eb4f5811..5d81d24d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -115,6 +115,8 @@ fun unAs s = doChars (String.explode s, []) end +fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s + fun exp e = case e of EPrim (Prim.String s) => @@ -405,11 +407,16 @@ fun exp e = optExp (EApp (e2, e1), loc) | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) => - (if Settings.checkUrl s then + (if checkUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); se) + | EFfiApp ("Basis", "checkUrl", [(se as EPrim (Prim.String s), loc)]) => + (if checkUrl s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) => (if Settings.checkMime s then () diff --git a/src/mono_print.sml b/src/mono_print.sml index 6ac3393d..cfaa410b 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -239,6 +239,14 @@ fun p_exp' par env (e, _) = space, p_typ env t, string ")"] + | ERedirect (e, t) => box [string "(redirect", + space, + p_exp env e, + space, + string ":", + space, + p_typ env t, + string ")"] | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1, space, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 04cd199e..a15ce34b 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -98,6 +98,7 @@ fun impure (e, _) = | EError (e, _) => impure e | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2 + | ERedirect (e, _) => impure e | EStrcat (e1, e2) => impure e1 orelse impure e2 @@ -429,6 +430,7 @@ fun reduce file = | EError (e, _) => summarize d e @ [Unsure] | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Unsure] + | ERedirect (e, _) => summarize d e @ [Unsure] | EWrite e => summarize d e @ [WritePage] diff --git a/src/mono_util.sml b/src/mono_util.sml index f8e45dc3..91b4412e 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -263,6 +263,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc)))) + | ERedirect (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (ERedirect (e', t'), loc))) | EStrcat (e1, e2) => S.bind2 (mfe ctx e1, diff --git a/src/monoize.sml b/src/monoize.sml index 25b7d9c3..2d1a1f33 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -395,6 +395,8 @@ fun capitalize s = else str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) +val inTag = ref false + fun fooifyExp fk env = let fun fooify fm (e, tAll as (t, loc)) = @@ -1065,6 +1067,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) end + | L.EFfi ("Basis", "show_url") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end | L.EFfi ("Basis", "show_char") => ((L'.EFfi ("Basis", "charToString"), loc), fm) | L.EFfi ("Basis", "show_bool") => @@ -2472,6 +2480,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = tag), _), xml) => let + val inT = !inTag + val () = inTag := true + fun getTag' (e, _) = case e of L.EFfi ("Basis", tag) => (tag, []) @@ -2707,206 +2718,207 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EPrim (Prim.String ")"), loc)), loc)), loc) end in - case tag of - "body" => let - val onload = execify onload - val onunload = execify onunload - in - normal ("body", - SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", - [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", - [(L'.ERecord [], loc)]), loc), - onload), loc)]), - loc), - (L'.EFfiApp ("Basis", "maybe_onunload", - [onunload]), - loc)), loc), - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) - end - - | "dyn" => - let - fun inTag tag = case targs of - (L.CRecord (_, ctx), _) :: _ => - List.exists (fn ((L.CName tag', _), _) => tag' = tag - | _ => false) ctx - | _ => false - - val tag = if inTag "Tr" then - "tr" - else if inTag "Table" then - "table" - else - "span" - in - case attrs of - [("Signal", e, _)] => - ((L'.EStrcat - ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" - ^ tag ^ "\", execD(")), loc), - (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), - fm) - | _ => raise Fail "Monoize: Bad dyn attributes" - end - - | "submit" => normal ("input type=\"submit\"", NONE, NONE) - | "button" => normal ("input type=\"submit\"", NONE, NONE) - | "hidden" => input "hidden" - - | "textbox" => - (case targs of - [_, (L.CName name, _)] => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")), - loc)), loc), fm) - end - | SOME (_, src, _) => - (strcat [str "<script type=\"text/javascript\">inp(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))</script>"], - fm)) - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to textbox tag")) - | "password" => input "password" - | "textarea" => - (case targs of - [_, (L.CName name, _)] => - let - val (ts, fm) = tagStart "textarea" - val (xml, fm) = monoExp (env, st, fm) xml - in - ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), - (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</textarea>"), - loc)), loc)), - loc), fm) - end - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to ltextarea tag")) - - | "checkbox" => input "checkbox" - | "upload" => input "file" - - | "radio" => - (case targs of - [_, (L.CName name, _)] => - monoExp (env, St.setRadioGroup (st, name), fm) xml - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to radio tag")) - | "radioOption" => - (case St.radioGroup st of - NONE => raise Fail "No name for radioGroup" - | SOME name => - normal ("input", - SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), - NONE)) - - | "select" => - (case targs of - [_, (L.CName name, _)] => - let - val (ts, fm) = tagStart "select" - val (xml, fm) = monoExp (env, st, fm) xml - in - ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), - loc)), loc), - (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</select>"), - loc)), loc)), - loc), - fm) - end - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to lselect tag")) - - | "ctextbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "inp(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], + (case tag of + "body" => let + val onload = execify onload + val onunload = execify onunload + in + normal ("body", + SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", + [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", + [(L'.ERecord [], loc)]), loc), + onload), loc)]), + loc), + (L'.EFfiApp ("Basis", "maybe_onunload", + [onunload]), + loc)), loc), + SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + end + + | "dyn" => + let + fun inTag tag = case targs of + (L.CRecord (_, ctx), _) :: _ => + List.exists (fn ((L.CName tag', _), _) => tag' = tag + | _ => false) ctx + | _ => false + + val tag = if inTag "Tr" then + "tr" + else if inTag "Table" then + "table" + else + "span" + in + case attrs of + [("Signal", e, _)] => + ((L'.EStrcat + ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" + ^ tag ^ "\", execD(")), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), fm) - end) + | _ => raise Fail "Monoize: Bad dyn attributes" + end + + | "submit" => normal ("input type=\"submit\"", NONE, NONE) + | "button" => normal ("input type=\"submit\"", NONE, NONE) + | "hidden" => input "hidden" + + | "textbox" => + (case targs of + [_, (L.CName name, _)] => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")), + loc)), loc), fm) + end + | SOME (_, src, _) => + (strcat [str "<script type=\"text/javascript\">inp(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))</script>"], + fm)) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to textbox tag")) + | "password" => input "password" + | "textarea" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "textarea" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</textarea>"), + loc)), loc)), + loc), fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to ltextarea tag")) + + | "checkbox" => input "checkbox" + | "upload" => input "file" + + | "radio" => + (case targs of + [_, (L.CName name, _)] => + monoExp (env, St.setRadioGroup (st, name), fm) xml + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to radio tag")) + | "radioOption" => + (case St.radioGroup st of + NONE => raise Fail "No name for radioGroup" + | SOME name => + normal ("input", + SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), + NONE)) + + | "select" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "select" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), + loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</select>"), + loc)), loc)), + loc), + fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to lselect tag")) + + | "ctextbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String " />"), loc)), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "inp(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) - | "ccheckbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input type=\"checkbox\"" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "chk(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) + | "ccheckbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input type=\"checkbox\"" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String " />"), loc)), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "chk(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) - | "cselect" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (xml, fm) = monoExp (env, st, fm) xml - val (ts, fm) = tagStart "select" - in - (strcat [ts, - str ">", - xml, - str "</select>"], - fm) - end - | SOME (_, src, _) => - let - val (xml, fm) = monoExp (env, st, fm) xml - - val sc = strcat [str "sel(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "),exec(", - (L'.EJavaScript (L'.Script, xml), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) + | "cselect" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (xml, fm) = monoExp (env, st, fm) xml + val (ts, fm) = tagStart "select" + in + (strcat [ts, + str ">", + xml, + str "</select>"], + fm) + end + | SOME (_, src, _) => + let + val (xml, fm) = monoExp (env, st, fm) xml + + val sc = strcat [str "sel(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "),exec(", + (L'.EJavaScript (L'.Script, xml), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) - | "coption" => normal ("option", NONE, NONE) + | "coption" => normal ("option", NONE, NONE) - | "tabl" => normal ("table", NONE, NONE) - | _ => normal (tag, NONE, NONE) + | "tabl" => normal ("table", NONE, NONE) + | _ => normal (tag, NONE, NONE)) + before inTag := inT end | L.EApp ((L.ECApp ( @@ -3121,6 +3133,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = t = t}, loc)), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) => + let + val t = monoType env t + val un = (L'.TRecord [], loc) + in + ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), + (L'.EAbs ("_", un, t, + (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc), + fm) + end | L.EApp (e1, e2) => let @@ -3198,9 +3220,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) - fm es + fm es + val e = (L'.EClosure (n, es), loc) in - ((L'.EClosure (n, es), loc), fm) + if !inTag then + (e, fm) + else + urlifyExp env fm (e, dummyTyp) end | L.ELet (x, t, e1, e2) => diff --git a/src/prepare.sml b/src/prepare.sml index e7afc77f..58344a1f 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -202,6 +202,13 @@ fun prepExp (e as (_, loc), st) = ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) end + | ERedirect (e, t) => + let + val (e, st) = prepExp (e, st) + in + ((ERedirect (e, t), loc), st) + end + | EWrite e => let val (e, st) = prepExp (e, st) diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index c4623fc3..6dc11c65 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -106,6 +106,7 @@ fun classify (ds, ps) = | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes | EError (e, _) => hasClient e | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2 + | ERedirect (e, _) => hasClient e | EWrite e => hasClient e | ESeq (e1, e2) => hasClient e1 orelse hasClient e2 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2 diff --git a/src/tag.sml b/src/tag.sml index b4574b79..9510d360 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -46,115 +46,148 @@ fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a "Make sure that the signature of the containing module hides any form handlers.\n")) fun exp env (e, s) = - case e of - EApp ( - (EApp ( - (EApp ( - (EApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), _), absent), _), outer), _), inner), _), - useOuter), _), useInner), _), bindOuter), _), bindInner), _), - class), _), - attrs), _), - tag), _), - xml) => - (case attrs of - (ERecord xets, _) => - let - val (xets, s) = - ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => - let - fun tagIt (ek, newAttr) = - let - val eOrig = e + let + fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) = + let + val loc = #2 e + + val eOrig = e - fun unravel (e, _) = - case e of - ENamed n => (n, []) - | EApp (e1, e2) => - let - val (n, es) = unravel e1 - in - (n, es @ [e2]) - end - | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr - ^ " expression"); - Print.epreface ("Expression", - CorePrint.p_exp CoreEnv.empty eOrig); - (0, [])) + fun unravel (e, _) = + case e of + ENamed n => (n, []) + | EApp (e1, e2) => + let + val (n, es) = unravel e1 + in + (n, es @ [e2]) + end + | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr + ^ " expression"); + Print.epreface ("Expression", + CorePrint.p_exp CoreEnv.empty eOrig); + (0, [])) - val (f, args) = unravel e + val (f, args) = unravel e - val (cn, count, tags, newTags) = - case IM.find (tags, f) of - NONE => - (count, count + 1, IM.insert (tags, f, count), - (ek, f, count) :: newTags) - | SOME cn => (cn, count, tags, newTags) - - val (_, _, _, s) = E.lookupENamed env f + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (ek, f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val (_, _, _, s) = E.lookupENamed env f - val byTag = case SM.find (byTag, s) of - NONE => SM.insert (byTag, s, (ek, f)) - | SOME (ek', f') => - (if f = f' then - () - else - ErrorMsg.errorAt loc - ("Duplicate HTTP tag " - ^ s); - if ek = ek' then - () - else - both (loc, s); - byTag) + val byTag = case SM.find (byTag, s) of + NONE => SM.insert (byTag, s, (ek, f)) + | SOME (ek', f') => + (if f = f' then + () + else + ErrorMsg.errorAt loc + ("Duplicate HTTP tag " + ^ s); + if ek = ek' then + () + else + both (loc, s); + byTag) - val e = (EClosure (cn, args), loc) - val t = (CFfi ("Basis", "string"), loc) - in - (((CName newAttr, loc), e, t), - (count, tags, byTag, newTags)) - end - in - case x of - (CName "Link", _) => tagIt (Link, "Link") - | (CName "Action", _) => tagIt (Action ReadWrite, "Action") - | _ => ((x, e, t), (count, tags, byTag, newTags)) - end) - s xets - in - (EApp ( - (EApp ( - (EApp ( - (EApp ( + val e = (EClosure (cn, args), loc) + in + (e, (count, tags, byTag, newTags)) + end + in + case e of + EApp ( + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( (ECApp ( (ECApp ( - (ECApp ( - (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + useOuter), _), useInner), _), bindOuter), _), bindInner), _), + class), _), + attrs), _), + tag), _), + xml) => + (case attrs of + (ERecord xets, _) => + let + val (xets, s) = + ListUtil.foldlMap (fn ((x, e, t), s) => + let + fun tagIt' (ek, newAttr) = + let + val (e', s) = tagIt (e, ek, newAttr, s) + val t = (CFfi ("Basis", "string"), loc) + in + (((CName newAttr, loc), e', t), s) + end + in + case x of + (CName "Link", _) => tagIt' (Link, "Link") + | (CName "Action", _) => tagIt' (Action ReadWrite, "Action") + | _ => ((x, e, t), s) + end) + s xets + in + (EApp ( + (EApp ( + (EApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), loc), absent), loc), outer), loc), inner), loc), - useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), - class), loc), - (ERecord xets, loc)), loc), - tag), loc), - xml), s) - end - | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; - (e, s))) + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + class), loc), + (ERecord xets, loc)), loc), + tag), loc), + xml), s) + end + | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; + (e, s))) + + | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s) - | _ => (e, s) + | EFfiApp ("Basis", "url", [e]) => + let + val (e, s) = tagIt (e, Link, "Url", s) + in + (#1 e, s) + end + + | EApp ((ENamed n, _), e') => + let + val (_, _, eo, _) = E.lookupENamed env n + in + case eo of + SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) => + let + val (e, s) = tagIt (e', Link, "Url", s) + in + (#1 e, s) + end + | _ => (e, s) + end + + | _ => (e, s) + end fun decl (d, s) = (d, s) diff --git a/tests/makeUrl.ur b/tests/makeUrl.ur new file mode 100644 index 00000000..12026dab --- /dev/null +++ b/tests/makeUrl.ur @@ -0,0 +1,3 @@ +fun other () = return <xml>Hi!</xml> + +fun main () = return <xml>{[Basis.url (main ())]}, {[url (other ())]}</xml> diff --git a/tests/makeUrl.urp b/tests/makeUrl.urp new file mode 100644 index 00000000..83451c4c --- /dev/null +++ b/tests/makeUrl.urp @@ -0,0 +1,3 @@ +debug + +makeUrl diff --git a/tests/makeUrl.urs b/tests/makeUrl.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/makeUrl.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/redirect.ur b/tests/redirect.ur new file mode 100644 index 00000000..da5114ca --- /dev/null +++ b/tests/redirect.ur @@ -0,0 +1,15 @@ +fun other () = redirect (bless "http://www.google.com/") + +fun further () = case checkUrl "http://www.google.com/" of + None => return <xml>Darn.</xml> + | Some url => redirect url + +fun failing () = case checkUrl "http://www.yahoo.com/" of + None => return <xml>Darn.</xml> + | Some url => redirect url + +fun main () = return <xml><body> + <a link={other ()}>Go there</a><br/> + <a link={further ()}>Go also there</a><br/> + <a link={failing ()}>Fail there</a> +</body></xml> diff --git a/tests/redirect.urp b/tests/redirect.urp new file mode 100644 index 00000000..670d3212 --- /dev/null +++ b/tests/redirect.urp @@ -0,0 +1,4 @@ +debug +allow url http://www.google.com/ + +redirect diff --git a/tests/redirect.urs b/tests/redirect.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/redirect.urs @@ -0,0 +1 @@ +val main : unit -> transaction page |