queryString and effectfulUrl

13 files changed, 85 insertions, 12 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index c59caac7..8aa8485f 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2084,6 +2084,8 @@ A web application is built from a series of modules, with one module, the last o
 
 Normal links are accessible via HTTP \texttt{GET}, which the relevant standard says should never cause side effects.  To export a page which may cause side effects, accessible only via HTTP \texttt{POST}, include one argument of the page handler of type $\mt{Basis.postBody}$.  When the handler is called, this argument will receive a value that can be deconstructed into a MIME type (with $\mt{Basis.postType}$) and payload (with $\mt{Basis.postData}$).  This kind of handler will only work with \texttt{POST} payloads of MIME types besides those associated with HTML forms; for these, use Ur/Web's built-in support, as described below.
 
+Any normal page handler may also include arguments of type $\mt{option \; Basis.queryString}$, which will be handled specially.  Rather than being deserialized from the current URI, such an argument is passed the whole query string that the handler received.  The string may be analyzed by calling $\mt{Basis.show}$ on it.  A handler of this kind may be passed as an argument to $\mt{Basis.effectfulUrl}$ to generate a URL to a page that may be used as a ``callback'' by an external service, such that the handler is allowed to cause side effects.
+
 When the standalone web server receives a request for a known page, it calls the function for that page, ``running'' the resulting transaction to produce the page to return to the client.  Pages link to other pages with the \texttt{link} attribute of the \texttt{a} HTML tag.  A link has type $\mt{transaction} \; \mt{page}$, and the semantics of a link are that this transaction should be run to compute the result page, when the link is followed.  Link targets are assigned URL names in the same way as top-level entry points.
 
 HTML forms are handled in a similar way.  The $\mt{action}$ attribute of a $\mt{submit}$ form tag takes a value of type $\$\mt{use} \to \mt{transaction} \; \mt{page}$, where $\mt{use}$ is a kind-$\{\mt{Type}\}$ record of the form fields used by this action handler.  Action handlers are assigned URL patterns in the same way as above.
diff --git a/include/types.h b/include/types.h
index ddc46b27..d36f0f6b 100644
--- a/include/types.h
+++ b/include/types.h
@@ -47,6 +47,8 @@ typedef struct uw_Basis_postBody {
   uw_Basis_string type, data;
 } uw_Basis_postBody;
 
+typedef uw_Basis_string uw_Basis_queryString;
+
 typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_INDIRECTLY } failure_kind;
 
 typedef enum { SERVED, KEEP_OPEN, FAILED } request_result;
diff --git a/include/urweb.h b/include/urweb.h
index 69496d06..dbbfec38 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -317,4 +317,7 @@ size_t uw_buffer_used(uw_buffer *);
 size_t uw_buffer_avail(uw_buffer *);
 int uw_buffer_append(uw_buffer *, const char *, size_t);
 
+void uw_setQueryString(uw_context, uw_Basis_string);
+uw_Basis_string uw_queryString(uw_context);
+
 #endif
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 54500753..a2881cf0 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -625,12 +625,16 @@ con subform = [Body, Subform]
 con tabl = [Body, Table]
 con tr = [Body, Tr]
 
+type queryString
+val show_queryString : show queryString
+
 type url
 val show_url : show url
 val bless : string -> url
 val checkUrl : string -> option url
 val currentUrl : transaction url
 val url : transaction page -> url
+val effectfulUrl : (option queryString -> transaction page) -> url
 val redirect : t ::: Type -> url -> transaction t
 
 val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ body] => unit
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