Returning a blob as page result

21 files changed, 144 insertions, 5 deletions

diff --git a/include/types.h b/include/types.h
index 90a9f524..71a5ee0f 100644
--- a/include/types.h
+++ b/include/types.h
@@ -33,7 +33,7 @@ typedef struct uw_Basis_file {
   uw_Basis_blob data;
 } uw_Basis_file;
 
-typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY } failure_kind;
+typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_BLOB } failure_kind;
 
 
 #define INTS_MAX 50
diff --git a/include/urweb.h b/include/urweb.h
index cba746d4..4df7caef 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -157,6 +157,7 @@ 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);
+uw_Basis_string uw_Basis_blessMime(uw_context, uw_Basis_string);
 
 uw_Basis_string uw_unnull(uw_Basis_string);
 uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string);
@@ -166,3 +167,4 @@ uw_Basis_string uw_Basis_fileName(uw_context, uw_Basis_file);
 uw_Basis_string uw_Basis_fileMimeType(uw_context, uw_Basis_file);
 uw_Basis_blob uw_Basis_fileData(uw_context, uw_Basis_file);
 
+__attribute__((noreturn)) void uw_return_blob(uw_context, uw_Basis_blob, uw_Basis_string mimeType);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1068ddb9..6e22ece3 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -521,6 +521,10 @@ val fileData : file -> blob
 
 val upload : formTag file [] [Value = string, Size = int]
 
+type mimeType
+val blessMime : string -> mimeType
+val returnBlob : t ::: Type -> blob -> mimeType -> transaction t
+
 con radio = [Body, Radio]
 val radio : formTag string radio []
 val radioOption : unit -> tag [Value = string] radio [] [] []
diff --git a/src/c/driver.c b/src/c/driver.c
index c95f8886..63a7d224 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -194,7 +194,7 @@ static void *worker(void *data) {
 
       if (s = strstr(buf, "\r\n\r\n")) {
         failure_kind fk;
-        int is_post = 0;
+        int is_post = 0, do_normal_send = 1;
         char *boundary = NULL;
         size_t boundary_len;
         char *cmd, *path, *headers, path_copy[uw_bufsize+1], *inputs, *after_headers;
@@ -433,7 +433,7 @@ static void *worker(void *data) {
 
           strcpy(path_copy, path);
           fk = uw_begin(ctx, path_copy);
-          if (fk == SUCCESS) {
+          if (fk == SUCCESS || fk == RETURN_BLOB) {
             uw_commit(ctx);
             break;
           } else if (fk == BOUNDED_RETRY) {
diff --git a/src/c/urweb.c b/src/c/urweb.c
index ff4d5c8f..28364f2c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1,4 +1,4 @@
-#define _XOPEN_SOURCE
+#define _XOPEN_SOURCE 500
 
 #include <stdlib.h>
 #include <stdio.h>
@@ -8,6 +8,7 @@
 #include <setjmp.h>
 #include <stdarg.h>
 #include <assert.h>
+#include <ctype.h>
 
 #include <pthread.h>
 
@@ -2104,6 +2105,16 @@ uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
   return s;
 }
 
+uw_Basis_string uw_Basis_blessMime(uw_context ctx, uw_Basis_string s) {
+  char *s2;
+
+  for (s2 = s; *s2; ++s2)
+    if (!isalnum(*s2) && *s2 != '/' && *s2 != '-' && *s2 != '.')
+      uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character %c\n", s, *s2);
+  
+  return s;
+}
+
 uw_Basis_string uw_unnull(uw_Basis_string s) {
   return s ? s : "";
 }
@@ -2135,3 +2146,28 @@ uw_Basis_string uw_Basis_fileMimeType(uw_context ctx, uw_Basis_file f) {
 uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) {
   return f.data;
 }
+
+__attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, uw_Basis_string mimeType) {
+  cleanup *cl;
+  int len;
+
+  buf_reset(&ctx->outHeaders);
+  buf_reset(&ctx->page);
+
+  uw_write_header(ctx, "HTTP/1.1 200 OK\r\nContent-Type: ");
+  uw_write_header(ctx, mimeType);
+  uw_write_header(ctx, "\r\nContent-Length: ");
+  buf_check(&ctx->outHeaders, INTS_MAX);
+  sprintf(ctx->outHeaders.front, "%d%n", b.size, &len);
+  ctx->outHeaders.front += len;
+  uw_write_header(ctx, "\r\n");  
+
+  buf_append(&ctx->page, b.data, b.size);
+
+  for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
+    cl->func(cl->arg);
+
+  ctx->cleanup_front = ctx->cleanup;
+
+  longjmp(ctx->jmp_buf, RETURN_BLOB);
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 9d43f14a..559b7ada 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -75,6 +75,7 @@ datatype exp' =
        | ECase of exp * (pat * exp) list * { disc : typ, result : typ }
 
        | EError of exp * typ
+       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
 
        | EWrite of exp
        | ESeq of exp * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 07e3931f..3f7ec1e1 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1276,8 +1276,26 @@ fun p_exp' par env (e, loc) =
              string "tmp;",
              newline,
              string "})"]
+      | EReturnBlob {blob, mimeType, t} =>
+        box [string "({",
+             newline,
+             p_typ env t,
+             space,
+             string "tmp;",
+             newline,
+             string "uw_return_blob(ctx, ",
+             p_exp env blob,
+             string ", ",
+             p_exp env mimeType,
+             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), _) =>
+        p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
 
       | EFfiApp (m, x, es) => box [string "uw_",
                                    p_ident m,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 5e0f9bdb..ee2ecdb6 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -319,6 +319,14 @@ fun cifyExp (eAll as (e, loc), sm) =
         in
             ((L'.EError (e, t), loc), sm)
         end
+      | L.EReturnBlob {blob, mimeType, t} =>
+        let
+            val (blob, sm) = cifyExp (blob, sm)
+            val (mimeType, sm) = cifyExp (mimeType, sm)
+            val (t, sm) = cifyTyp (t, sm)
+        in
+            ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
+        end
 
       | L.EStrcat (e1, e2) =>
         let
diff --git a/src/jscomp.sml b/src/jscomp.sml
index e6da3d4b..0f545987 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -101,6 +101,7 @@ fun varDepth (e, _) =
         (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
       | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
       | EError (e, _) => varDepth e
+      | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2)
       | EWrite e => varDepth e
       | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
       | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
@@ -141,6 +142,7 @@ fun closedUpto d =
                 andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
               | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
               | EError (e, _) => cu inner e
+              | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2
               | EWrite e => cu inner e
               | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
               | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
@@ -915,6 +917,7 @@ fun process file =
                           | EDml _ => unsupported "DML"
                           | ENextval _ => unsupported "Nextval"
                           | EUnurlify _ => unsupported "EUnurlify"
+                          | EReturnBlob _ => unsupported "EUnurlify"
                           | EJavaScript (_, e, _) =>
                             let
                                 val (e, st) = jsE inner (e, st)
diff --git a/src/mono.sml b/src/mono.sml
index 94314774..e9d30181 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -88,6 +88,7 @@ datatype exp' =
        | EStrcat of exp * exp
 
        | EError of exp * typ
+       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
 
        | EWrite of exp
        | ESeq of exp * exp
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index b1652c71..905dc53b 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -31,5 +31,6 @@ signature MONO_OPT = sig
     val optExp : Mono.exp -> Mono.exp
 
     val bless : (string -> bool) ref
+    val blessMime : (string -> bool) ref
 
 end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 670774a2..19244e60 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -31,6 +31,7 @@ open Mono
 structure U = MonoUtil
 
 val bless = ref (fn _ : string => true)
+val blessMime = ref (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"-" orelse ch = #"/" orelse ch = #"."))
 
 fun typ t = t
 fun decl d = d
@@ -386,6 +387,12 @@ fun exp e =
          else
              ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
          se)
+      | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
+        (if !blessMime s then
+             ()
+         else
+             ErrorMsg.errorAt loc "Invalid string passed to 'blessMime'";
+         se)
 
       | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => 
         let
diff --git a/src/mono_print.sml b/src/mono_print.sml
index b01442e8..ffc1d4fe 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -211,6 +211,18 @@ fun p_exp' par env (e, _) =
                               space,
                               p_typ env t,
                               string ")"]
+      | EReturnBlob {blob, mimeType, t} => box [string "(blob",
+                                                space,
+                                                p_exp env blob,
+                                                space,
+                                                string "in",
+                                                space,
+                                                p_exp env mimeType,
+                                                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 c124a7b4..4eee1f79 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -79,6 +79,7 @@ fun impure (e, _) =
       | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
 
       | EError (e, _) => impure e
+      | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
 
       | EStrcat (e1, e2) => impure e1 orelse impure e2
 
@@ -349,6 +350,7 @@ fun reduce file =
                       | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
 
                       | EError (e, _) => summarize d e @ [Unsure]
+                      | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Unsure]
 
                       | EWrite e => summarize d e @ [WritePage]
                                     
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 017b86ca..dd848ba6 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -247,7 +247,15 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                             S.map2 (mft t,
                                     fn t' =>
                                        (EError (e', t'), loc)))
-
+              | EReturnBlob {blob, mimeType, t} =>
+                S.bind2 (mfe ctx blob,
+                         fn blob' =>
+                            S.bind2 (mfe ctx mimeType,
+                                  fn mimeType' =>
+                                     S.map2 (mft t,
+                                          fn t' =>
+                                             (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc))))
+                            
               | EStrcat (e1, e2) =>
                 S.bind2 (mfe ctx e1,
                       fn e1' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 8ccb84fc..90440807 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -128,6 +128,7 @@ fun monoType env =
                     readType (mt env dtmap t, loc)
 
                   | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "mimeType") => (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"), _), _), _), _) =>
@@ -2560,6 +2561,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
+            let
+                val t = monoType env t
+                val un = (L'.TRecord [], loc)
+            in
+                ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
+                           (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
+                           (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
+                                     (L'.EAbs ("_", un, t,
+                                               (L'.EReturnBlob {blob = (L'.ERel 2, loc),
+                                                                mimeType = (L'.ERel 1, loc),
+                                                                t = t}, loc)), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.EApp (e1, e2) =>
             let
diff --git a/src/prepare.sml b/src/prepare.sml
index 52308540..25306e89 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -156,6 +156,14 @@ fun prepExp (e as (_, loc), sns) =
             ((EError (e, t), loc), sns)
         end
 
+      | EReturnBlob {blob, mimeType, t} =>
+        let
+            val (blob, sns) = prepExp (blob, sns)
+            val (mimeType, sns) = prepExp (mimeType, sns)
+        in
+            ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sns)
+        end
+
       | EWrite e =>
         let
             val (e, sns) = prepExp (e, sns)
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 352ef46c..61676dc6 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -86,6 +86,7 @@ fun classify (ds, ps) =
                       | EField (e, _) => hasClient e
                       | 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
                       | EWrite e => hasClient e
                       | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
                       | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
diff --git a/tests/echoBlob.ur b/tests/echoBlob.ur
new file mode 100644
index 00000000..fc8f8603
--- /dev/null
+++ b/tests/echoBlob.ur
@@ -0,0 +1,8 @@
+fun echo r = returnBlob (fileData r.Data) (blessMime (fileMimeType r.Data))
+
+fun main () = return <xml><body>
+  <form>
+    <upload{#Data}/>
+    <submit action={echo}/>
+  </form>
+</body></xml>
diff --git a/tests/echoBlob.urp b/tests/echoBlob.urp
new file mode 100644
index 00000000..4b94b59c
--- /dev/null
+++ b/tests/echoBlob.urp
@@ -0,0 +1,3 @@
+debug
+
+echoBlob
diff --git a/tests/echoBlob.urs b/tests/echoBlob.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/echoBlob.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page