diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/c/request.c | 5 | ||||
-rw-r--r-- | src/c/urweb.c | 34 | ||||
-rw-r--r-- | src/cjr_print.sml | 107 | ||||
-rw-r--r-- | src/corify.sml | 10 | ||||
-rw-r--r-- | src/effectize.sml | 9 | ||||
-rw-r--r-- | src/elaborate.sml | 8 | ||||
-rw-r--r-- | src/export.sig | 1 | ||||
-rw-r--r-- | src/export.sml | 2 | ||||
-rw-r--r-- | src/marshalcheck.sml | 7 |
9 files changed, 125 insertions, 58 deletions
diff --git a/src/c/request.c b/src/c/request.c index bcfec5e9..e51f95ae 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -192,6 +192,9 @@ request_result uw_request(uw_request_context rc, uw_context ctx, boundary[0] = '-'; boundary[1] = '-'; boundary_len = strlen(boundary); + } else if (clen_s && strcasecmp(clen_s, "application/x-www-form-urlencoded")) { + uw_Basis_postBody pb = {clen_s, body}; + uw_postBody(ctx, pb); } } else if (strcmp(method, "GET")) { log_error(logger_data, "Not ready for non-GET/POST command: %s\n", method); @@ -325,7 +328,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx, } } } - else { + else if (!uw_hasPostBody(ctx)) { inputs = is_post ? body : query_string; if (inputs) { diff --git a/src/c/urweb.c b/src/c/urweb.c index 47c6dadf..2b54e87c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -445,6 +445,9 @@ struct uw_context { void *logger_data; uw_logger log_debug; + int hasPostBody; + uw_Basis_postBody postBody; + char error_message[ERROR_BUF_LEN]; }; @@ -507,6 +510,8 @@ uw_context uw_init(void *logger_data, uw_logger log_debug) { ctx->logger_data = logger_data; ctx->log_debug = log_debug; + ctx->hasPostBody = 0; + return ctx; } @@ -583,6 +588,7 @@ void uw_reset_keep_error_message(uw_context ctx) { ctx->cur_container = NULL; ctx->used_transactionals = 0; ctx->script_header = ""; + ctx->hasPostBody = 0; } void uw_reset_keep_request(uw_context ctx) { @@ -3200,6 +3206,14 @@ uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { return f.data; } +uw_Basis_string uw_Basis_postType(uw_context ctx, uw_Basis_postBody pb) { + return pb.type; +} + +uw_Basis_string uw_Basis_postData(uw_context ctx, uw_Basis_postBody pb) { + return pb.data; +} + __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, uw_Basis_string mimeType) { cleanup *cl; int len; @@ -3458,3 +3472,23 @@ uw_Basis_int uw_Basis_rand(uw_context ctx) { uw_Basis_int n = abs(rand()); return n; } + +void uw_noPostBody(uw_context ctx) { + ctx->hasPostBody = 0; +} + +void uw_postBody(uw_context ctx, uw_Basis_postBody pb) { + ctx->hasPostBody = 1; + ctx->postBody = pb; +} + +int uw_hasPostBody(uw_context ctx) { + return ctx->hasPostBody; +} + +uw_Basis_postBody uw_getPostBody(uw_context ctx) { + if (ctx->hasPostBody) + return ctx->postBody; + else + uw_error(ctx, FATAL, "Asked for POST body when none exists"); +} diff --git a/src/cjr_print.sml b/src/cjr_print.sml index df11737e..fbbbc548 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2246,22 +2246,21 @@ fun p_file env (ds, ps) = 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, loc) => - let - val xts = E.lookupStruct env i - val extra = case eff of - ReadCookieWrite => [sigName xts] - | _ => [] - in - case flatFields extra (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") + Action eff => + (case List.nth (ts, length ts - 2) of + (TRecord i, loc) => + let + val xts = E.lookupStruct env i + val extra = case eff of + ReadCookieWrite => [sigName xts] + | _ => [] + in + case flatFields extra (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") + | _ => fields) [] ps val fields = foldl (fn (xts, fields) => @@ -2544,49 +2543,49 @@ fun p_file env (ds, ps) = let val (ts, defInputs, inputsVar, fields) = case ek of - Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE) - | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "", NONE) - | Core.Action _ => - case List.nth (ts, length ts - 2) of - (TRecord i, _) => - let - val xts = E.lookupStruct env i - in - (List.take (ts, length ts - 2), - box [box (map (fn (x, t) => box [p_typ env t, - space, - string "uw_input_", - p_ident x, - string ";", - newline]) xts), - newline, - box (map getInput xts), - string "struct __uws_", - string (Int.toString i), - space, - string "uw_inputs", - space, - string "= {", - newline, - box (map (fn (x, _) => box [string "uw_input_", - p_ident x, - string ",", - newline]) xts), - string "};", - newline], - box [string ",", - space, - string "uw_inputs"], - SOME xts) - end + Core.Action _ => + (case List.nth (ts, length ts - 2) of + (TRecord i, _) => + let + val xts = E.lookupStruct env i + in + (List.take (ts, length ts - 2), + box [box (map (fn (x, t) => box [p_typ env t, + space, + string "uw_input_", + p_ident x, + string ";", + newline]) xts), + newline, + box (map getInput xts), + string "struct __uws_", + string (Int.toString i), + space, + string "uw_inputs", + space, + string "= {", + newline, + box (map (fn (x, _) => box [string "uw_input_", + p_ident x, + string ",", + newline]) xts), + string "};", + newline], + box [string ",", + space, + string "uw_inputs"], + SOME xts) + end - | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" + | _ => raise Fail "CjrPrint: Last argument to an action isn't a record") + | _ => (List.take (ts, length ts - 1), string "", string "", NONE) fun couldWrite ek = case ek of Link => false | Action ef => ef = ReadCookieWrite | Rpc ef => ef = ReadCookieWrite + | Extern ef => ef = ReadCookieWrite val s = case Settings.getUrlPrefix () of @@ -2693,7 +2692,9 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify false env t, + case #1 t of + TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)" + | _ => unurlify false env t, string ";", newline]) ts), defInputs, diff --git a/src/corify.sml b/src/corify.sml index c3a53094..075047a2 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1011,11 +1011,19 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = t, tf, e), loc), (L.TFun (t, tf), loc))) ((L.EApp (ef, ea), loc), ranT) args + + val expKind = if List.exists (fn t => + case corifyCon st t of + (L'.CFfi ("Basis", "postBody"), _) => true + | _ => false) args then + L'.Extern L'.ReadCookieWrite + else + L'.Link in ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds, (fn st => case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of - L'.ENamed n => (L'.DExport (L'.Link, n, false), loc) + L'.ENamed n => (L'.DExport (expKind, n, false), loc) | _ => raise Fail "Corify: Value to export didn't corify properly") :: eds) end diff --git a/src/effectize.sml b/src/effectize.sml index 7f148476..4601f301 100644 --- a/src/effectize.sml +++ b/src/effectize.sml @@ -168,6 +168,15 @@ fun effectize file = else ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs) + | DExport (Extern _, n, _) => + ((DExport (Extern (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), + evs) | _ => (d, evs) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file diff --git a/src/elaborate.sml b/src/elaborate.sml index 008529ea..b1515b6e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3834,8 +3834,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (L'.CModProj (basis, [], "transaction"), loc), t), loc) + + fun normArgs t = + case hnormCon env t of + (L'.TFun (dom, ran), loc) => + (L'.TFun (hnormCon env dom, normArgs ran), loc) + | t' => t' in - (L'.SgiVal (x, n, makeRes t), loc) + (L'.SgiVal (x, n, normArgs (makeRes t)), loc) end | _ => all) | _ => all) diff --git a/src/export.sig b/src/export.sig index 0bbdd1ac..9bcfa0d4 100644 --- a/src/export.sig +++ b/src/export.sig @@ -36,6 +36,7 @@ datatype export_kind = Link | Action of effect | Rpc of effect + | Extern of effect val p_effect : effect Print.printer val p_export_kind : export_kind Print.printer diff --git a/src/export.sml b/src/export.sml index ad604e16..5d200894 100644 --- a/src/export.sml +++ b/src/export.sml @@ -39,6 +39,7 @@ datatype export_kind = Link | Action of effect | Rpc of effect + | Extern of effect fun p_effect ef = case ef of @@ -51,5 +52,6 @@ fun p_export_kind ck = Link => string "link" | Action ef => box [string "action(", p_effect ef, string ")"] | Rpc ef => box [string "rpc(", p_effect ef, string ")"] + | Extern ef => box [string "extern(", p_effect ef, string ")"] end diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml index de6879ae..c7a274de 100644 --- a/src/marshalcheck.sml +++ b/src/marshalcheck.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2009, Adam Chlipala +(* Copyright (c) 2009-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -96,7 +96,10 @@ fun check file = let fun makeS (t, _) = case t of - TFun (dom, ran) => PS.union (sins cmap dom, makeS ran) + TFun (dom, ran) => + (case #1 dom of + CFfi ("Basis", "postBody") => makeS ran + | _ => PS.union (sins cmap dom, makeS ran)) | _ => PS.empty val s = makeS t in |