summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 11:29:16 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 11:29:16 -0500
commit09d844ebdc60010b6b19d1833c213bcbba035515 (patch)
tree05a8c82978b8d58211cd4b05357cccecd0dd9fb7
parent6b020742f893fed869a9473680271b6a68e1ce09 (diff)
Setting a cookie
Diffstat
-rw-r--r--include/urweb.h3
-rw-r--r--src/c/driver.c7
-rw-r--r--src/c/urweb.c69
-rw-r--r--src/mono_reduce.sml12
-rw-r--r--src/monoize.sml39
-rw-r--r--tests/cookie.ur3
6 files changed, 121 insertions, 12 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 301129c5..4fb2d612 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -98,3 +98,6 @@ uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string);
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);
diff --git a/src/c/driver.c b/src/c/driver.c
index ac968dc9..438adb8d 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -206,15 +206,12 @@ static void *worker(void *data) {
}
}
- 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;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 5f718db6..dc58576a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -26,6 +26,7 @@ typedef struct {
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 @@ struct uw_context {
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_get_db(uw_context ctx) {
}
void uw_free(uw_context ctx) {
+ free(ctx->outHeaders);
free(ctx->page);
free(ctx->heap);
free(ctx->inputs);
@@ -84,6 +91,7 @@ void uw_free(uw_context ctx) {
}
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_request(uw_context ctx) {
}
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_end_region(uw_context ctx) {
}
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_really_send(int sock, const void *buf, size_t len) {
}
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_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) {
}
}
+
+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;
+}
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 57a9cc6d..7420f14f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -50,6 +50,7 @@ fun impure (e, _) =
| ENone _ => false
| ESome (_, e) => impure e
| EFfi _ => false
+ | EFfiApp ("Basis", "set_cookie", _) => true
| EFfiApp _ => false
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -231,6 +232,7 @@ fun summarize d (e, _) =
| 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 @@ fun exp env e =
#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
diff --git a/src/monoize.sml b/src/monoize.sml
index 0bdc1c70..64522a18 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -133,6 +133,8 @@ fun monoType env =
| 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoDecl (env, fm) (all as (d, loc)) =
(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 =
diff --git a/tests/cookie.ur b/tests/cookie.ur
index b2bca580..36734260 100644
--- a/tests/cookie.ur
+++ b/tests/cookie.ur
@@ -2,8 +2,7 @@ cookie c : string
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>
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-03 20:55:03 +0000