Mercurial > urweb
changeset 462:21bb5bbba2e9
Setting a cookie
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 06 Nov 2008 11:29:16 -0500 (2008-11-06) |
parents | 5c9606deacb6 |
children | bb27c7efcd90 |
files | include/urweb.h src/c/driver.c src/c/urweb.c src/mono_reduce.sml src/monoize.sml tests/cookie.ur |
diffstat | 6 files changed, 121 insertions(+), 12 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu Nov 06 10:48:02 2008 -0500 +++ b/include/urweb.h Thu Nov 06 11:29:16 2008 -0500 @@ -98,3 +98,6 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); + +void uw_write_header(uw_context, uw_Basis_string); +uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string);
--- a/src/c/driver.c Thu Nov 06 10:48:02 2008 -0500 +++ b/src/c/driver.c Thu Nov 06 11:29:16 2008 -0500 @@ -206,15 +206,12 @@ } } - uw_write(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write(ctx, "Content-type: text/html\r\n\r\n"); - uw_write(ctx, "<html>"); + uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); + uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, "</html>"); - if (uw_db_commit(ctx)) { fk = FATAL;
--- a/src/c/urweb.c Thu Nov 06 10:48:02 2008 -0500 +++ b/src/c/urweb.c Thu Nov 06 11:29:16 2008 -0500 @@ -26,6 +26,7 @@ struct uw_context { char *headers, *headers_end; + char *outHeaders, *outHeaders_front, *outHeaders_back; char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; char **inputs; @@ -43,11 +44,16 @@ extern int uw_inputs_len; -uw_context uw_init(size_t page_len, size_t heap_len) { +uw_context uw_init(size_t outHeaders_len, size_t page_len, size_t heap_len) { uw_context ctx = malloc(sizeof(struct uw_context)); ctx->headers = ctx->headers_end = NULL; + ctx->outHeaders_front = ctx->outHeaders = malloc(outHeaders_len); + ctx->outHeaders_back = ctx->outHeaders_front + outHeaders_len; + + ctx->heap_front = ctx->heap = malloc(heap_len); + ctx->page_front = ctx->page = malloc(page_len); ctx->page_back = ctx->page_front + page_len; @@ -76,6 +82,7 @@ } void uw_free(uw_context ctx) { + free(ctx->outHeaders); free(ctx->page); free(ctx->heap); free(ctx->inputs); @@ -84,6 +91,7 @@ } void uw_reset_keep_request(uw_context ctx) { + ctx->outHeaders_front = ctx->outHeaders; ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; @@ -93,6 +101,7 @@ } void uw_reset_keep_error_message(uw_context ctx) { + ctx->outHeaders_front = ctx->outHeaders; ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; @@ -276,6 +285,7 @@ } void uw_memstats(uw_context ctx) { + printf("Headers: %d/%d\n", ctx->outHeaders_front - ctx->outHeaders, ctx->outHeaders_back - ctx->outHeaders); printf("Page: %d/%d\n", ctx->page_front - ctx->page, ctx->page_back - ctx->page); printf("Heap: %d/%d\n", ctx->heap_front - ctx->heap, ctx->heap_back - ctx->heap); } @@ -295,7 +305,52 @@ } int uw_send(uw_context ctx, int sock) { - return uw_really_send(sock, ctx->page, ctx->page_front - ctx->page); + int n = uw_really_send(sock, ctx->outHeaders, ctx->outHeaders_front - ctx->outHeaders); + + if (n < 0) + return n; + + n = uw_really_send(sock, "\r\n", 2); + + if (n < 0) + return n; + + n = uw_really_send(sock, "<html>", 6); + + if (n < 0) + return n; + + n = uw_really_send(sock, ctx->page, ctx->page_front - ctx->page); + + if (n < 0) + return n; + + return uw_really_send(sock, "</html>", 7); +} + +static void uw_check_headers(uw_context ctx, size_t extra) { + size_t desired = ctx->outHeaders_front - ctx->outHeaders + extra, next; + char *new_outHeaders; + + next = ctx->outHeaders_back - ctx->outHeaders; + if (next < desired) { + if (next == 0) + next = 1; + for (; next < desired; next *= 2); + + new_outHeaders = realloc(ctx->outHeaders, next); + ctx->outHeaders_front = new_outHeaders + (ctx->outHeaders_front - ctx->outHeaders); + ctx->outHeaders_back = new_outHeaders + next; + ctx->outHeaders = new_outHeaders; + } +} + +void uw_write_header(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + + uw_check_headers(ctx, len + 1); + strcpy(ctx->outHeaders_front, s); + ctx->outHeaders_front += len; } static void uw_check(uw_context ctx, size_t extra) { @@ -1090,3 +1145,13 @@ } } + +uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) { + uw_write_header(ctx, "Set-Cookie: "); + uw_write_header(ctx, c); + uw_write_header(ctx, "="); + uw_write_header(ctx, v); + uw_write_header(ctx, "\r\n"); + + return uw_unit_v; +}
--- a/src/mono_reduce.sml Thu Nov 06 10:48:02 2008 -0500 +++ b/src/mono_reduce.sml Thu Nov 06 11:29:16 2008 -0500 @@ -50,6 +50,7 @@ | ENone _ => false | ESome (_, e) => impure e | EFfi _ => false + | EFfiApp ("Basis", "set_cookie", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -231,6 +232,7 @@ | ENone _ => [] | ESome (_, e) => summarize d e | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", _) => [Unsure] | EFfiApp (_, _, es) => List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => [Unsure] @@ -347,12 +349,16 @@ #1 (reduceExp env (ELet (x, t, e, (EApp (b, liftExpInExp 0 e'), loc)), loc)) - | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) => - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc)) + | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + if impure e' then + e + else + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | ELet (x, t, e', b) => let - fun doSub () = #1 (reduceExp env (subExpInExp (0, e') b)) + fun doSub () = + #1 (reduceExp env (subExpInExp (0, e') b)) fun trySub () = case t of
--- a/src/monoize.sml Thu Nov 06 10:48:02 2008 -0500 +++ b/src/monoize.sml Thu Nov 06 11:29:16 2008 -0500 @@ -133,6 +133,8 @@ | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => @@ -945,6 +947,33 @@ fm) end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + in + ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), + (L'.EAbs ("_", un, s, + (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t) + in + ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("v", t, (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.EFfiApp ("Basis", "set_cookie", [(L'.ERel 2, loc), e]), loc)), + loc)), loc)), loc), + fm) + end + | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e @@ -2059,6 +2088,16 @@ (L'.DVal (x, n, t', e, s), loc)]) end | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)]) + | L.DCookie (x, n, t, s) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = (L'.EPrim (Prim.String s), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DVal (x, n, t', e, s), loc)]) + end end fun monoize env ds =
--- a/tests/cookie.ur Thu Nov 06 10:48:02 2008 -0500 +++ b/tests/cookie.ur Thu Nov 06 11:29:16 2008 -0500 @@ -2,8 +2,7 @@ fun main () : transaction page = setCookie c "Hi"; - so <- getCookie c; + so <- requestHeader "Cookie"; case so of None => return <xml>No cookie</xml> | Some s => return <xml>Cookie: {[s]}</xml> -