Mercurial > urweb
changeset 741:f7e2026dd5ae
Returning a blob as page result
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 26 Apr 2009 09:02:17 -0400 |
| parents | b302b6e35f93 |
| children | 43553c93dd8c |
| files | include/types.h include/urweb.h lib/ur/basis.urs src/c/driver.c src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_opt.sig src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/scriptcheck.sml tests/echoBlob.ur tests/echoBlob.urp tests/echoBlob.urs |
| diffstat | 21 files changed, 144 insertions(+), 5 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Sat Apr 25 14:47:16 2009 -0400 +++ b/include/types.h Sun Apr 26 09:02:17 2009 -0400 @@ -33,7 +33,7 @@ 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
--- a/include/urweb.h Sat Apr 25 14:47:16 2009 -0400 +++ b/include/urweb.h Sun Apr 26 09:02:17 2009 -0400 @@ -157,6 +157,7 @@ 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_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);
--- a/lib/ur/basis.urs Sat Apr 25 14:47:16 2009 -0400 +++ b/lib/ur/basis.urs Sun Apr 26 09:02:17 2009 -0400 @@ -521,6 +521,10 @@ 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 [] [] []
--- a/src/c/driver.c Sat Apr 25 14:47:16 2009 -0400 +++ b/src/c/driver.c Sun Apr 26 09:02:17 2009 -0400 @@ -194,7 +194,7 @@ 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 @@ 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) {
--- a/src/c/urweb.c Sat Apr 25 14:47:16 2009 -0400 +++ b/src/c/urweb.c Sun Apr 26 09:02:17 2009 -0400 @@ -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 @@ 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_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); +}
--- a/src/cjr.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/cjr.sml Sun Apr 26 09:02:17 2009 -0400 @@ -75,6 +75,7 @@ | 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
--- a/src/cjr_print.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/cjr_print.sml Sun Apr 26 09:02:17 2009 -0400 @@ -1276,8 +1276,26 @@ 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,
--- a/src/cjrize.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/cjrize.sml Sun Apr 26 09:02:17 2009 -0400 @@ -319,6 +319,14 @@ 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
--- a/src/jscomp.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/jscomp.sml Sun Apr 26 09:02:17 2009 -0400 @@ -101,6 +101,7 @@ (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 @@ 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 @@ | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" + | EReturnBlob _ => unsupported "EUnurlify" | EJavaScript (_, e, _) => let val (e, st) = jsE inner (e, st)
--- a/src/mono.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono.sml Sun Apr 26 09:02:17 2009 -0400 @@ -88,6 +88,7 @@ | EStrcat of exp * exp | EError of exp * typ + | EReturnBlob of {blob : exp, mimeType : exp, t : typ} | EWrite of exp | ESeq of exp * exp
--- a/src/mono_opt.sig Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono_opt.sig Sun Apr 26 09:02:17 2009 -0400 @@ -31,5 +31,6 @@ val optExp : Mono.exp -> Mono.exp val bless : (string -> bool) ref + val blessMime : (string -> bool) ref end
--- a/src/mono_opt.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono_opt.sml Sun Apr 26 09:02:17 2009 -0400 @@ -31,6 +31,7 @@ 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 @@ 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
--- a/src/mono_print.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono_print.sml Sun Apr 26 09:02:17 2009 -0400 @@ -211,6 +211,18 @@ 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,
--- a/src/mono_reduce.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono_reduce.sml Sun Apr 26 09:02:17 2009 -0400 @@ -79,6 +79,7 @@ | 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 @@ | 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]
--- a/src/mono_util.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/mono_util.sml Sun Apr 26 09:02:17 2009 -0400 @@ -247,7 +247,15 @@ 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' =>
--- a/src/monoize.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/monoize.sml Sun Apr 26 09:02:17 2009 -0400 @@ -128,6 +128,7 @@ 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 @@ (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
--- a/src/prepare.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/prepare.sml Sun Apr 26 09:02:17 2009 -0400 @@ -156,6 +156,14 @@ ((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)
--- a/src/scriptcheck.sml Sat Apr 25 14:47:16 2009 -0400 +++ b/src/scriptcheck.sml Sun Apr 26 09:02:17 2009 -0400 @@ -86,6 +86,7 @@ | 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/echoBlob.ur Sun Apr 26 09:02:17 2009 -0400 @@ -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>