Mercurial > urweb
changeset 463:bb27c7efcd90
Reading cookies works
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 06 Nov 2008 12:08:41 -0500 |
| parents | 21bb5bbba2e9 |
| children | 91914c15a85b |
| files | include/urweb.h src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml tests/cookie.ur |
| diffstat | 12 files changed, 440 insertions(+), 353 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu Nov 06 11:29:16 2008 -0500 +++ b/include/urweb.h Thu Nov 06 12:08:41 2008 -0500 @@ -100,4 +100,6 @@ uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); void uw_write_header(uw_context, uw_Basis_string); + +uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string); uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string);
--- a/src/c/urweb.c Thu Nov 06 11:29:16 2008 -0500 +++ b/src/c/urweb.c Thu Nov 06 12:08:41 2008 -0500 @@ -1143,7 +1143,23 @@ return NULL; } } +} +uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { + int len = strlen(c); + char *s = ctx->headers, *p; + + while (p = strchr(s, ':')) { + if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len) + && p + 2 + len < ctx->headers_end && p[2 + len] == '=') { + return p + 3 + len; + } else { + if ((s = strchr(p, 0)) && s < ctx->headers_end) + s += 2; + else + return NULL; + } + } } uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) {
--- a/src/cjr.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/cjr.sml Thu Nov 06 12:08:41 2008 -0500 @@ -92,6 +92,7 @@ prepared : int option } | ENextval of { seq : exp, prepared : int option } + | EUnurlify of exp * typ withtype exp = exp' located
--- a/src/cjr_print.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/cjr_print.sml Thu Nov 06 12:08:41 2008 -0500 @@ -62,6 +62,12 @@ val p_ident = string o ident +fun isUnboxable (t : typ) = + case #1 t of + TDatatype (Default, _, _) => true + | TFfi ("Basis", "string") => true + | _ => false + fun p_typ' par env (t, loc) = case t of TFun (t1, t2) => parenIf par (box [p_typ' true env t2, @@ -96,11 +102,11 @@ handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | TOption t => - (case #1 t of - TDatatype _ => p_typ' par env t - | TFfi ("Basis", "string") => p_typ' par env t - | _ => box [p_typ' par env t, - string "*"]) + if isUnboxable t then + p_typ' par env t + else + box [p_typ' par env t, + string "*"] and p_typ env = p_typ' false env @@ -228,13 +234,12 @@ string "->data.", string x] | Option => - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -335,13 +340,12 @@ space, string "=", space, - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -468,6 +472,288 @@ nl end +fun capitalize s = + if s = "" then + "" + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun unurlify env (t, loc) = + let + fun unurlify' rf t = + case t of + TFfi ("Basis", "unit") => string ("uw_unit_v") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + + | TRecord 0 => string "uw_unit_v" + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "({", + newline, + box (map (fn (x, t) => + box [p_typ env t, + space, + string "uwr_", + string x, + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline]) xts), + string "struct", + space, + string "__uws_", + string (Int.toString i), + space, + string "tmp", + space, + string "=", + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", + string x]) xts, + space, + string "};", + newline, + string "tmp;", + newline, + string "})"] + end + + | TDatatype (Enum, i, _) => + let + val (x, xncs) = E.lookupDatatype env i + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), (enum __uwe_" + ^ x ^ "_" ^ Int.toString i ^ ")0)") + | (x', n, to) :: rest => + box [string "((!strncmp(request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && (request[", + string (Int.toString (size x')), + string "] == 0 || request[", + string (Int.toString (size x')), + string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), + space, + string ":", + space, + doEm rest, + string ")"] + in + doEm xncs + end + + | TDatatype (Option, i, xncs) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + else + let + val (x, _) = E.lookupDatatype env i + + val (no_arg, has_arg, t) = + case !xncs of + [(no_arg, _, NONE), (has_arg, _, SOME t)] => + (no_arg, has_arg, t) + | [(has_arg, _, SOME t), (no_arg, _, NONE)] => + (no_arg, has_arg, t) + | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" + + val rf = IS.add (rf, i) + in + box [string "({", + space, + p_typ env t, + space, + string "*unurlify_", + string (Int.toString i), + string "(void) {", + newline, + box [string "return (request[0] == '/' ? ++request : request,", + newline, + string "((!strncmp(request, \"", + string no_arg, + string "\", ", + string (Int.toString (size no_arg)), + string ") && (request[", + string (Int.toString (size no_arg)), + string "] == 0 || request[", + string (Int.toString (size no_arg)), + string "] == '/')) ? (request", + space, + string "+=", + space, + string (Int.toString (size no_arg)), + string ", NULL) : ((!strncmp(request, \"", + string has_arg, + string "\", ", + string (Int.toString (size has_arg)), + string ") && (request[", + string (Int.toString (size has_arg)), + string "] == 0 || request[", + string (Int.toString (size has_arg)), + string "] == '/')) ? (request", + space, + string "+=", + space, + string (Int.toString (size has_arg)), + string ", (request[0] == '/' ? ++request : NULL), ", + newline, + + if isUnboxable t then + unurlify' rf (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")", + newline, + string ":", + space, + string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x + ^ "\"), NULL))));"), + newline], + string "}", + newline, + newline, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | TDatatype (Default, i, _) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + else + let + val (x, xncs) = E.lookupDatatype env i + + val rf = IS.add (rf, i) + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), NULL)") + | (x', n, to) :: rest => + box [string "((!strncmp(request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && (request[", + string (Int.toString (size x')), + string "] == 0 || request[", + string (Int.toString (size x')), + string "] == '/')) ? ({", + newline, + string "struct", + space, + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), + space, + string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", + string x, + string "_", + string (Int.toString i), + string "));", + newline, + string "tmp->tag", + space, + string "=", + space, + string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), + string ";", + newline, + string "request", + space, + string "+=", + space, + string (Int.toString (size x')), + string ";", + newline, + string "if (request[0] == '/') ++request;", + newline, + case to of + NONE => box [] + | SOME (t, _) => box [string "tmp->data.uw_", + p_ident x', + space, + string "=", + space, + unurlify' rf t, + string ";", + newline], + string "tmp;", + newline, + string "})", + space, + string ":", + space, + doEm rest, + string ")"] + in + box [string "({", + space, + p_typ env (t, ErrorMsg.dummySpan), + space, + string "unurlify_", + string (Int.toString i), + string "(void) {", + newline, + box [string "return", + space, + doEm xncs, + string ";", + newline], + string "}", + newline, + newline, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; + space) + in + unurlify' IS.empty t + end + fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t_GCC p @@ -485,30 +771,30 @@ NONE => raise Fail "CjrPrint: ECon argument status mismatch" | SOME t => t in - case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"] + if isUnboxable t then + p_exp' par env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] end | ECon (Default, pc, eo) => let @@ -551,30 +837,30 @@ end | ENone _ => string "NULL" | ESome (t, e) => - (case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"]) + if isUnboxable t then + p_exp' par env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | EError (e, t) => @@ -1078,6 +1364,41 @@ string "}))"] end + | EUnurlify (e, t) => + let + fun getIt () = + if isUnboxable t then + unurlify env t + else + box [string "({", + newline, + p_typ env t, + string " *tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + unurlify env t, + string ";", + newline, + string "tmp;", + newline, + string "})"] + in + box [string "({", + newline, + string "uw_Basis_string request = ", + p_exp env e, + string ";", + newline, + newline, + string "(request ? ", + getIt (), + string " : NULL);", + newline, + string "})"] + end + and p_exp env = p_exp' false env fun p_fun env (fx, n, args, ran, e) = @@ -1527,288 +1848,6 @@ string "}"] end - fun capitalize s = - if s = "" then - "" - else - str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) - - fun unurlify (t, loc) = - let - fun unurlify' rf t = - case t of - TFfi ("Basis", "unit") => string ("uw_unit_v") - | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") - - | TRecord 0 => string "uw_unit_v" - | TRecord i => - let - val xts = E.lookupStruct env i - in - box [string "({", - newline, - box (map (fn (x, t) => - box [p_typ env t, - space, - string "uwr_", - string x, - space, - string "=", - space, - unurlify' rf (#1 t), - string ";", - newline]) xts), - string "struct", - space, - string "__uws_", - string (Int.toString i), - space, - string "tmp", - space, - string "=", - space, - string "{", - space, - p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", - string x]) xts, - space, - string "};", - newline, - string "tmp;", - newline, - string "})"] - end - - | TDatatype (Enum, i, _) => - let - val (x, xncs) = E.lookupDatatype env i - - fun doEm xncs = - case xncs of - [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " - ^ x ^ "\"), (enum __uwe_" - ^ x ^ "_" ^ Int.toString i ^ ")0)") - | (x', n, to) :: rest => - box [string "((!strncmp(request, \"", - string x', - string "\", ", - string (Int.toString (size x')), - string ") && (request[", - string (Int.toString (size x')), - string "] == 0 || request[", - string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), - space, - string ":", - space, - doEm rest, - string ")"] - in - doEm xncs - end - - | TDatatype (Option, i, xncs) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - else - let - val (x, _) = E.lookupDatatype env i - - val (no_arg, has_arg, t) = - case !xncs of - [(no_arg, _, NONE), (has_arg, _, SOME t)] => - (no_arg, has_arg, t) - | [(has_arg, _, SOME t), (no_arg, _, NONE)] => - (no_arg, has_arg, t) - | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" - - val rf = IS.add (rf, i) - in - box [string "({", - space, - p_typ env t, - space, - string "*unurlify_", - string (Int.toString i), - string "(void) {", - newline, - box [string "return (request[0] == '/' ? ++request : request,", - newline, - string "((!strncmp(request, \"", - string no_arg, - string "\", ", - string (Int.toString (size no_arg)), - string ") && (request[", - string (Int.toString (size no_arg)), - string "] == 0 || request[", - string (Int.toString (size no_arg)), - string "] == '/')) ? (request", - space, - string "+=", - space, - string (Int.toString (size no_arg)), - string ", NULL) : ((!strncmp(request, \"", - string has_arg, - string "\", ", - string (Int.toString (size has_arg)), - string ") && (request[", - string (Int.toString (size has_arg)), - string "] == 0 || request[", - string (Int.toString (size has_arg)), - string "] == '/')) ? (request", - space, - string "+=", - space, - string (Int.toString (size has_arg)), - string ", (request[0] == '/' ? ++request : NULL), ", - newline, - - case #1 t of - TDatatype _ => unurlify' rf (#1 t) - | TFfi ("Basis", "string") => unurlify' rf (#1 t) - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - space, - unurlify' rf (#1 t), - string ";", - newline, - string "tmp;", - newline, - string "})"], - string ")", - newline, - string ":", - space, - string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x - ^ "\"), NULL))));"), - newline], - string "}", - newline, - newline, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | TDatatype (Default, i, _) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - else - let - val (x, xncs) = E.lookupDatatype env i - - val rf = IS.add (rf, i) - - fun doEm xncs = - case xncs of - [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " - ^ x ^ "\"), NULL)") - | (x', n, to) :: rest => - box [string "((!strncmp(request, \"", - string x', - string "\", ", - string (Int.toString (size x')), - string ") && (request[", - string (Int.toString (size x')), - string "] == 0 || request[", - string (Int.toString (size x')), - string "] == '/')) ? ({", - newline, - string "struct", - space, - string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), - space, - string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", - string x, - string "_", - string (Int.toString i), - string "));", - newline, - string "tmp->tag", - space, - string "=", - space, - string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), - string ";", - newline, - string "request", - space, - string "+=", - space, - string (Int.toString (size x')), - string ";", - newline, - string "if (request[0] == '/') ++request;", - newline, - case to of - NONE => box [] - | SOME (t, _) => box [string "tmp->data.uw_", - p_ident x', - space, - string "=", - space, - unurlify' rf t, - string ";", - newline], - string "tmp;", - newline, - string "})", - space, - string ":", - space, - doEm rest, - string ")"] - in - box [string "({", - space, - p_typ env (t, ErrorMsg.dummySpan), - space, - string "unurlify_", - string (Int.toString i), - string "(void) {", - newline, - box [string "return", - space, - doEm xncs, - string ";", - newline], - string "}", - newline, - newline, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; - space) - in - unurlify' IS.empty t - end - fun p_page (ek, s, n, ts) = let val (ts, defInputs, inputsVar) = @@ -1855,7 +1894,7 @@ space, string "=", space, - unurlify t, + unurlify env t, string ";", newline] end) xts), @@ -1904,7 +1943,7 @@ space, string "=", space, - unurlify t, + unurlify env t, string ";", newline]) ts), defInputs,
--- a/src/cjrize.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/cjrize.sml Thu Nov 06 12:08:41 2008 -0500 @@ -412,6 +412,13 @@ ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) end + | L.EUnurlify (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EUnurlify (e, t), loc), sm) + end fun cifyDecl ((d, loc), sm) = case d of
--- a/src/mono.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/mono.sml Thu Nov 06 12:08:41 2008 -0500 @@ -94,6 +94,8 @@ | EDml of exp | ENextval of exp + | EUnurlify of exp * typ + withtype exp = exp' located
--- a/src/mono_print.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/mono_print.sml Thu Nov 06 12:08:41 2008 -0500 @@ -272,6 +272,9 @@ | ENextval e => box [string "nextval(", p_exp env e, string ")"] + | EUnurlify (e, _) => box [string "unurlify(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env
--- a/src/mono_reduce.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/mono_reduce.sml Thu Nov 06 12:08:41 2008 -0500 @@ -41,6 +41,7 @@ | EQuery _ => true | EDml _ => true | ENextval _ => true + | EUnurlify _ => true | EAbs _ => false | EPrim _ => false @@ -275,6 +276,7 @@ | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e fun exp env e = let
--- a/src/mono_util.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/mono_util.sml Thu Nov 06 12:08:41 2008 -0500 @@ -305,6 +305,12 @@ S.map2 (mfe ctx e, fn e' => (ENextval e', loc)) + | EUnurlify (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (EUnurlify (e', t'), loc))) in mfe end
--- a/src/monoize.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/monoize.sml Thu Nov 06 12:08:41 2008 -0500 @@ -955,7 +955,9 @@ in ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), (L'.EAbs ("_", un, s, - (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc), + (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc), + t), + loc)), loc)), loc), fm) end
--- a/src/prepare.sml Thu Nov 06 11:29:16 2008 -0500 +++ b/src/prepare.sml Thu Nov 06 12:08:41 2008 -0500 @@ -191,6 +191,13 @@ ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) end + | EUnurlify (e, t) => + let + val (e, sns) = prepExp (e, sns) + in + ((EUnurlify (e, t), loc), sns) + end + fun prepDecl (d as (_, loc), sns) = case #1 d of DStruct _ => (d, sns)
--- a/tests/cookie.ur Thu Nov 06 11:29:16 2008 -0500 +++ b/tests/cookie.ur Thu Nov 06 12:08:41 2008 -0500 @@ -2,7 +2,7 @@ fun main () : transaction page = setCookie c "Hi"; - so <- requestHeader "Cookie"; + so <- getCookie c; case so of None => return <xml>No cookie</xml> | Some s => return <xml>Cookie: {[s]}</xml>