queryString and effectfulUrl

9 files changed, 74 insertions, 12 deletions

diff --git a/src/c/request.c b/src/c/request.c
index b49a524e..3627d2f3 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -164,19 +164,21 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log
 
 
 typedef struct uw_rc {
-  size_t path_copy_size;
-  char *path_copy;
+  size_t path_copy_size, queryString_size;
+  char *path_copy, *queryString;
 } *uw_request_context;
 
 uw_request_context uw_new_request_context(void) {
   uw_request_context r = malloc(sizeof(struct uw_rc));
-  r->path_copy_size = 0;
+  r->path_copy_size = r->queryString_size = 0;
   r->path_copy = malloc(0);
+  r->queryString = malloc(0);
   return r;
 }
 
 void uw_free_request_context(uw_request_context r) {
   free(r->path_copy);
+  free(r->queryString);
   free(r);
 }
 
@@ -380,6 +382,14 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
 
     if (inputs) {
       char *name, *value;
+      int len = strlen(inputs);
+
+      if (len+1 > rc->queryString_size) {
+        rc->queryString_size = len+1;
+        rc->queryString = realloc(rc->queryString, len+1);
+      }
+      strcpy(rc->queryString, inputs);
+      uw_setQueryString(ctx, rc->queryString);
 
       while (*inputs) {
         name = inputs;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7dc2ba3a..b78c4c82 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -443,6 +443,7 @@ struct uw_context {
 
   int hasPostBody;
   uw_Basis_postBody postBody;
+  uw_Basis_string queryString;
 
   char error_message[ERROR_BUF_LEN];
 };
@@ -508,6 +509,8 @@ uw_context uw_init(void *logger_data, uw_logger log_debug) {
 
   ctx->hasPostBody = 0;
 
+  ctx->queryString = NULL;
+
   return ctx;
 }
 
@@ -585,6 +588,7 @@ void uw_reset_keep_error_message(uw_context ctx) {
   ctx->used_transactionals = 0;
   ctx->script_header = "";
   ctx->hasPostBody = 0;
+  ctx->queryString = NULL;
 }
 
 void uw_reset_keep_request(uw_context ctx) {
@@ -3602,6 +3606,14 @@ int uw_hasPostBody(uw_context ctx) {
   return ctx->hasPostBody;
 }
 
+void uw_setQueryString(uw_context ctx, uw_Basis_string s) {
+  ctx->queryString = s;
+}
+
+uw_Basis_string uw_queryString(uw_context ctx) {
+  return ctx->queryString;
+}
+
 uw_Basis_postBody uw_getPostBody(uw_context ctx) {
   if (ctx->hasPostBody)
     return ctx->postBody;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 53060ab2..cb6c6d3c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -66,6 +66,7 @@ fun isUnboxable (t : typ) =
     case #1 t of
         TDatatype (Default, _, _) => true
       | TFfi ("Basis", "string") => true
+      | TFfi ("Basis", "queryString") => true
       | _ => false
 
 fun p_typ' par env (t, loc) =
@@ -2696,6 +2697,7 @@ fun p_file env (ds, ps) =
                                                                 space,
                                                                 case #1 t of
                                                                     TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)"
+                                                                  | TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)"
                                                                   | _ => unurlify false env t,
                                                                 string ";",
                                                                 newline]) ts),
diff --git a/src/effectize.sml b/src/effectize.sml
index aba8bc58..3fb85f7b 100644
--- a/src/effectize.sml
+++ b/src/effectize.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
@@ -141,7 +141,7 @@ fun effectize file =
                 in
                     (d, loop (writers, readers, pushers))
                 end
-              | DExport (Link, n, _) =>
+              | DExport (Link, n, t) =>
                 (case IM.find (writers, n) of
                      NONE => ()
                    | SOME (loc, s) =>
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index c7a274de..eadbfa49 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -99,6 +99,7 @@ fun check file =
                                                TFun (dom, ran) =>
                                                (case #1 dom of
                                                     CFfi ("Basis", "postBody") => makeS ran
+                                                  | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran
                                                   | _ => PS.union (sins cmap dom, makeS ran))
                                              | _ => PS.empty
                                        val s = makeS t
diff --git a/src/monoize.sml b/src/monoize.sml
index 6946f877..4009226d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1189,6 +1189,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
             end
+          | L.EFfi ("Basis", "show_queryString") =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
+            end
           | L.EFfi ("Basis", "show_url") =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
@@ -3633,8 +3639,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EFfiApp ("Basis", "url", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
+                val (e, fm) = urlifyExp env fm (e, dummyTyp)
             in
-                urlifyExp env fm (e, dummyTyp)
+                ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm)
             end
 
           | L.EApp (e1, e2) =>
diff --git a/src/settings.sig b/src/settings.sig
index efbbdb32..c49ecacc 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -35,6 +35,7 @@ signature SETTINGS = sig
     (* How do all application URLs begin? *)
     val setUrlPrefix : string -> unit
     val getUrlPrefix : unit -> string
+    val getUrlPrePrefix : unit -> string
 
     (* How many seconds should the server wait before assuming a Comet client has left? *)
     val setTimeout : int -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 5b4bbe2c..29bbb1d8 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -28,18 +28,38 @@
 structure Settings :> SETTINGS = struct
 
 val urlPrefix = ref "/"
+val urlPrePrefix = ref ""
 val timeout = ref 0
 val headers = ref ([] : string list)
 val scripts = ref ([] : string list)
 
 fun getUrlPrefix () = !urlPrefix
+fun getUrlPrePrefix () = !urlPrePrefix
 fun setUrlPrefix p =
-    urlPrefix := (if p = "" then
-                      "/"
-                  else if String.sub (p, size p - 1) <> #"/" then
-                      p ^ "/"
-                  else
-                      p)
+    let
+        val prefix = if p = "" then
+                         "/"
+                     else if String.sub (p, size p - 1) <> #"/" then
+                         p ^ "/"
+                     else
+                         p
+
+        val (prepre, prefix) =
+            if String.isPrefix "http://" prefix then
+                let
+                    val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, 7, NONE))
+                in
+                    if Substring.isEmpty after then
+                        ("", prefix)
+                    else
+                        ("http://" ^ Substring.string befor, Substring.string after)
+                end
+            else
+                ("", prefix)
+    in
+        urlPrePrefix := prepre;
+        urlPrefix := prefix
+    end
 
 fun getTimeout () = !timeout
 fun setTimeout n = timeout := n
diff --git a/src/tag.sml b/src/tag.sml
index c9d3cbb8..a313e0a6 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -171,6 +171,15 @@ fun exp env (e, s) =
                 (EFfiApp ("Basis", "url", [e]), s)
             end
 
+          | EFfiApp ("Basis", "effectfulUrl", [(ERel 0, _)]) => (e, s)
+
+          | EFfiApp ("Basis", "effectfulUrl", [e]) =>
+            let
+                val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
+            in
+                (EFfiApp ("Basis", "url", [e]), s)
+            end
+
           | EApp ((ENamed n, _), e') =>
             let
                 val (_, _, eo, _) = E.lookupENamed env n