summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb/urweb_cpp.h2
-rw-r--r--src/c/urweb.c34
-rw-r--r--src/checknest.sml6
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml26
-rw-r--r--src/cjrize.sml11
-rw-r--r--src/iflow.sml9
-rw-r--r--src/jscomp.sml10
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml36
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/mono_util.sml13
-rw-r--r--src/monoize.sml20
-rw-r--r--src/prepare.sml9
14 files changed, 154 insertions, 32 deletions
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index fb3c83a2..d1fb4d37 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -209,6 +209,7 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string);
void uw_write_header(struct uw_context *, uw_Basis_string);
void uw_clear_headers(struct uw_context *);
+void uw_Basis_clear_page(struct uw_context *);
uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c);
uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure);
@@ -255,6 +256,7 @@ uw_Basis_postBody uw_getPostBody(struct uw_context *);
void uw_mayReturnIndirectly(struct uw_context *);
__attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType);
+__attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType);
__attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url);
uw_Basis_time uw_Basis_now(struct uw_context *);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cd724cbf..1201b09b 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1351,6 +1351,10 @@ void uw_clear_headers(uw_context ctx) {
uw_buffer_reset(&ctx->outHeaders);
}
+void uw_Basis_clear_page(uw_context ctx) {
+ uw_buffer_reset(&ctx->page);
+}
+
static void uw_check_script(uw_context ctx, size_t extra) {
ctx_uw_buffer_check(ctx, "script", &ctx->script, extra);
}
@@ -3736,6 +3740,36 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
}
+__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) {
+ cleanup *cl;
+ int len;
+ char *oldh;
+
+ if (!ctx->allowed_to_return_indirectly)
+ uw_error(ctx, FATAL, "Tried to return a blob from an RPC");
+
+ ctx->returning_indirectly = 1;
+ oldh = old_headers(ctx);
+ uw_buffer_reset(&ctx->outHeaders);
+
+ uw_write_header(ctx, on_success);
+ uw_write_header(ctx, "Content-Type: ");
+ uw_write_header(ctx, mimeType);
+ uw_write_header(ctx, "\r\nContent-Length: ");
+ ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
+ sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len);
+ ctx->outHeaders.front += len;
+ uw_write_header(ctx, "\r\n");
+ if (oldh) uw_write_header(ctx, oldh);
+
+ for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
+ cl->func(cl->arg);
+
+ ctx->cleanup_front = ctx->cleanup;
+
+ longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
+}
+
__attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) {
cleanup *cl;
char *s;
diff --git a/src/checknest.sml b/src/checknest.sml
index 05ad8e9a..fa418d89 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -56,7 +56,8 @@ fun expUses globals =
| ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
| EError (e, _) => eu e
- | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
+ | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
+ | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
| ERedirect (e, _) => eu e
| EWrite e => eu e
@@ -118,7 +119,8 @@ fun annotateExp globals =
| ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
| EError (e, t) => (EError (ae e, t), loc)
- | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc)
+ | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
+ | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
| ERedirect (e, t) => (ERedirect (ae e, t), loc)
| EWrite e => (EWrite (ae e), loc)
diff --git a/src/cjr.sml b/src/cjr.sml
index 3a37b26f..8cbabdcc 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -78,7 +78,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}
+ | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
| ERedirect of exp * typ
| EWrite of exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e98918e6..dec21eb3 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1628,7 +1628,7 @@ and p_exp' par tail env (e, loc) =
string "tmp;",
newline,
string "})"]
- | EReturnBlob {blob, mimeType, t} =>
+ | EReturnBlob {blob = SOME blob, mimeType, t} =>
box [string "({",
newline,
string "uw_Basis_blob",
@@ -1658,6 +1658,27 @@ and p_exp' par tail env (e, loc) =
string "tmp;",
newline,
string "})"]
+ | EReturnBlob {blob = NONE, mimeType, t} =>
+ box [string "({",
+ newline,
+ string "uw_Basis_string",
+ space,
+ string "mimeType",
+ space,
+ string "=",
+ space,
+ p_exp' false false env mimeType,
+ string ";",
+ newline,
+ p_typ env t,
+ space,
+ string "tmp;",
+ newline,
+ string "uw_return_blob_from_page(ctx, mimeType);",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
| ERedirect (e, t) =>
box [string "({",
newline,
@@ -3180,7 +3201,8 @@ fun p_file env (ds, ps) =
| EField (e, _) => expDb e
| ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
| EError (e, _) => expDb e
- | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
+ | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2
+ | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
| ERedirect (e, _) => expDb e
| EWrite e => expDb e
| ESeq (e1, e2) => expDb e1 orelse expDb e2
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 0f4bdb42..d153feff 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -372,13 +372,20 @@ fun cifyExp (eAll as (e, loc), sm) =
in
((L'.EError (e, t), loc), sm)
end
- | L.EReturnBlob {blob, mimeType, t} =>
+ | L.EReturnBlob {blob = NONE, mimeType, t} =>
+ let
+ val (mimeType, sm) = cifyExp (mimeType, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm)
+ end
+ | L.EReturnBlob {blob = SOME 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)
+ ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm)
end
| L.ERedirect (e, t) =>
let
diff --git a/src/iflow.sml b/src/iflow.sml
index 0c94cd47..461dc956 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1587,7 +1587,8 @@ fun evalExp env (e as (_, loc)) k =
evalExp env e2 (fn e2 =>
k (Func (Other "cat", [e1, e2]))))
| EError (e, _) => evalExp env e (fn e => St.send (e, loc))
- | EReturnBlob {blob = b, mimeType = m, ...} =>
+ | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization"
+ | EReturnBlob {blob = SOME b, mimeType = m, ...} =>
evalExp env b (fn b =>
(St.send (b, loc);
evalExp env m
@@ -2060,8 +2061,10 @@ fun check (file : file) =
end
| EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc)
| EError (e1, t) => (EError (doExp env e1, t), loc)
- | EReturnBlob {blob = b, mimeType = m, t} =>
- (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc)
+ | EReturnBlob {blob = NONE, mimeType = m, t} =>
+ (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc)
+ | EReturnBlob {blob = SOME b, mimeType = m, t} =>
+ (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc)
| ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc)
| EWrite e1 => (EWrite (doExp env e1), loc)
| ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
diff --git a/src/jscomp.sml b/src/jscomp.sml
index e0d87a8e..4a2c0365 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -1118,12 +1118,18 @@ fun process (file : file) =
in
((EError (e, t), loc), st)
end
- | EReturnBlob {blob, mimeType, t} =>
+ | EReturnBlob {blob = NONE, mimeType, t} =>
+ let
+ val (mimeType, st) = exp outer (mimeType, st)
+ in
+ ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st)
+ end
+ | EReturnBlob {blob = SOME blob, mimeType, t} =>
let
val (blob, st) = exp outer (blob, st)
val (mimeType, st) = exp outer (mimeType, st)
in
- ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
+ ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st)
end
| ERedirect (e, t) =>
let
diff --git a/src/mono.sml b/src/mono.sml
index f5260419..78740d70 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -93,7 +93,7 @@ datatype exp' =
| EStrcat of exp * exp
| EError of exp * typ
- | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
+ | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
| ERedirect of exp * typ
| EWrite of exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a5156aca..c81b362a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -235,18 +235,30 @@ 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 ")"]
+ | EReturnBlob {blob = SOME 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 ")"]
+ | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob",
+ space,
+ string "<page>",
+ space,
+ string "in",
+ space,
+ p_exp env mimeType,
+ space,
+ string ":",
+ space,
+ p_typ env t,
+ string ")"]
| ERedirect (e, t) => box [string "(redirect",
space,
p_exp env e,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0dfb7558..e96a0e8f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -101,7 +101,8 @@ fun impure (e, _) =
| ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
| EError _ => true
- | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
+ | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2
+ | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2
| ERedirect (e, _) => impure e
| EStrcat (e1, e2) => impure e1 orelse impure e2
@@ -492,7 +493,8 @@ fun reduce (file : file) =
| EStrcat (e1, e2) => summarize d e1 @ summarize d e2
| EError (e, _) => summarize d e @ [Abort]
- | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
+ | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
+ | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
| ERedirect (e, _) => summarize d e @ [Abort]
| EWrite e => summarize d e @ [WritePage]
diff --git a/src/mono_util.sml b/src/mono_util.sml
index cb871891..cc531625 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -261,14 +261,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EError (e', t'), loc)))
- | EReturnBlob {blob, mimeType, t} =>
+ | EReturnBlob {blob = NONE, mimeType, t} =>
+ S.bind2 (mfe ctx mimeType,
+ fn mimeType' =>
+ S.map2 (mft t,
+ fn t' =>
+ (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc)))
+ | EReturnBlob {blob = SOME 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))))
+ (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc))))
| ERedirect (e, t) =>
S.bind2 (mfe ctx e,
fn e' =>
@@ -495,7 +501,8 @@ fun appLoc f =
| ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
| EStrcat (e1, e2) => (appl e1; appl e2)
| EError (e1, _) => appl e1
- | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2)
+ | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2
+ | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2)
| ERedirect (e1, _) => appl e1
| EWrite e1 => appl e1
| ESeq (e1, e2) => (appl e1; appl e2)
diff --git a/src/monoize.sml b/src/monoize.sml
index 2b604325..b1166734 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4053,6 +4053,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EError ((L'.ERel 0, loc), t), loc)), loc),
fm)
end
+ | L.EApp (
+ (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
+ (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
+ let
+ val t = monoType env t
+ val un = (L'.TRecord [], loc)
+ val (e, fm) = monoExp (env, st, fm) e
+ in
+ ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
+ (L'.EAbs ("_", un, t,
+ (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
+ (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
+ (L'.EReturnBlob {blob = NONE,
+ mimeType = (L'.ERel 1, loc),
+ t = t}, loc)), loc)), loc)), loc)),
+ loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
let
val t = monoType env t
@@ -4062,7 +4080,7 @@ fun monoExp (env, st, fm) (all as (e, 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),
+ (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
mimeType = (L'.ERel 1, loc),
t = t}, loc)), loc)), loc)), loc),
fm)
diff --git a/src/prepare.sml b/src/prepare.sml
index 7f55959c..89cd1b43 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -201,7 +201,14 @@ fun prepExp (e as (_, loc), st) =
| EReturnBlob {blob, mimeType, t} =>
let
- val (blob, st) = prepExp (blob, st)
+ val (blob, st) = case blob of
+ NONE => (blob, st)
+ | SOME blob =>
+ let
+ val (b, st) = prepExp (blob, st)
+ in
+ (SOME b, st)
+ end
val (mimeType, st) = prepExp (mimeType, st)
in
((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-25 18:12:05 +0000