summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c139
-rw-r--r--src/cjr_print.sml173
-rw-r--r--src/monoize.sml15
-rw-r--r--src/urweb.grm11
4 files changed, 266 insertions, 72 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 1d6b804f..fc8b82c9 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -284,14 +284,17 @@ typedef struct {
} delta;
typedef enum {
- UNSET, NORMAL, FIL
+ UNSET, NORMAL, FIL, SUBFORM
} input_kind;
-typedef struct {
+typedef struct input {
input_kind kind;
union {
char *normal;
uw_Basis_file file;
+ struct {
+ struct input *fields, *prev;
+ } subform;
} data;
} input;
@@ -299,7 +302,8 @@ struct uw_context {
char *headers, *headers_end;
buf outHeaders, page, heap, script;
- input *inputs;
+ input *inputs, *subinputs, *cur_inputs;
+ size_t n_subinputs, used_subinputs;
int source_count;
@@ -339,6 +343,9 @@ uw_context uw_init() {
ctx->script.start[0] = 0;
ctx->inputs = calloc(uw_inputs_len, sizeof(input));
+ ctx->cur_inputs = NULL;
+ ctx->subinputs = malloc(0);
+ ctx->n_subinputs = ctx->used_subinputs = 0;
ctx->db = NULL;
@@ -383,6 +390,7 @@ void uw_free(uw_context ctx) {
buf_free(&ctx->page);
buf_free(&ctx->heap);
free(ctx->inputs);
+ free(ctx->subinputs);
free(ctx->cleanup);
for (i = 0; i < ctx->n_deltas; ++i)
@@ -392,6 +400,8 @@ void uw_free(uw_context ctx) {
}
void uw_reset_keep_error_message(uw_context ctx) {
+ size_t i;
+
buf_reset(&ctx->outHeaders);
buf_reset(&ctx->script);
ctx->script.start[0] = 0;
@@ -412,6 +422,9 @@ void uw_reset_keep_request(uw_context ctx) {
void uw_reset(uw_context ctx) {
uw_reset_keep_request(ctx);
memset(ctx->inputs, 0, uw_inputs_len * sizeof(input));
+ memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input));
+ ctx->cur_inputs = NULL;
+ ctx->used_subinputs = 0;
}
void uw_db_init(uw_context);
@@ -564,17 +577,72 @@ char *uw_error_message(uw_context ctx) {
extern int uw_input_num(const char*);
+#define INP(ctx) (ctx->cur_inputs ? ctx->cur_inputs : ctx->inputs)
+
void uw_set_input(uw_context ctx, const char *name, char *value) {
- int n = uw_input_num(name);
+ if (!strcasecmp(name, ".b")) {
+ size_t i;
+ int n = uw_input_num(value);
+ input *inps;
- if (n < 0)
- uw_error(ctx, FATAL, "Bad input name %s", name);
+ if (n < 0)
+ uw_error(ctx, FATAL, "Bad subform name %s", value);
- if (n >= uw_inputs_len)
- uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n);
+ if (n >= uw_inputs_len)
+ uw_error(ctx, FATAL, "For subform name %s, index %d is out of range", value, n);
+
+ if (ctx->used_subinputs + uw_inputs_len >= ctx->n_subinputs) {
+ input *new_subinputs = realloc(ctx->subinputs, sizeof(input) * (ctx->used_subinputs + uw_inputs_len));
+ size_t offset = new_subinputs - ctx->subinputs;
+
+ for (i = 0; i < ctx->used_subinputs; ++i)
+ if (new_subinputs[i].kind == SUBFORM) {
+ new_subinputs[i].data.subform.fields += offset;
+ if (new_subinputs[i].data.subform.prev != NULL)
+ new_subinputs[i].data.subform.prev += offset;
+ }
+
+ for (i = 0; i < uw_inputs_len; ++i)
+ if (ctx->inputs[i].kind == SUBFORM) {
+ ctx->inputs[i].data.subform.fields += offset;
+ if (ctx->inputs[i].data.subform.prev != NULL)
+ ctx->inputs[i].data.subform.prev += offset;
+ }
+
+ if (ctx->cur_inputs != NULL)
+ ctx->cur_inputs += offset;
+
+ ctx->n_subinputs = ctx->used_subinputs + uw_inputs_len;
+ ctx->subinputs = new_subinputs;
+ }
+
+ ctx->inputs[n].kind = SUBFORM;
+ ctx->inputs[n].data.subform.prev = ctx->cur_inputs;
+ ctx->cur_inputs = ctx->inputs[n].data.subform.fields = &ctx->subinputs[ctx->used_subinputs];
+
+ for (i = 0; i < uw_inputs_len; ++i)
+ ctx->subinputs[ctx->used_subinputs++].kind = UNUSED;
+ } else if (!strcasecmp(name, ".e")) {
+ input *tmp;
+
+ if (ctx->cur_inputs == NULL)
+ uw_error(ctx, FATAL, "Unmatched subform closer");
+
+ tmp = ctx->cur_inputs;
+ ctx->cur_inputs = tmp->data.subform.prev;
+ tmp->data.subform.prev = NULL;
+ } else {
+ int n = uw_input_num(name);
- ctx->inputs[n].kind = NORMAL;
- ctx->inputs[n].data.normal = value;
+ if (n < 0)
+ uw_error(ctx, FATAL, "Bad input name %s", name);
+
+ if (n >= uw_inputs_len)
+ uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n);
+
+ INP(ctx)[n].kind = NORMAL;
+ INP(ctx)[n].data.normal = value;
+ }
}
char *uw_get_input(uw_context ctx, int n) {
@@ -583,13 +651,15 @@ char *uw_get_input(uw_context ctx, int n) {
if (n >= uw_inputs_len)
uw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
- switch (ctx->inputs[n].kind) {
+ switch (INP(ctx)[n].kind) {
case UNSET:
return NULL;
case FIL:
uw_error(ctx, FATAL, "Tried to read a file form input as normal");
+ case SUBFORM:
+ uw_error(ctx, FATAL, "Tried to read a subform form input as normal");
case NORMAL:
- return ctx->inputs[n].data.normal;
+ return INP(ctx)[n].data.normal;
default:
uw_error(ctx, FATAL, "Impossible input kind");
}
@@ -601,13 +671,15 @@ char *uw_get_optional_input(uw_context ctx, int n) {
if (n >= uw_inputs_len)
uw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
- switch (ctx->inputs[n].kind) {
+ switch (INP(ctx)[n].kind) {
case UNSET:
return "";
case FIL:
uw_error(ctx, FATAL, "Tried to read a file form input as normal");
+ case SUBFORM:
+ uw_error(ctx, FATAL, "Tried to read a subform form input as normal");
case NORMAL:
- return ctx->inputs[n].data.normal;
+ return INP(ctx)[n].data.normal;
default:
uw_error(ctx, FATAL, "Impossible input kind");
}
@@ -634,7 +706,7 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) {
if (n >= uw_inputs_len)
uw_error(ctx, FATAL, "Out-of-bounds file input index %d", n);
- switch (ctx->inputs[n].kind) {
+ switch (INP(ctx)[n].kind) {
case UNSET:
{
char *data = uw_malloc(ctx, 0);
@@ -642,14 +714,49 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) {
return f;
}
case FIL:
- return ctx->inputs[n].data.file;
+ return INP(ctx)[n].data.file;
case NORMAL:
uw_error(ctx, FATAL, "Tried to read a normal form input as files");
+ case SUBFORM:
+ uw_error(ctx, FATAL, "Tried to read a subform form input as files");
+ default:
+ uw_error(ctx, FATAL, "Impossible input kind");
+ }
+}
+
+void uw_enter_subform(uw_context ctx, int n) {
+ if (n < 0)
+ uw_error(ctx, FATAL, "Negative subform index %d", n);
+ if (n >= uw_inputs_len)
+ uw_error(ctx, FATAL, "Out-of-bounds subform index %d", n);
+
+ switch (INP(ctx)[n].kind) {
+ case UNSET:
+ uw_error(ctx, FATAL, "Missing subform");
+ case FIL:
+ uw_error(ctx, FATAL, "Tried to read a file form input as subform");
+ case NORMAL:
+ uw_error(ctx, FATAL, "Tried to read a normal form input as subform");
+ case SUBFORM:
+ INP(ctx)[n].data.subform.prev = ctx->cur_inputs;
+ ctx->cur_inputs = INP(ctx)[n].data.subform.fields;
+ return;
default:
uw_error(ctx, FATAL, "Impossible input kind");
}
}
+void uw_leave_subform(uw_context ctx) {
+ input *tmp;
+
+ if (ctx->cur_inputs == NULL)
+ uw_error(ctx, FATAL, "Unmatched uw_leave_subform");
+
+ tmp = ctx->cur_inputs;
+ ctx->cur_inputs = tmp->data.subform.prev;
+ tmp->data.subform.prev = NULL;
+}
+
void uw_set_script_header(uw_context ctx, const char *s) {
ctx->script_header = s;
}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a09dd7f6..7928ec5e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2340,31 +2340,50 @@ fun p_file env (ds, ps) =
E.declBinds env d))
env ds
+ fun flatFields (t : typ) =
+ case #1 t of
+ TRecord i =>
+ let
+ val xts = E.lookupStruct env i
+ in
+ SOME (map #1 xts :: List.concat (List.mapPartial (flatFields o #2) xts))
+ end
+ | _ => NONE
+
val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
case ek of
Link => fields
| Rpc _ => fields
| Action eff =>
case List.nth (ts, length ts - 2) of
- (TRecord i, _) =>
+ (TRecord i, loc) =>
let
val xts = E.lookupStruct env i
val xts = case eff of
ReadCookieWrite =>
(sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
| _ => xts
- val xtsSet = SS.addList (SS.empty, map #1 xts)
in
- foldl (fn ((x, _), fields) =>
- let
- val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
- in
- SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
- xtsSet'))
- end) fields xts
+ case flatFields (TRecord i, loc) of
+ NONE => raise Fail "CjrPrint: flatFields impossible"
+ | SOME fields' => List.revAppend (fields', fields)
end
| _ => raise Fail "CjrPrint: Last argument of action isn't record")
- SM.empty ps
+ [] ps
+
+ val fields = foldl (fn (xts, fields) =>
+ let
+ val xtsSet = SS.addList (SS.empty, xts)
+ in
+ foldl (fn (x, fields) =>
+ let
+ val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
+ in
+ SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
+ xtsSet'))
+ end) fields xts
+ end)
+ SM.empty fields
val fnums = SM.foldli (fn (x, xs, fnums) =>
let
@@ -2467,6 +2486,97 @@ fun p_file env (ds, ps) =
string "}"]
end
+ fun getInput (x, t) =
+ let
+ val n = case SM.find (fnums, x) of
+ NONE => raise Fail "CjrPrint: Can't find in fnums"
+ | SOME n => n
+
+ val f = case t of
+ (TFfi ("Basis", "bool"), _) => "optional_"
+ | _ => ""
+ in
+ if isFile t then
+ box [string "uw_input_",
+ p_ident x,
+ space,
+ string "=",
+ space,
+ string "uw_get_file_input(ctx, ",
+ string (Int.toString n),
+ string ");",
+ newline]
+ else case #1 t of
+ TRecord i =>
+ let
+ val xts = E.lookupStruct env i
+ in
+ box [string "uw_enter_subform(ctx, ",
+ string (Int.toString n),
+ string ");",
+ newline,
+ string "uw_input_",
+ p_ident x,
+ space,
+ string "=",
+ space,
+ string "({",
+ box [p_typ env t,
+ space,
+ string "result;",
+ newline,
+ p_list_sep (box [])
+ (fn (x, t) =>
+ box [p_typ env t,
+ space,
+ string "uw_input_",
+ string x,
+ string ";",
+ newline])
+ xts,
+ newline,
+ p_list_sep (box []) (fn (x, t) =>
+ box [getInput (x, t),
+ string "result.__uwf_",
+ string x,
+ space,
+ string "=",
+ space,
+ string "uw_input_",
+ string x,
+ string ";",
+ newline])
+ xts,
+ newline,
+ string "result;",
+ newline],
+ string "});",
+ newline,
+ string "uw_leave_subform(ctx);"]
+ end
+ | _ =>
+ box [string "request = uw_get_",
+ string f,
+ string "input(ctx, ",
+ string (Int.toString n),
+ string ");",
+ newline,
+ string "if (request == NULL)",
+ newline,
+ box [string "uw_error(ctx, FATAL, \"Missing input ",
+ string x,
+ string "\");"],
+ newline,
+ string "uw_input_",
+ p_ident x,
+ space,
+ string "=",
+ space,
+ unurlify env t,
+ string ";",
+ newline]
+ end
+
fun p_page (ek, s, n, ts, ran, side) =
let
val (ts, defInputs, inputsVar, fields) =
@@ -2487,48 +2597,7 @@ fun p_file env (ds, ps) =
string ";",
newline]) xts),
newline,
- box (map (fn (x, t) =>
- let
- val n = case SM.find (fnums, x) of
- NONE => raise Fail "CjrPrint: Can't find in fnums"
- | SOME n => n
-
- val f = case t of
- (TFfi ("Basis", "bool"), _) => "optional_"
- | _ => ""
- in
- if isFile t then
- box [string "uw_input_",
- p_ident x,
- space,
- string "=",
- space,
- string "uw_get_file_input(ctx, ",
- string (Int.toString n),
- string ");",
- newline]
- else
- box [string "request = uw_get_",
- string f,
- string "input(ctx, ",
- string (Int.toString n),
- string ");",
- newline,
- string "if (request == NULL)",
- newline,
- box [string "uw_error(ctx, FATAL, \"Missing input ",
- string x,
- string "\");"],
- newline,
- string "uw_input_",
- p_ident x,
- space,
- string "=",
- space,
- unurlify env t,
- string ";",
- newline]
- end) xts),
+ box (map getInput xts),
string "struct __uws_",
string (Int.toString i),
space,
diff --git a/src/monoize.sml b/src/monoize.sml
index a2048a7d..ea191802 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2686,6 +2686,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
+ (L.EFfi ("Basis", "subform"), _), _), _), _),
+ _), _), _), (L.CName nm, loc)) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("xml", s, s,
+ strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
+ ^ nm ^ "\">")), loc),
+ (L'.ERel 0, loc),
+ (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
+ loc),
+ fm)
+ end
+
| L.EApp ((L.ECApp (
(L.ECApp (
(L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index da817ab3..55a38c57 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -280,7 +280,7 @@ datatype attr = Class of exp | Normal of con * exp
| rexp of (con * exp) list
| xml of exp
| xmlOne of exp
- | tag of string * exp
+ | tag of (string * exp) * exp
| tagHead of string * exp
| bind of string * con option * exp
| edecl of edecl
@@ -1240,7 +1240,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
val pos = s (tagleft, GTright)
val cdata =
- if #1 tag = "submit" orelse #1 tag = "dyn" then
+ if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then
let
val e = (EVar (["Basis"], "cdata", DontInfer), pos)
val e = (ECApp (e, (CWild (KWild, pos), pos)), pos)
@@ -1261,10 +1261,13 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
val pos = s (tagleft, GTright)
val et = tagIn END_TAG
in
- if #1 tag = et then
+ if #1 (#1 tag) = et then
if et = "form" then
(EApp ((EVar (["Basis"], "form", Infer), pos),
xml), pos)
+ else if et = "subform" then
+ (EApp ((EDisjointApp (#2 (#1 tag)), pos),
+ xml), pos)
else
(EApp (#2 tag, xml), pos)
else
@@ -1295,7 +1298,7 @@ tag : tagHead attrs (let
val e = (EApp (e, (EApp (#2 tagHead,
(ERecord [], pos)), pos)), pos)
in
- (#1 tagHead, e)
+ (tagHead, e)
end)
tagHead: BEGIN_TAG (let
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 20:08:59 +0000