# HG changeset patch # User Patrick Hurst # Date 1390087584 18000 # Node ID 81bc76aa4acd2e37c57fa14c17ade71f3ea9fa3c # Parent c5143edaf3c70d303ed7ef6494a6b55af0ea64a8# Parent 93f3e35a79672f5d8ffc56ba3f96459cc485cbed Merge in upstream changes. diff -r c5143edaf3c7 -r 81bc76aa4acd CHANGELOG --- a/CHANGELOG Mon Dec 09 20:41:24 2013 -0500 +++ b/CHANGELOG Sat Jan 18 18:26:24 2014 -0500 @@ -1,3 +1,15 @@ +======== +20131231 +======== + +- Performance optimizations for Ur/Web's standalone HTTP servers +- New command-line options for those servers: '-k' and '-q' +- New HTML pseudo-tag: }. + \subsubsection{Node IDs} There is an abstract type of node IDs that may be assigned to \cd{id} attributes of most HTML tags. @@ -2184,7 +2196,7 @@ \mt{val} \; \mt{self} : \mt{transaction} \; \mt{client} \end{array}$$ -\emph{Channels} are the means of message-passing. Each channel is created in the context of a client and belongs to that client; no other client may receive the channel's messages. Each channel type includes the type of values that may be sent over the channel. Sending and receiving are asynchronous, in the sense that a client need not be ready to receive a message right away. Rather, sent messages may queue up, waiting to be processed. +\emph{Channels} are the means of message-passing. Each channel is created in the context of a client and belongs to that client; no other client may receive the channel's messages. Note that here \emph{client} has a technical Ur/Web meaning so that it describes only \emph{single page views}, so a user following a traditional link within an application will remove the ability for \emph{any} code to receive messages on the channels associated with the previous client. Each channel type includes the type of values that may be sent over the channel. Sending and receiving are asynchronous, in the sense that a client need not be ready to receive a message right away. Rather, sent messages may queue up, waiting to be processed. $$\begin{array}{l} \mt{con} \; \mt{channel} :: \mt{Type} \to \mt{Type} \\ diff -r c5143edaf3c7 -r 81bc76aa4acd include/urweb/types_cpp.h --- a/include/urweb/types_cpp.h Mon Dec 09 20:41:24 2013 -0500 +++ b/include/urweb/types_cpp.h Sat Jan 18 18:26:24 2014 -0500 @@ -82,7 +82,7 @@ void (*expunger)(struct uw_context *, uw_Basis_client); void (*db_init)(struct uw_context *); - int (*db_begin)(struct uw_context *); + int (*db_begin)(struct uw_context *, int could_write); int (*db_commit)(struct uw_context *); int (*db_rollback)(struct uw_context *); void (*db_close)(struct uw_context *); @@ -102,6 +102,8 @@ uw_periodic *periodics; // 0-terminated array uw_Basis_string time_format; + + int is_html5; } uw_app; #define ERROR_BUF_LEN 1024 diff -r c5143edaf3c7 -r 81bc76aa4acd include/urweb/urweb_cpp.h --- a/include/urweb/urweb_cpp.h Mon Dec 09 20:41:24 2013 -0500 +++ b/include/urweb/urweb_cpp.h Sat Jan 18 18:26:24 2014 -0500 @@ -37,9 +37,11 @@ void uw_set_headers(struct uw_context *, char *(*get_header)(void *, const char *), void *get_header_data); void uw_set_env(struct uw_context *, char *(*get_env)(void *, const char *), void *get_env_data); failure_kind uw_begin(struct uw_context *, char *path); +void uw_ensure_transaction(struct uw_context *); failure_kind uw_begin_onError(struct uw_context *, char *msg); void uw_login(struct uw_context *); -void uw_commit(struct uw_context *); +int uw_commit(struct uw_context *); +// ^-- returns nonzero if the transaction should be restarted int uw_rollback(struct uw_context *, int will_retry); __attribute__((noreturn)) void uw_error(struct uw_context *, failure_kind, const char *fmt, ...); @@ -85,6 +87,7 @@ void uw_set_needs_push(struct uw_context *, int); void uw_set_needs_sig(struct uw_context *, int); +void uw_set_could_write_db(struct uw_context *, int); char *uw_Basis_htmlifyInt(struct uw_context *, uw_Basis_int); char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float); @@ -208,6 +211,8 @@ void uw_write_header(struct uw_context *, uw_Basis_string); void uw_clear_headers(struct uw_context *); +int uw_has_contentLength(struct uw_context *); +void uw_Basis_clear_page(struct uw_context *); uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c); uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure); @@ -254,6 +259,7 @@ void uw_mayReturnIndirectly(struct uw_context *); __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType); +__attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url); uw_Basis_time uw_Basis_now(struct uw_context *); @@ -379,4 +385,6 @@ uw_Basis_string uw_Basis_remainingFields(struct uw_context *, uw_Basis_postField); uw_Basis_postField *uw_Basis_firstFormField(struct uw_context *, uw_Basis_string); +extern const char uw_begin_xhtml[], uw_begin_html5[]; + #endif diff -r c5143edaf3c7 -r 81bc76aa4acd lib/js/urweb.js --- a/lib/js/urweb.js Mon Dec 09 20:41:24 2013 -0500 +++ b/lib/js/urweb.js Sat Jan 18 18:26:24 2014 -0500 @@ -35,10 +35,11 @@ function isBlank(c) { return c == ' ' || c == '\t'; } function isSpace(c) { return isBlank(c) || c == '\r' || c == '\n'; } function isXdigit(c) { return isDigit(c) || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F'); } +function ord(c) { return c.charCodeAt(0); } +function isPrint(c) { return ord(c) > 31 && ord(c) < 127; } function toLower(c) { return c.toLowerCase(); } function toUpper(c) { return c.toUpperCase(); } - // Lists function cons(v, ls) { @@ -1574,7 +1575,7 @@ er("May not 'recv' in main thread of 'code' for "); if (chn == null) - return; + er("Client-side code tried to recv() from a channel belonging to a different page view."); if (chn < 0) whine("Out-of-bounds channel receive"); diff -r c5143edaf3c7 -r 81bc76aa4acd lib/ur/basis.urs --- a/lib/ur/basis.urs Mon Dec 09 20:41:24 2013 -0500 +++ b/lib/ur/basis.urs Sat Jan 18 18:26:24 2014 -0500 @@ -785,6 +785,7 @@ type id val fresh : transaction id val giveFocus : id -> transaction unit +val show_id : show id val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] => unit -> tag [Signal = signal (xml ([Dyn] ++ ctx) use bind)] ([Dyn] ++ ctx) [] use bind @@ -792,6 +793,9 @@ val active : unit -> tag [Code = transaction xbody] body [] [] [] +val script : unit + -> tag [Code = transaction unit] head [] [] [] + val head : unit -> tag [] html head [] [] val title : unit -> tag [] head [] [] [] val link : unit -> tag [Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] [] diff -r c5143edaf3c7 -r 81bc76aa4acd src/c/cgi.c --- a/src/c/cgi.c Mon Dec 09 20:41:24 2013 -0500 +++ b/src/c/cgi.c Sat Jan 18 18:26:24 2014 -0500 @@ -134,10 +134,11 @@ } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { - if (uw_get_app(ctx)->db_begin(ctx)) - uw_error(ctx, FATAL, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); - uw_commit(ctx); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); } void uw_post_expunge(uw_context ctx, void *data) { diff -r c5143edaf3c7 -r 81bc76aa4acd src/c/fastcgi.c --- a/src/c/fastcgi.c Mon Dec 09 20:41:24 2013 -0500 +++ b/src/c/fastcgi.c Sat Jan 18 18:26:24 2014 -0500 @@ -632,10 +632,11 @@ } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { - if (uw_get_app(ctx)->db_begin(ctx)) - uw_error(ctx, FATAL, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); - uw_commit(ctx); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); } void uw_post_expunge(uw_context ctx, void *data) { diff -r c5143edaf3c7 -r 81bc76aa4acd src/c/http.c --- a/src/c/http.c Mon Dec 09 20:41:24 2013 -0500 +++ b/src/c/http.c Sat Jan 18 18:26:24 2014 -0500 @@ -21,7 +21,7 @@ extern uw_app uw_application; int uw_backlog = SOMAXCONN; -static int keepalive = 0; +static int keepalive = 0, quiet = 0; static char *get_header(void *data, const char *h) { char *s = data; @@ -62,16 +62,18 @@ } static void log_debug(void *data, const char *fmt, ...) { - va_list ap; - va_start(ap, fmt); + if (!quiet) { + va_list ap; + va_start(ap, fmt); - vprintf(fmt, ap); + vprintf(fmt, ap); + } } static void *worker(void *data) { int me = *(int *)data; uw_context ctx = uw_request_new_context(me, &uw_application, NULL, log_error, log_debug); - size_t buf_size = 2; + size_t buf_size = 1024; char *buf = malloc(buf_size), *back = buf; uw_request_context rc = uw_new_request_context(); int sock = 0; @@ -82,7 +84,8 @@ sock = uw_dequeue(); } - printf("Handling connection with thread #%d.\n", me); + if (!quiet) + printf("Handling connection with thread #%d.\n", me); while (1) { int r; @@ -96,26 +99,32 @@ buf = new_buf; } - r = recv(sock, back, buf_size - 1 - (back - buf), 0); + *back = 0; + body = strstr(buf, "\r\n\r\n"); + if (body == NULL) { + r = recv(sock, back, buf_size - 1 - (back - buf), 0); - if (r < 0) { - fprintf(stderr, "Recv failed\n"); - close(sock); - sock = 0; - break; + if (r < 0) { + if (!quiet) + fprintf(stderr, "Recv failed\n"); + close(sock); + sock = 0; + break; + } + + if (r == 0) { + if (!quiet) + printf("Connection closed.\n"); + close(sock); + sock = 0; + break; + } + + back += r; + *back = 0; } - if (r == 0) { - printf("Connection closed.\n"); - close(sock); - sock = 0; - break; - } - - back += r; - *back = 0; - - if ((body = strstr(buf, "\r\n\r\n"))) { + if (body != NULL || (body = strstr(buf, "\r\n\r\n"))) { request_result rr; int should_keepalive = 0; @@ -148,14 +157,16 @@ r = recv(sock, back, buf_size - 1 - (back - buf), 0); if (r < 0) { - fprintf(stderr, "Recv failed\n"); + if (!quiet) + fprintf(stderr, "Recv failed\n"); close(sock); sock = 0; goto done; } if (r == 0) { - fprintf(stderr, "Connection closed.\n"); + if (!quiet) + fprintf(stderr, "Connection closed.\n"); close(sock); sock = 0; goto done; @@ -206,6 +217,11 @@ s = headers; while ((s2 = strchr(s, '\r'))) { + if (s2 == s) { + *s = 0; + break; + } + s = s2; if (s[1] == 0) @@ -218,15 +234,14 @@ uw_set_headers(ctx, get_header, headers); uw_set_env(ctx, get_env, NULL); - printf("Serving URI %s....\n", path); + if (!quiet) + printf("Serving URI %s....\n", path); rr = uw_request(rc, ctx, method, path, query_string, body, back - body, on_success, on_failure, NULL, log_error, log_debug, sock, uw_really_send, close); if (rr != KEEP_OPEN) { - char clen[100]; - if (keepalive) { char *connection = uw_Basis_requestHeader(ctx, "Connection"); @@ -236,8 +251,13 @@ if (!should_keepalive) uw_write_header(ctx, "Connection: close\r\n"); - sprintf(clen, "Content-length: %d\r\n", uw_pagelen(ctx)); - uw_write_header(ctx, clen); + if (!uw_has_contentLength(ctx)) { + char clen[100]; + + sprintf(clen, "Content-length: %d\r\n", uw_pagelen(ctx)); + uw_write_header(ctx, clen); + } + uw_send(ctx, sock); } @@ -246,13 +266,25 @@ // In case any other requests are queued up, shift // unprocessed part of buffer to front. int kept = back - after; - memmove(buf, after, kept); - back = buf + kept; + + if (kept == 0) { + // No pipelining going on here. + // We'd might as well try to switch to a different connection, + // while we wait for more input on this one. + uw_enqueue(sock); + sock = 0; + } else { + // More input! Move it to the front and continue in this loop. + memmove(buf, after, kept); + back = buf + kept; + } } else { close(sock); sock = 0; } - } else if (rr != KEEP_OPEN) + } else if (rr == KEEP_OPEN) + sock = 0; + else fprintf(stderr, "Illegal uw_request return code: %d\n", rr); break; @@ -267,7 +299,7 @@ } static void help(char *cmd) { - printf("Usage: %s [-p ] [-a ] [-t ] [-k]\nThe '-k' option turns on HTTP keepalive.\n", cmd); + printf("Usage: %s [-p ] [-a ] [-t ] [-k] [-q]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\n", cmd); } static void sigint(int signum) { @@ -291,10 +323,10 @@ my_addr.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP memset(my_addr.sin_zero, '\0', sizeof my_addr.sin_zero); - while ((opt = getopt(argc, argv, "hp:a:t:k")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:t:kq")) != -1) { switch (opt) { case '?': - fprintf(stderr, "Unknown command-line option"); + fprintf(stderr, "Unknown command-line option\n"); help(argv[0]); return 1; @@ -332,6 +364,10 @@ keepalive = 1; break; + case 'q': + quiet = 1; + break; + default: fprintf(stderr, "Unexpected getopt() behavior\n"); return 1; @@ -369,7 +405,8 @@ sin_size = sizeof their_addr; - printf("Listening on port %d....\n", uw_port); + if (!quiet) + printf("Listening on port %d....\n", uw_port); { pthread_t thread; @@ -393,18 +430,19 @@ int new_fd = accept(sockfd, (struct sockaddr *)&their_addr, &sin_size); if (new_fd < 0) { - fprintf(stderr, "Socket accept failed\n"); - return 1; + if (!quiet) + fprintf(stderr, "Socket accept failed\n"); + } else { + if (!quiet) + printf("Accepted connection.\n"); + + if (keepalive) { + int flag = 1; + setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); + } + + uw_enqueue(new_fd); } - - printf("Accepted connection.\n"); - - if (keepalive) { - int flag = 1; - setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); - } - - uw_enqueue(new_fd); } } @@ -419,10 +457,11 @@ } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { - if (uw_get_app(ctx)->db_begin(ctx)) - uw_error(ctx, FATAL, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); - uw_commit(ctx); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); } void uw_post_expunge(uw_context ctx, void *data) { diff -r c5143edaf3c7 -r 81bc76aa4acd src/c/request.c --- a/src/c/request.c Mon Dec 09 20:41:24 2013 -0500 +++ b/src/c/request.c Sat Jan 18 18:26:24 2014 -0500 @@ -116,8 +116,10 @@ return NULL; } while (r == UNLIMITED_RETRY || (r == BOUNDED_RETRY && retries_left > 0)); - if (r != FATAL && r != BOUNDED_RETRY) - uw_commit(ctx); + if (r != FATAL && r != BOUNDED_RETRY) { + if (uw_commit(ctx)) + r = UNLIMITED_RETRY; + } sleep(p->pdic.period); }; diff -r c5143edaf3c7 -r 81bc76aa4acd src/c/urweb.c --- a/src/c/urweb.c Mon Dec 09 20:41:24 2013 -0500 +++ b/src/c/urweb.c Sat Jan 18 18:26:24 2014 -0500 @@ -431,6 +431,7 @@ unsigned long long source_count; void *db; + int transaction_started; jmp_buf jmp_buf; @@ -440,7 +441,7 @@ const char *script_header; - int needs_push, needs_sig; + int needs_push, needs_sig, could_write_db; size_t n_deltas, used_deltas; delta *deltas; @@ -473,6 +474,9 @@ char error_message[ERROR_BUF_LEN]; int usedSig, needsResig; + + char *output_buffer; + size_t output_buffer_size; }; size_t uw_headers_max = SIZE_MAX; @@ -507,6 +511,7 @@ ctx->sz_inputs = ctx->n_subinputs = ctx->used_subinputs = 0; ctx->db = NULL; + ctx->transaction_started = 0; ctx->regions = NULL; @@ -515,6 +520,7 @@ ctx->script_header = ""; ctx->needs_push = 0; ctx->needs_sig = 0; + ctx->could_write_db = 1; ctx->source_count = 0; @@ -551,6 +557,9 @@ ctx->usedSig = 0; ctx->needsResig = 0; + ctx->output_buffer = malloc(1); + ctx->output_buffer_size = 1; + return ctx; } @@ -609,6 +618,8 @@ ctx->globals[i].free(ctx->globals[i].data); free(ctx->globals); + free(ctx->output_buffer); + free(ctx); } @@ -644,6 +655,7 @@ memset(ctx->inputs, 0, ctx->app->inputs_len * sizeof(input)); memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input)); ctx->used_subinputs = ctx->hasPostBody = ctx->isPost = 0; + ctx->transaction_started = 0; } failure_kind uw_begin_init(uw_context ctx) { @@ -730,50 +742,52 @@ char *uw_Basis_htmlifyString(uw_context, const char *); void uw_login(uw_context ctx) { - if (ctx->needs_push) { - char *id_s, *pass_s; - - if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client")) - && (pass_s = uw_Basis_requestHeader(ctx, "UrWeb-Pass"))) { - unsigned id = atoi(id_s); - int pass = atoi(pass_s); - client *c = find_client(id); - - if (c == NULL) - uw_error(ctx, FATAL, "Unknown client ID in HTTP headers (%s, %s)", uw_Basis_htmlifyString(ctx, id_s), uw_Basis_htmlifyString(ctx, pass_s)); - else { - use_client(c); - ctx->client = c; - - if (c->mode != USED) - uw_error(ctx, FATAL, "Stale client ID (%u) in subscription request", id); - if (c->pass != pass) - uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass); - } - } else { - client *c = new_client(); - - if (c == NULL) - uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients"); - + char *id_s, *pass_s; + + if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client")) + && (pass_s = uw_Basis_requestHeader(ctx, "UrWeb-Pass"))) { + unsigned id = atoi(id_s); + int pass = atoi(pass_s); + client *c = find_client(id); + + if (c == NULL) + uw_error(ctx, FATAL, "Unknown client ID in HTTP headers (%s, %s)", uw_Basis_htmlifyString(ctx, id_s), uw_Basis_htmlifyString(ctx, pass_s)); + else { use_client(c); - uw_copy_client_data(c->data, ctx->client_data); ctx->client = c; + + if (c->mode != USED) + uw_error(ctx, FATAL, "Stale client ID (%u) in subscription request", id); + if (c->pass != pass) + uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass); } + } else if (ctx->needs_push) { + client *c = new_client(); + + if (c == NULL) + uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients"); + + use_client(c); + uw_copy_client_data(c->data, ctx->client_data); + ctx->client = c; } } failure_kind uw_begin(uw_context ctx, char *path) { int r = setjmp(ctx->jmp_buf); - if (r == 0) { - if (ctx->app->db_begin(ctx)) + if (r == 0) + ctx->app->handle(ctx, path); + + return r; +} + +void uw_ensure_transaction(uw_context ctx) { + if (!ctx->transaction_started) { + if (ctx->app->db_begin(ctx, ctx->could_write_db)) uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); - - ctx->app->handle(ctx, path); + ctx->transaction_started = 1; } - - return r; } uw_Basis_client uw_Basis_self(uw_context ctx) { @@ -1184,6 +1198,10 @@ ctx->needs_sig = n; } +void uw_set_could_write_db(uw_context ctx, int n) { + ctx->could_write_db = n; +} + static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) { if (b->back - b->front < extra) { @@ -1287,17 +1305,20 @@ } int uw_send(uw_context ctx, int sock) { - int n = uw_really_send(sock, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start); - - if (n < 0) - return n; - - n = uw_really_send(sock, "\r\n", 2); - - if (n < 0) - return n; - - return uw_really_send(sock, ctx->page.start, ctx->page.front - ctx->page.start); + size_t target_length = (ctx->outHeaders.front - ctx->outHeaders.start) + 2 + (ctx->page.front - ctx->page.start); + + if (ctx->output_buffer_size < target_length) { + do { + ctx->output_buffer_size *= 2; + } while (ctx->output_buffer_size < target_length); + ctx->output_buffer = realloc(ctx->output_buffer, ctx->output_buffer_size); + } + + memcpy(ctx->output_buffer, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start); + memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start), "\r\n", 2); + memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start) + 2, ctx->page.start, ctx->page.front - ctx->page.start); + + return uw_really_send(sock, ctx->output_buffer, target_length); } int uw_print(uw_context ctx, int fd) { @@ -1340,10 +1361,18 @@ ctx->outHeaders.front += len; } +int uw_has_contentLength(uw_context ctx) { + return strstr(ctx->outHeaders.start, "Content-length: ") != NULL; +} + void uw_clear_headers(uw_context ctx) { uw_buffer_reset(&ctx->outHeaders); } +void uw_Basis_clear_page(uw_context ctx) { + uw_buffer_reset(&ctx->page); +} + static void uw_check_script(uw_context ctx, size_t extra) { ctx_uw_buffer_check(ctx, "script", &ctx->script, extra); } @@ -3205,10 +3234,15 @@ if (ctx->transactionals[i].free) ctx->transactionals[i].free(ctx->transactionals[i].data, will_retry); - return ctx->app ? ctx->app->db_rollback(ctx) : 0; -} - -static const char begin_xhtml[] = "\n\n"; + if (ctx->app && ctx->transaction_started) { + ctx->transaction_started = 0; + return ctx->app->db_rollback(ctx); + } else + return 0; +} + +const char uw_begin_xhtml[] = "\n\n"; +const char uw_begin_html5[] = ""; extern int uw_hash_blocksize; @@ -3233,13 +3267,13 @@ return s; } -void uw_commit(uw_context ctx) { +int uw_commit(uw_context ctx) { int i; char *sig; if (uw_has_error(ctx)) { uw_rollback(ctx, 0); - return; + return 0; } for (i = ctx->used_transactionals-1; i >= 0; --i) @@ -3248,7 +3282,7 @@ ctx->transactionals[i].commit(ctx->transactionals[i].data); if (uw_has_error(ctx)) { uw_rollback(ctx, 0); - return; + return 0; } } @@ -3258,13 +3292,24 @@ ctx->transactionals[i].commit(ctx->transactionals[i].data); if (uw_has_error(ctx)) { uw_rollback(ctx, 0); - return; + return 0; } } - if (ctx->app->db_commit(ctx)) { - uw_set_error_message(ctx, "Error running SQL COMMIT"); - return; + if (ctx->transaction_started) { + int code = ctx->app->db_commit(ctx); + + if (code) { + if (code == -1) + return 1; + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, 0); + + uw_set_error_message(ctx, "Error running SQL COMMIT"); + return 0; + } } for (i = 0; i < ctx->used_deltas; ++i) { @@ -3287,11 +3332,14 @@ uw_check(ctx, 1); *ctx->page.front = 0; - if (!ctx->returning_indirectly && !strncmp(ctx->page.start, begin_xhtml, sizeof begin_xhtml - 1)) { + if (!ctx->returning_indirectly + && (ctx->app->is_html5 + ? !strncmp(ctx->page.start, uw_begin_html5, sizeof uw_begin_html5 - 1) + : !strncmp(ctx->page.start, uw_begin_xhtml, sizeof uw_begin_xhtml - 1))) { char *s; // Splice script data into appropriate part of page, also adding if needed. - s = ctx->page.start + sizeof begin_xhtml - 1; + s = ctx->page.start + (ctx->app->is_html5 ? sizeof uw_begin_html5 - 1 : sizeof uw_begin_xhtml - 1); s = strchr(s, '<'); if (s == NULL) { // Weird. Document has no tags! @@ -3370,6 +3418,8 @@ } while (sig); } } + + return 0; } @@ -3428,8 +3478,8 @@ prev->next = next; else clients_used = next; - uw_reset(ctx); while (fk == UNLIMITED_RETRY) { + uw_reset(ctx); fk = uw_expunge(ctx, c->id, c->data); if (fk == UNLIMITED_RETRY) printf("Unlimited retry during expunge: %s\n", uw_error_message(ctx)); @@ -3451,8 +3501,7 @@ int r = setjmp(ctx->jmp_buf); if (r == 0) { - if (ctx->app->db_begin(ctx)) - uw_error(ctx, FATAL, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); ctx->app->initializer(ctx); if (ctx->app->db_commit(ctx)) uw_error(ctx, FATAL, "Error running SQL COMMIT"); @@ -3711,7 +3760,7 @@ uw_write_header(ctx, on_success); uw_write_header(ctx, "Content-Type: "); uw_write_header(ctx, mimeType); - uw_write_header(ctx, "\r\nContent-Length: "); + uw_write_header(ctx, "\r\nContent-length: "); ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX); sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)b.size, &len); ctx->outHeaders.front += len; @@ -3728,6 +3777,36 @@ longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); } +__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) { + cleanup *cl; + int len; + char *oldh; + + if (!ctx->allowed_to_return_indirectly) + uw_error(ctx, FATAL, "Tried to return a blob from an RPC"); + + ctx->returning_indirectly = 1; + oldh = old_headers(ctx); + uw_buffer_reset(&ctx->outHeaders); + + uw_write_header(ctx, on_success); + uw_write_header(ctx, "Content-Type: "); + uw_write_header(ctx, mimeType); + uw_write_header(ctx, "\r\nContent-length: "); + ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX); + sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len); + ctx->outHeaders.front += len; + uw_write_header(ctx, "\r\n"); + if (oldh) uw_write_header(ctx, oldh); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + __attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) { cleanup *cl; char *s; @@ -4031,9 +4110,13 @@ return uw_unit_v; } +static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; + uw_Basis_int uw_Basis_rand(uw_context ctx) { uw_Basis_int ret; + pthread_mutex_lock(&rand_mutex); int r = RAND_bytes((unsigned char *)&ret, sizeof ret); + pthread_mutex_unlock(&rand_mutex); if (r) return abs(ret); @@ -4085,8 +4168,7 @@ int r = setjmp(ctx->jmp_buf); if (r == 0) { - if (ctx->app->db_begin(ctx)) - uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); callback(ctx); } @@ -4133,8 +4215,7 @@ if (ctx->app->on_error) { if (r == 0) { - if (ctx->app->db_begin(ctx)) - uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); + uw_ensure_transaction(ctx); uw_buffer_reset(&ctx->outHeaders); if (on_success[0]) @@ -4143,7 +4224,7 @@ uw_write_header(ctx, "Status: "); uw_write_header(ctx, "500 Internal Server Error\r\n"); uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, begin_xhtml); + uw_write(ctx, ctx->app->is_html5 ? uw_begin_html5 : uw_begin_xhtml); ctx->app->on_error(ctx, msg); uw_write(ctx, ""); } diff -r c5143edaf3c7 -r 81bc76aa4acd src/checknest.sml --- a/src/checknest.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/checknest.sml Sat Jan 18 18:26:24 2014 -0500 @@ -56,7 +56,8 @@ | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes | EError (e, _) => eu e - | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType) + | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType + | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType) | ERedirect (e, _) => eu e | EWrite e => eu e @@ -118,7 +119,8 @@ | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc) | EError (e, t) => (EError (ae e, t), loc) - | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc) + | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc) + | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc) | ERedirect (e, t) => (ERedirect (ae e, t), loc) | EWrite e => (EWrite (ae e), loc) diff -r c5143edaf3c7 -r 81bc76aa4acd src/cjr.sml --- a/src/cjr.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/cjr.sml Sat Jan 18 18:26:24 2014 -0500 @@ -78,7 +78,7 @@ | ECase of exp * (pat * exp) list * { disc : typ, result : typ } | EError of exp * typ - | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} | ERedirect of exp * typ | EWrite of exp diff -r c5143edaf3c7 -r 81bc76aa4acd src/cjr_print.sml --- a/src/cjr_print.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/cjr_print.sml Sat Jan 18 18:26:24 2014 -0500 @@ -1628,7 +1628,7 @@ string "tmp;", newline, string "})"] - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "({", newline, string "uw_Basis_blob", @@ -1658,6 +1658,27 @@ string "tmp;", newline, string "})"] + | EReturnBlob {blob = NONE, mimeType, t} => + box [string "({", + newline, + string "uw_Basis_string", + space, + string "mimeType", + space, + string "=", + space, + p_exp' false false env mimeType, + string ";", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_return_blob_from_page(ctx, mimeType);", + newline, + string "tmp;", + newline, + string "})"] | ERedirect (e, t) => box [string "({", newline, @@ -2079,6 +2100,8 @@ newline, string "int dummy = (uw_begin_region(ctx), 0);", newline, + string "uw_ensure_transaction(ctx);", + newline, case prepared of NONE => @@ -2140,6 +2163,8 @@ p_exp' false false env dml, string ";", newline, + string "uw_ensure_transaction(ctx);", + newline, newline, #dml (Settings.currentDbms ()) (loc, mode)] | SOME {id, dml = dml'} => @@ -2159,8 +2184,10 @@ string ";"]) inputs, newline, + string "uw_ensure_transaction(ctx);", newline, - + newline, + #dmlPrepared (Settings.currentDbms ()) {loc = loc, id = id, dml = dml', @@ -2184,6 +2211,8 @@ newline, string "uw_Basis_int n;", newline, + string "uw_ensure_transaction(ctx);", + newline, case prepared of NONE => #nextval (Settings.currentDbms ()) {loc = loc, @@ -2204,6 +2233,8 @@ | ESetval {seq, count} => box [string "({", newline, + string "uw_ensure_transaction(ctx);", + newline, #setval (Settings.currentDbms ()) {loc = loc, seqE = p_exp' false false env seq, @@ -2970,11 +3001,18 @@ fun couldWrite ek = case ek of - Link => false + Link _ => false | Action ef => ef = ReadCookieWrite | Rpc ef => ef = ReadCookieWrite | Extern _ => false + fun couldWriteDb ek = + case ek of + Link ef => ef <> ReadOnly + | Action ef => ef <> ReadOnly + | Rpc ef => ef <> ReadOnly + | Extern ef => ef <> ReadOnly + val s = case Settings.getUrlPrefix () of "" => s @@ -3041,9 +3079,15 @@ newline] | _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");", newline, - string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", - newline, - string "uw_write(ctx, begin_xhtml);", + case side of + ServerOnly => box [] + | _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline], + string ("uw_write(ctx, uw_begin_" ^ + (if Settings.getIsHtml5 () then + "html5" + else + "xhtml") ^ ");"), newline, string "uw_mayReturnIndirectly(ctx);", newline, @@ -3058,6 +3102,10 @@ end, string "\");", newline]), + string "uw_set_could_write_db(ctx, ", + string (if couldWriteDb ek then "1" else "0"), + string ");", + newline, string "uw_set_needs_push(ctx, ", string (case side of ServerAndPullAndPush => "1" @@ -3170,7 +3218,8 @@ | EField (e, _) => expDb e | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes | EError (e, _) => expDb e - | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 | ERedirect (e, _) => expDb e | EWrite e => expDb e | ESeq (e1, e2) => expDb e1 orelse expDb e2 @@ -3319,7 +3368,7 @@ newline, string "static void uw_db_init(uw_context ctx) { };", newline, - string "static int uw_db_begin(uw_context ctx) { return 0; };", + string "static int uw_db_begin(uw_context ctx, int could_write) { return 0; };", newline, string "static void uw_db_close(uw_context ctx) { };", newline, @@ -3329,9 +3378,6 @@ newline, newline, - string "static const char begin_xhtml[] = \"\\n\\n\";", - newline, - newline, p_list_sep newline (fn x => x) pds, newline, @@ -3543,7 +3589,8 @@ "uw_handle", "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics", - "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\""], + "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"", + if Settings.getIsHtml5 () then "1" else "0"], string "};", newline] end diff -r c5143edaf3c7 -r 81bc76aa4acd src/cjrize.sml --- a/src/cjrize.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/cjrize.sml Sat Jan 18 18:26:24 2014 -0500 @@ -372,13 +372,20 @@ in ((L'.EError (e, t), loc), sm) end - | L.EReturnBlob {blob, mimeType, t} => + | L.EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, sm) = cifyExp (mimeType, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm) + end + | L.EReturnBlob {blob = SOME blob, mimeType, t} => let val (blob, sm) = cifyExp (blob, sm) val (mimeType, sm) = cifyExp (mimeType, sm) val (t, sm) = cifyTyp (t, sm) in - ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm) + ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm) end | L.ERedirect (e, t) => let diff -r c5143edaf3c7 -r 81bc76aa4acd src/compiler.sml --- a/src/compiler.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/compiler.sml Sat Jan 18 18:26:24 2014 -0500 @@ -864,6 +864,8 @@ | "alwaysInline" => Settings.addAlwaysInline arg | "noXsrfProtection" => Settings.addNoXsrfProtection arg | "timeFormat" => Settings.setTimeFormat arg + | "noMangleSql" => Settings.setMangleSql false + | "html5" => Settings.setIsHtml5 true | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () diff -r c5143edaf3c7 -r 81bc76aa4acd src/corify.sml --- a/src/corify.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/corify.sml Sat Jan 18 18:26:24 2014 -0500 @@ -1046,7 +1046,7 @@ | _ => false) args then L'.Extern L'.ReadCookieWrite else - L'.Link + L'.Link L'.ReadCookieWrite in ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds, (fn st => diff -r c5143edaf3c7 -r 81bc76aa4acd src/effectize.sml --- a/src/effectize.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/effectize.sml Sat Jan 18 18:26:24 2014 -0500 @@ -153,7 +153,7 @@ in (d, loop (writers, readers, pushers)) end - | DExport (Link, n, t) => + | DExport (Link _, n, t) => (case IM.find (writers, n) of NONE => () | SOME (loc, s) => @@ -162,7 +162,13 @@ else ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s ^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive"); - ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs)) + ((DExport (Link (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs)) | DExport (Action _, n, _) => ((DExport (Action (if IM.inDomain (writers, n) then if IM.inDomain (readers, n) then diff -r c5143edaf3c7 -r 81bc76aa4acd src/export.sig --- a/src/export.sig Mon Dec 09 20:41:24 2013 -0500 +++ b/src/export.sig Sat Jan 18 18:26:24 2014 -0500 @@ -33,7 +33,7 @@ | ReadWrite datatype export_kind = - Link + Link of effect | Action of effect | Rpc of effect | Extern of effect diff -r c5143edaf3c7 -r 81bc76aa4acd src/export.sml --- a/src/export.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/export.sml Sat Jan 18 18:26:24 2014 -0500 @@ -36,7 +36,7 @@ | ReadWrite datatype export_kind = - Link + Link of effect | Action of effect | Rpc of effect | Extern of effect @@ -49,7 +49,7 @@ fun p_export_kind ck = case ck of - Link => string "link" + Link ef => box [string "link(", p_effect ef, string ")"] | Action ef => box [string "action(", p_effect ef, string ")"] | Rpc ef => box [string "rpc(", p_effect ef, string ")"] | Extern ef => box [string "extern(", p_effect ef, string ")"] diff -r c5143edaf3c7 -r 81bc76aa4acd src/iflow.sml --- a/src/iflow.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/iflow.sml Sat Jan 18 18:26:24 2014 -0500 @@ -1587,7 +1587,8 @@ evalExp env e2 (fn e2 => k (Func (Other "cat", [e1, e2])))) | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) - | EReturnBlob {blob = b, mimeType = m, ...} => + | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization" + | EReturnBlob {blob = SOME b, mimeType = m, ...} => evalExp env b (fn b => (St.send (b, loc); evalExp env m @@ -2060,8 +2061,10 @@ end | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc) | EError (e1, t) => (EError (doExp env e1, t), loc) - | EReturnBlob {blob = b, mimeType = m, t} => - (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc) + | EReturnBlob {blob = NONE, mimeType = m, t} => + (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc) + | EReturnBlob {blob = SOME b, mimeType = m, t} => + (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc) | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc) | EWrite e1 => (EWrite (doExp env e1), loc) | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) diff -r c5143edaf3c7 -r 81bc76aa4acd src/jscomp.sml --- a/src/jscomp.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/jscomp.sml Sat Jan 18 18:26:24 2014 -0500 @@ -1118,12 +1118,18 @@ in ((EError (e, t), loc), st) end - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, st) = exp outer (mimeType, st) + in + ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st) + end + | EReturnBlob {blob = SOME blob, mimeType, t} => let val (blob, st) = exp outer (blob, st) val (mimeType, st) = exp outer (mimeType, st) in - ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) + ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st) end | ERedirect (e, t) => let diff -r c5143edaf3c7 -r 81bc76aa4acd src/main.mlton.sml --- a/src/main.mlton.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/main.mlton.sml Sat Jan 18 18:26:24 2014 -0500 @@ -56,8 +56,10 @@ raise Code OS.Process.success) fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); raise Code OS.Process.success) - fun printCCompiler () = (print ((Settings.getCCompiler ()) ^ "\n"); - raise Code OS.Process.success) + fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n"); + raise Code OS.Process.success) + fun printCInclude () = (print (Config.includ ^ "\n"); + raise Code OS.Process.success) fun doArgs args = case args of @@ -71,6 +73,8 @@ doArgs rest) | "-print-ccompiler" :: rest => printCCompiler () + | "-print-cinclude" :: rest => + printCInclude () | "-ccompiler" :: ccomp :: rest => (Settings.setCCompiler ccomp; doArgs rest) diff -r c5143edaf3c7 -r 81bc76aa4acd src/mono.sml --- a/src/mono.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/mono.sml Sat Jan 18 18:26:24 2014 -0500 @@ -93,7 +93,7 @@ | EStrcat of exp * exp | EError of exp * typ - | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} | ERedirect of exp * typ | EWrite of exp diff -r c5143edaf3c7 -r 81bc76aa4acd src/mono_print.sml --- a/src/mono_print.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/mono_print.sml Sat Jan 18 18:26:24 2014 -0500 @@ -235,18 +235,30 @@ space, p_typ env t, string ")"] - | EReturnBlob {blob, mimeType, t} => box [string "(blob", - space, - p_exp env blob, - space, - string "in", - space, - p_exp env mimeType, - space, - string ":", - space, - p_typ env t, - string ")"] + | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "(blob", + space, + p_exp env blob, + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] + | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob", + space, + string "", + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] | ERedirect (e, t) => box [string "(redirect", space, p_exp env e, diff -r c5143edaf3c7 -r 81bc76aa4acd src/mono_reduce.sml --- a/src/mono_reduce.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/mono_reduce.sml Sat Jan 18 18:26:24 2014 -0500 @@ -101,7 +101,8 @@ | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes | EError _ => true - | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2 | ERedirect (e, _) => impure e | EStrcat (e1, e2) => impure e1 orelse impure e2 @@ -492,7 +493,8 @@ | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 | EError (e, _) => summarize d e @ [Abort] - | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] + | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort] + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] | ERedirect (e, _) => summarize d e @ [Abort] | EWrite e => summarize d e @ [WritePage] diff -r c5143edaf3c7 -r 81bc76aa4acd src/mono_util.sml --- a/src/mono_util.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/mono_util.sml Sat Jan 18 18:26:24 2014 -0500 @@ -261,14 +261,20 @@ S.map2 (mft t, fn t' => (EError (e', t'), loc))) - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = NONE, mimeType, t} => + S.bind2 (mfe ctx mimeType, + fn mimeType' => + S.map2 (mft t, + fn t' => + (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc))) + | EReturnBlob {blob = SOME blob, mimeType, t} => S.bind2 (mfe ctx blob, fn blob' => S.bind2 (mfe ctx mimeType, fn mimeType' => S.map2 (mft t, fn t' => - (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc)))) + (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc)))) | ERedirect (e, t) => S.bind2 (mfe ctx e, fn e' => @@ -495,7 +501,8 @@ | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes) | EStrcat (e1, e2) => (appl e1; appl e2) | EError (e1, _) => appl e1 - | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2) + | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2) | ERedirect (e1, _) => appl e1 | EWrite e1 => appl e1 | ESeq (e1, e2) => (appl e1; appl e2) diff -r c5143edaf3c7 -r 81bc76aa4acd src/monoize.sml --- a/src/monoize.sml Mon Dec 09 20:41:24 2013 -0500 +++ b/src/monoize.sml Sat Jan 18 18:26:24 2014 -0500 @@ -215,6 +215,7 @@ | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc) | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xhead") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "xtable") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc) @@ -1266,6 +1267,12 @@ in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) end + | L.EFfi ("Basis", "show_id") => + 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_char") => ((L'.EFfi ("Basis", "charToString"), loc), fm) | L.EFfi ("Basis", "show_bool") => @@ -1617,7 +1624,7 @@ (L'.EPrim (Prim.String (String.concatWith ", " (map (fn (x, _) => - "uw_" ^ monoNameLc env x + Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" @@ -1661,7 +1668,7 @@ in ((L'.EPrim (Prim.String ("UNIQUE (" ^ String.concatWith ", " - (map (fn (x, t) => "uw_" ^ monoNameLc env x + (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then "(767)" @@ -1707,19 +1714,19 @@ (L'.EAbs ("m", mat, mat, (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), [((L'.PPrim (Prim.String ""), loc), - (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)), + (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))), loc), string), - ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)), + ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))), loc), string)], loc)), ((L'.PWild, loc), (L'.ERecord [("1", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1 + (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1) ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2 + (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2) ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)], @@ -1850,7 +1857,7 @@ strcat [sc "INSERT INTO ", (L'.ERel 1, loc), sc " (", - strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields), + strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields), sc ") VALUES (", strcatComma (map (fn (x, _) => (L'.EField ((L'.ERel 0, loc), @@ -1877,7 +1884,7 @@ (L'.ERel 1, loc), sc " AS T_T SET ", strcatComma (map (fn (x, _) => - strcat [sc ("uw_" ^ x + strcat [sc (Settings.mangleSql x ^ " = "), (L'.EField ((L'.ERel 2, @@ -1891,7 +1898,7 @@ (L'.ERel 1, loc), sc " SET ", strcatComma (map (fn (x, _) => - strcat [sc ("uw_" ^ x + strcat [sc (Settings.mangleSql x ^ " = "), (L'.EFfiApp ("Basis", "unAs", [((L'.EField @@ -2083,14 +2090,14 @@ strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), - sc (" AS uw_" ^ x) + sc (" AS " ^ Settings.mangleSql x) ]) sexps @ map (fn (x, xts) => strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ ".uw_" - ^ x')) + ^ "." + ^ Settings.mangleSql x')) xts)) stables), (L'.ECase (gf "From", [((L'.PPrim (Prim.String ""), loc), @@ -2124,8 +2131,8 @@ strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ ".uw_" - ^ x')) + ^ "" + ^ Settings.mangleSql x')) xts)) grouped) ], @@ -2619,7 +2626,7 @@ _), _), _), _), (L.CName tab, _)), _), - (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm) + (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2631,7 +2638,7 @@ _), _), _), _), _), _), - (L.CName nm, _)) => ((L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm)), loc), fm) + (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm) | L.ECApp ( (L.ECApp ( @@ -3264,7 +3271,7 @@ val (style, fm) = monoExp (env, st, fm) style val (dynStyle, fm) = monoExp (env, st, fm) dynStyle - val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active"] + val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"] fun isSome (e, _) = case e of @@ -3600,6 +3607,16 @@ fm) | _ => raise Fail "Monoize: Bad attributes") + | "script" => + (case attrs of + [("Code", e, _)] => + ((L'.EStrcat + ((L'.EPrim (Prim.String ("")), loc)), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad