summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/types.h2
-rw-r--r--include/urweb.h2
-rw-r--r--lib/ur/basis.urs4
-rw-r--r--src/c/driver.c4
-rw-r--r--src/c/urweb.c38
-rw-r--r--src/cjr.sml1
-rw-r--r--src/cjr_print.sml18
-rw-r--r--src/cjrize.sml8
-rw-r--r--src/jscomp.sml3
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_opt.sig1
-rw-r--r--src/mono_opt.sml7
-rw-r--r--src/mono_print.sml12
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml10
-rw-r--r--src/monoize.sml15
-rw-r--r--src/prepare.sml8
-rw-r--r--src/scriptcheck.sml1
-rw-r--r--tests/echoBlob.ur8
-rw-r--r--tests/echoBlob.urp3
-rw-r--r--tests/echoBlob.urs1
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 02:02:32 +0000