Basis.url and redirects

26 files changed, 496 insertions, 303 deletions

diff --git a/CHANGELOG b/CHANGELOG
index f4eb32ea..36267b96 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -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