# HG changeset patch # User Adam Chlipala # Date 1293402543 18000 # Node ID 44a12a32115070bb637c97fbeff539bde6da1fd5 # Parent 1a78ca089bd040b838f0d7ac13526d361fd5d38f queryString and effectfulUrl diff -r 1a78ca089bd0 -r 44a12a321150 doc/manual.tex --- a/doc/manual.tex Sun Dec 26 15:52:56 2010 -0500 +++ b/doc/manual.tex Sun Dec 26 17:29:03 2010 -0500 @@ -2084,6 +2084,8 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 include/types.h --- a/include/types.h Sun Dec 26 15:52:56 2010 -0500 +++ b/include/types.h Sun Dec 26 17:29:03 2010 -0500 @@ -47,6 +47,8 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 include/urweb.h --- a/include/urweb.h Sun Dec 26 15:52:56 2010 -0500 +++ b/include/urweb.h Sun Dec 26 17:29:03 2010 -0500 @@ -317,4 +317,7 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 lib/ur/basis.urs --- a/lib/ur/basis.urs Sun Dec 26 15:52:56 2010 -0500 +++ b/lib/ur/basis.urs Sun Dec 26 17:29:03 2010 -0500 @@ -625,12 +625,16 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/c/request.c --- a/src/c/request.c Sun Dec 26 15:52:56 2010 -0500 +++ b/src/c/request.c Sun Dec 26 17:29:03 2010 -0500 @@ -164,19 +164,21 @@ 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 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/c/urweb.c --- a/src/c/urweb.c Sun Dec 26 15:52:56 2010 -0500 +++ b/src/c/urweb.c Sun Dec 26 17:29:03 2010 -0500 @@ -443,6 +443,7 @@ int hasPostBody; uw_Basis_postBody postBody; + uw_Basis_string queryString; char error_message[ERROR_BUF_LEN]; }; @@ -508,6 +509,8 @@ ctx->hasPostBody = 0; + ctx->queryString = NULL; + return ctx; } @@ -585,6 +588,7 @@ 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 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/cjr_print.sml --- a/src/cjr_print.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/cjr_print.sml Sun Dec 26 17:29:03 2010 -0500 @@ -66,6 +66,7 @@ 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 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/effectize.sml --- a/src/effectize.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/effectize.sml Sun Dec 26 17:29:03 2010 -0500 @@ -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 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/marshalcheck.sml --- a/src/marshalcheck.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/marshalcheck.sml Sun Dec 26 17:29:03 2010 -0500 @@ -99,6 +99,7 @@ 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 -r 1a78ca089bd0 -r 44a12a321150 src/monoize.sml --- a/src/monoize.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/monoize.sml Sun Dec 26 17:29:03 2010 -0500 @@ -1189,6 +1189,12 @@ 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 @@ | 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 -r 1a78ca089bd0 -r 44a12a321150 src/settings.sig --- a/src/settings.sig Sun Dec 26 15:52:56 2010 -0500 +++ b/src/settings.sig Sun Dec 26 17:29:03 2010 -0500 @@ -35,6 +35,7 @@ (* 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 -r 1a78ca089bd0 -r 44a12a321150 src/settings.sml --- a/src/settings.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/settings.sml Sun Dec 26 17:29:03 2010 -0500 @@ -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 -r 1a78ca089bd0 -r 44a12a321150 src/tag.sml --- a/src/tag.sml Sun Dec 26 15:52:56 2010 -0500 +++ b/src/tag.sml Sun Dec 26 17:29:03 2010 -0500 @@ -171,6 +171,15 @@ (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