Mercurial > urweb

changeset 462:21bb5bbba2e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Setting a cookie
author Adam Chlipala <adamc@hcoop.net>
date Thu, 06 Nov 2008 11:29:16 -0500
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>
-