postBody type

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