summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Patrick Hurst <phurst@mit.edu>2014-01-18 18:26:24 -0500
committerGravatar Patrick Hurst <phurst@mit.edu>2014-01-18 18:26:24 -0500
commit4caa5f98146d40715a96aeab6c4ff65e7a0f38b6 (patch)
tree96e059e285d059c3c9373fdb081041a72121d767 /src
parent1ce3acd70b3527add32015267cc916e920661dbb (diff)
parent6787b686afe5fd3e65b3d377d4c363b4cd086dad (diff)
Merge in upstream changes.
Diffstat (limited to 'src')
-rw-r--r--src/c/cgi.c7
-rw-r--r--src/c/fastcgi.c7
-rw-r--r--src/c/http.c135
-rw-r--r--src/c/request.c6
-rw-r--r--src/c/urweb.c199
-rw-r--r--src/checknest.sml6
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml71
-rw-r--r--src/cjrize.sml11
-rw-r--r--src/compiler.sml2
-rw-r--r--src/corify.sml2
-rw-r--r--src/effectize.sml10
-rw-r--r--src/export.sig2
-rw-r--r--src/export.sml4
-rw-r--r--src/iflow.sml9
-rw-r--r--src/jscomp.sml10
-rw-r--r--src/main.mlton.sml8
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml36
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/mono_util.sml13
-rw-r--r--src/monoize.sml109
-rw-r--r--src/mysql.sml101
-rw-r--r--src/postgres.sml45
-rw-r--r--src/prepare.sml9
-rw-r--r--src/settings.sig12
-rw-r--r--src/settings.sml31
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/tag.sml10
29 files changed, 617 insertions, 250 deletions
diff --git a/src/c/cgi.c b/src/c/cgi.c
index 52c0ca2e..539b83c2 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -134,10 +134,11 @@ void uw_copy_client_data(void *dst, void *src) {
}
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 --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index 9e3c8d7e..5c80d3ae 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -632,10 +632,11 @@ void uw_copy_client_data(void *dst, void *src) {
}
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 --git a/src/c/http.c b/src/c/http.c
index f954a879..25d2a320 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -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_error(void *data, const char *fmt, ...) {
}
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
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) {
- printf("Connection closed.\n");
- close(sock);
- sock = 0;
- break;
- }
+ if (r == 0) {
+ if (!quiet)
+ printf("Connection closed.\n");
+ close(sock);
+ sock = 0;
+ break;
+ }
- back += r;
- *back = 0;
+ 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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
s = headers;
while ((s2 = strchr(s, '\r'))) {
+ if (s2 == s) {
+ *s = 0;
+ break;
+ }
+
s = s2;
if (s[1] == 0)
@@ -218,15 +234,14 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
// 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 *worker(void *data) {
}
static void help(char *cmd) {
- printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k]\nThe '-k' option turns on HTTP keepalive.\n", cmd);
+ printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-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 @@ int main(int argc, char *argv[]) {
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 @@ int main(int argc, char *argv[]) {
keepalive = 1;
break;
+ case 'q':
+ quiet = 1;
+ break;
+
default:
fprintf(stderr, "Unexpected getopt() behavior\n");
return 1;
@@ -369,7 +405,8 @@ int main(int argc, char *argv[]) {
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 main(int argc, char *argv[]) {
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");
- printf("Accepted connection.\n");
+ if (keepalive) {
+ int flag = 1;
+ setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int));
+ }
- if (keepalive) {
- int flag = 1;
- setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int));
+ uw_enqueue(new_fd);
}
-
- uw_enqueue(new_fd);
}
}
@@ -419,10 +457,11 @@ void uw_copy_client_data(void *dst, void *src) {
}
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 --git a/src/c/request.c b/src/c/request.c
index 5973d979..b925cc3c 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -116,8 +116,10 @@ static void *periodic_loop(void *data) {
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 --git a/src/c/urweb.c b/src/c/urweb.c
index fb6d28c6..d7761f7a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -431,6 +431,7 @@ struct uw_context {
unsigned long long source_count;
void *db;
+ int transaction_started;
jmp_buf jmp_buf;
@@ -440,7 +441,7 @@ struct uw_context {
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 @@ struct uw_context {
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 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
ctx->sz_inputs = ctx->n_subinputs = ctx->used_subinputs = 0;
ctx->db = NULL;
+ ctx->transaction_started = 0;
ctx->regions = NULL;
@@ -515,6 +520,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
ctx->script_header = "";
ctx->needs_push = 0;
ctx->needs_sig = 0;
+ ctx->could_write_db = 1;
ctx->source_count = 0;
@@ -551,6 +557,9 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
ctx->usedSig = 0;
ctx->needsResig = 0;
+ ctx->output_buffer = malloc(1);
+ ctx->output_buffer_size = 1;
+
return ctx;
}
@@ -609,6 +618,8 @@ void uw_free(uw_context ctx) {
ctx->globals[i].free(ctx->globals[i].data);
free(ctx->globals);
+ free(ctx->output_buffer);
+
free(ctx);
}
@@ -644,6 +655,7 @@ void uw_reset(uw_context ctx) {
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,52 +742,54 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) {
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;
+ char *id_s, *pass_s;
- 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");
+ 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))
- uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
-
+ 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->transaction_started = 1;
+ }
+}
+
uw_Basis_client uw_Basis_self(uw_context ctx) {
if (ctx->client == NULL)
uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code");
@@ -1184,6 +1198,10 @@ void uw_set_needs_sig(uw_context ctx, int n) {
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_pagelen(uw_context ctx) {
}
int uw_send(uw_context ctx, int sock) {
- int n = uw_really_send(sock, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start);
+ size_t target_length = (ctx->outHeaders.front - ctx->outHeaders.start) + 2 + (ctx->page.front - ctx->page.start);
- if (n < 0)
- return n;
+ 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);
+ }
- n = uw_really_send(sock, "\r\n", 2);
+ 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);
- if (n < 0)
- return n;
-
- return uw_really_send(sock, 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 @@ void uw_write_header(uw_context ctx, uw_Basis_string s) {
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 @@ int uw_rollback(uw_context ctx, int will_retry) {
if (ctx->transactionals[i].free)
ctx->transactionals[i].free(ctx->transactionals[i].data, will_retry);
- return ctx->app ? ctx->app->db_rollback(ctx) : 0;
+ if (ctx->app && ctx->transaction_started) {
+ ctx->transaction_started = 0;
+ return ctx->app->db_rollback(ctx);
+ } else
+ return 0;
}
-static const char begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
+const char uw_begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
+const char uw_begin_html5[] = "<!DOCTYPE html><html>";
extern int uw_hash_blocksize;
@@ -3233,13 +3267,13 @@ static char *find_sig(char *haystack) {
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 @@ void uw_commit(uw_context ctx) {
ctx->transactionals[i].commit(ctx->transactionals[i].data);
if (uw_has_error(ctx)) {
uw_rollback(ctx, 0);
- return;
+ return 0;
}
}
@@ -3258,13 +3292,24 @@ void uw_commit(uw_context ctx) {
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 @@ void uw_commit(uw_context ctx) {
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 <head> 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 @@ void uw_commit(uw_context ctx) {
} while (sig);
}
}
+
+ return 0;
}
@@ -3428,8 +3478,8 @@ void uw_prune_clients(uw_context ctx) {
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 @@ failure_kind uw_initialize(uw_context ctx) {
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 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
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 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
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 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) {
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 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
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 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
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 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
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, "</html>");
}
diff --git a/src/checknest.sml b/src/checknest.sml
index 05ad8e9a..fa418d89 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -56,7 +56,8 @@ fun expUses globals =
| 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 @@ fun annotateExp globals =
| 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 --git a/src/cjr.sml b/src/cjr.sml
index 3a37b26f..8cbabdcc 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -78,7 +78,7 @@ datatype exp' =
| 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 --git a/src/cjr_print.sml b/src/cjr_print.sml
index bc8f1be6..05dce35e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1628,7 +1628,7 @@ and p_exp' par tail env (e, loc) =
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 @@ and p_exp' par tail env (e, loc) =
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 @@ and p_exp' par tail env (e, loc) =
newline,
string "int dummy = (uw_begin_region(ctx), 0);",
newline,
+ string "uw_ensure_transaction(ctx);",
+ newline,
case prepared of
NONE =>
@@ -2140,6 +2163,8 @@ and p_exp' par tail env (e, loc) =
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 @@ and p_exp' par tail env (e, loc) =
string ";"])
inputs,
newline,
+ string "uw_ensure_transaction(ctx);",
newline,
-
+ newline,
+
#dmlPrepared (Settings.currentDbms ()) {loc = loc,
id = id,
dml = dml',
@@ -2184,6 +2211,8 @@ and p_exp' par tail env (e, loc) =
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 @@ and p_exp' par tail env (e, loc) =
| 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 p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
| 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 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
newline,
newline,
- string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
- newline,
- newline,
p_list_sep newline (fn x => x) pds,
newline,
@@ -3543,7 +3589,8 @@ fun p_file env (ds, ps) =
"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 --git a/src/cjrize.sml b/src/cjrize.sml
index 0f4bdb42..d153feff 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -372,13 +372,20 @@ fun cifyExp (eAll as (e, loc), sm) =
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 --git a/src/compiler.sml b/src/compiler.sml
index b2635e5e..0ffab01c 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -864,6 +864,8 @@ fun parseUrp' accLibs fname =
| "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 --git a/src/corify.sml b/src/corify.sml
index c06d62ca..c1c60045 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1046,7 +1046,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
| _ => 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 --git a/src/effectize.sml b/src/effectize.sml
index 6ced952b..d711e620 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -153,7 +153,7 @@ fun effectize file =
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 @@ fun effectize file =
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 --git a/src/export.sig b/src/export.sig
index 9bcfa0d4..881459c5 100644
--- a/src/export.sig
+++ b/src/export.sig
@@ -33,7 +33,7 @@ datatype effect =
| ReadWrite
datatype export_kind =
- Link
+ Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
diff --git a/src/export.sml b/src/export.sml
index 5d200894..a99d0b70 100644
--- a/src/export.sml
+++ b/src/export.sml
@@ -36,7 +36,7 @@ datatype effect =
| ReadWrite
datatype export_kind =
- Link
+ Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
@@ -49,7 +49,7 @@ fun p_effect ef =
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 --git a/src/iflow.sml b/src/iflow.sml
index 0c94cd47..461dc956 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1587,7 +1587,8 @@ fun evalExp env (e as (_, loc)) k =
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 @@ fun check (file : file) =
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 --git a/src/jscomp.sml b/src/jscomp.sml
index e0d87a8e..4a2c0365 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -1118,12 +1118,18 @@ fun process (file : file) =
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 --git a/src/main.mlton.sml b/src/main.mlton.sml
index d176efcc..b0c4e03f 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -56,8 +56,10 @@ fun oneRun args =
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 @@ fun oneRun args =
doArgs rest)
| "-print-ccompiler" :: rest =>
printCCompiler ()
+ | "-print-cinclude" :: rest =>
+ printCInclude ()
| "-ccompiler" :: ccomp :: rest =>
(Settings.setCCompiler ccomp;
doArgs rest)
diff --git a/src/mono.sml b/src/mono.sml
index f5260419..78740d70 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -93,7 +93,7 @@ datatype exp' =
| 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 --git a/src/mono_print.sml b/src/mono_print.sml
index a5156aca..c81b362a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -235,18 +235,30 @@ fun p_exp' par env (e, _) =
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 "<page>",
+ 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 --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0dfb7558..e96a0e8f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -101,7 +101,8 @@ fun impure (e, _) =
| 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 @@ fun reduce (file : file) =
| 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 --git a/src/mono_util.sml b/src/mono_util.sml
index cb871891..cc531625 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -261,14 +261,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
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 @@ fun appLoc f =
| 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 --git a/src/monoize.sml b/src/monoize.sml
index 3df6ec92..000ba7b6 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -215,6 +215,7 @@ fun monoType env =
| 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
- ^ ".uw_"
- ^ x'))
+ ^ ""
+ ^ Settings.mangleSql x'))
xts)) grouped)
],
@@ -2619,7 +2626,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
_), _),
- (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
| _ => raise Fail "Monoize: Bad <active> attributes")
+ | "script" =>
+ (case attrs of
+ [("Code", e, _)] =>
+ ((L'.EStrcat
+ ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc),
+ (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
+ (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+ fm)
+ | _ => raise Fail "Monoize: Bad <script> attributes")
+
| "submit" => normal ("input type=\"submit\"", NONE)
| "image" => normal ("input type=\"image\"", NONE)
| "button" => normal ("input type=\"submit\"", NONE)
@@ -4036,6 +4053,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EError ((L'.ERel 0, loc), t), loc)), loc),
fm)
end
+ | L.EApp (
+ (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
+ (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
+ let
+ val t = monoType env t
+ val un = (L'.TRecord [], loc)
+ val (e, fm) = monoExp (env, st, fm) e
+ in
+ ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
+ (L'.EAbs ("_", un, t,
+ (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
+ (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
+ (L'.EReturnBlob {blob = NONE,
+ mimeType = (L'.ERel 1, loc),
+ t = t}, loc)), loc)), loc)), loc)),
+ loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
let
val t = monoType env t
@@ -4045,7 +4080,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
(L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
(L'.EAbs ("_", un, t,
- (L'.EReturnBlob {blob = (L'.ERel 2, loc),
+ (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
mimeType = (L'.ERel 1, loc),
t = t}, loc)), loc)), loc)), loc),
fm)
@@ -4333,7 +4368,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSqlTable s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4351,7 +4386,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSqlTable s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4369,7 +4404,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSql s
val e = (L'.EPrim (Prim.String s), loc)
in
SOME (Env.pushENamed env x n t NONE s,
@@ -4407,7 +4442,13 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val un = (L'.TRecord [], loc)
val t = if MonoUtil.Exp.exists {typ = fn _ => false,
- exp = fn L'.EFfiApp ("Basis", "periodic", _) => true
+ exp = fn L'.EFfiApp ("Basis", "periodic", _) =>
+ (if #persistent (Settings.currentProtocol ()) then
+ ()
+ else
+ E.errorAt (#2 e1)
+ ("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ").");
+ true)
| _ => false} e1 then
(L'.TFfi ("Basis", "int"), loc)
else
@@ -4512,7 +4553,7 @@ fun monoize env file =
val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
- (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
+ (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
^ (case v of
Client => ""
| Channel => " >> 32")
@@ -4523,10 +4564,10 @@ fun monoize env file =
foldl (fn ((x, v), e) =>
(L'.ESeq (
(L'.EDml ((L'.EStrcat (
- (L'.EPrim (Prim.String ("UPDATE uw_"
- ^ tab
- ^ " SET uw_"
- ^ x
+ (L'.EPrim (Prim.String ("UPDATE "
+ ^ Settings.mangleSql tab
+ ^ " SET "
+ ^ Settings.mangleSql x
^ " = NULL WHERE ")), loc),
cond (x, v)), loc), L'.Error), loc),
e), loc))
@@ -4543,8 +4584,8 @@ fun monoize env file =
(L'.EStrcat ((L'.EPrim (Prim.String " OR "),
loc),
cond eb), loc)), loc))
- (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
- ^ tab
+ (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
+ ^ Settings.mangleSql tab
^ " WHERE ")), loc),
cond eb), loc)
ebs, L'.Error), loc),
@@ -4577,11 +4618,11 @@ fun monoize env file =
(L'.ESeq (
(L'.EDml ((L'.EPrim (Prim.String
(foldl (fn ((x, _), s) =>
- s ^ ", uw_" ^ x ^ " = NULL")
+ s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
("UPDATE uw_"
^ tab
- ^ " SET uw_"
- ^ x
+ ^ " SET "
+ ^ Settings.mangleSql x
^ " = NULL")
ebs)), loc), L'.Error), loc),
e), loc)
@@ -4591,8 +4632,8 @@ fun monoize env file =
[] => e
| eb :: ebs =>
(L'.ESeq (
- (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_"
- ^ tab)), loc), L'.Error), loc),
+ (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
+ ^ Settings.mangleSql tab)), loc), L'.Error), loc),
e), loc)
in
e
diff --git a/src/mysql.sml b/src/mysql.sml
index c70a1cdd..e34efbd4 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -76,7 +76,11 @@ val ident = String.translate (fn #"'" => "PRIME"
fun checkRel (table, checkNullable) (s, xts) =
let
val sl = CharVector.map Char.toLower s
- val both = "table_name IN ('" ^ sl ^ "', '" ^ s ^ "')"
+ val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+ String.substring (sl, 1, size sl - 2)
+ else
+ sl
+ val both = "LOWER(table_name) = ('" ^ sl ^ "')"
val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both
@@ -85,14 +89,17 @@ fun checkRel (table, checkNullable) (s, xts) =
" AND (",
case String.concatWith " OR "
(map (fn (x, t) =>
- String.concat ["(column_name IN ('uw_",
- CharVector.map
- Char.toLower (ident x),
- "', 'uw_",
- ident x,
- "') AND data_type = '",
- p_sql_type_base t,
- "'",
+ String.concat ["(LOWER(column_name) = '",
+ Settings.mangleSqlCatalog
+ (CharVector.map
+ Char.toLower (ident x)),
+ "' AND data_type ",
+ case p_sql_type_base t of
+ "bigint" =>
+ "IN ('bigint', 'int')"
+ | "longtext" =>
+ "IN ('longtext', 'varchar')"
+ | s => "= '" ^ s ^ "'",
if checkNullable then
(" AND is_nullable = '"
^ (if isNotNull t then
@@ -109,7 +116,7 @@ fun checkRel (table, checkNullable) (s, xts) =
val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ",
both,
- " AND column_name LIKE 'uw_%'"]
+ " AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
in
box [string "if (mysql_query(conn->conn, \"",
string q,
@@ -174,7 +181,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' does not exist.\");",
newline],
string "}",
@@ -249,7 +256,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has the wrong column types.\");",
newline],
string "}",
@@ -324,7 +331,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has extra columns.\");",
newline],
string "}",
@@ -529,7 +536,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
| SOME n => string (Int.toString n),
string ", ",
stringOf unix_socket,
- string ", 0) == NULL) {",
+ string ", CLIENT_MULTI_STATEMENTS) == NULL) {",
newline,
box [string "char msg[1024];",
newline,
@@ -544,6 +551,23 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
string "}",
newline,
+ newline,
+ string "if (mysql_set_character_set(mysql, \"utf8\")) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, mysql_error(mysql), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ string "mysql_close(mysql);",
+ newline,
+ string "uw_error(ctx, FATAL, ",
+ string "\"Error setting UTF-8 character set for MySQL connection: %s\", msg);"],
+ newline,
+ string "}",
+ newline,
+ newline,
string "conn = calloc(1, sizeof(uw_conn));",
newline,
string "conn->conn = mysql;",
@@ -577,14 +601,12 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
newline,
- string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE\")",
- newline,
- string " || mysql_query(conn->conn, \"BEGIN\");",
+ string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE; BEGIN\") ? 1 : (mysql_next_result(conn->conn), 0);",
newline,
string "}",
newline,
@@ -847,11 +869,20 @@ fun queryCommon {loc, query, cols, doCols} =
newline,
newline,
- string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Error executing query: %s\\n%s\", ",
- query,
- string ", mysql_error(conn->conn));",
+ string "if (mysql_stmt_execute(stmt)) {",
+ newline,
+ box [string "if (mysql_errno(conn->conn) == 1213)",
+ newline,
+ box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
+ newline],
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error executing query: %s\\n%s\", ",
+ query,
+ string ", mysql_error(conn->conn));",
+ newline],
+ string "}",
newline,
newline,
@@ -1201,15 +1232,21 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
box []]
fun dmlCommon {loc, dml, mode} =
- box [string "if (mysql_stmt_execute(stmt)) ",
- case mode of
- Settings.Error => box [string "uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Error executing DML: %s\\n%s\", ",
- dml,
- string ", mysql_error(conn->conn));"]
- | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
- newline,
+ box [string "if (mysql_stmt_execute(stmt)) {",
+ box [string "if (mysql_errno(conn->conn) == 1213)",
+ newline,
+ box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
+ newline],
+ newline,
+ case mode of
+ Settings.Error => box [string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error executing DML: %s\\n%s\", ",
+ dml,
+ string ", mysql_error(conn->conn));"]
+ | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
+ newline],
+ string "}",
newline]
fun dml (loc, mode) =
diff --git a/src/postgres.sml b/src/postgres.sml
index 41529173..b97226c1 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -63,6 +63,10 @@ fun p_sql_type_base t =
fun checkRel (table, checkNullable) (s, xts) =
let
val sl = CharVector.map Char.toLower s
+ val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+ String.substring (sl, 1, size sl - 2)
+ else
+ sl
val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
^ sl ^ "'"
@@ -72,12 +76,15 @@ fun checkRel (table, checkNullable) (s, xts) =
"' AND (",
case String.concatWith " OR "
(map (fn (x, t) =>
- String.concat ["(column_name = 'uw_",
- CharVector.map
- Char.toLower (ident x),
+ String.concat ["(LOWER(column_name) = '",
+ Settings.mangleSqlCatalog
+ (CharVector.map
+ Char.toLower (ident x)),
(case p_sql_type_base t of
"bigint" =>
- "' AND data_type IN ('bigint', 'numeric')"
+ "' AND data_type IN ('bigint', 'numeric', 'integer')"
+ | "text" =>
+ "' AND data_type IN ('text', 'character varying')"
| t =>
String.concat ["' AND data_type = '",
t,
@@ -98,7 +105,7 @@ fun checkRel (table, checkNullable) (s, xts) =
val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
sl,
- "' AND column_name LIKE 'uw_%'"]
+ "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
in
box [string "res = PQexec(conn, \"",
string q,
@@ -140,7 +147,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' does not exist.\");",
newline],
string "}",
@@ -191,7 +198,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has the wrong column types.\");",
newline],
string "}",
@@ -243,7 +250,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has extra columns.\");",
newline],
string "}",
@@ -402,11 +409,11 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "PGconn *conn = uw_get_db(ctx);",
newline,
- string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
+ string "PGresult *res = PQexec(conn, could_write ? \"BEGIN ISOLATION LEVEL SERIALIZABLE\" : \"BEGIN ISOLATION LEVEL SERIALIZABLE, READ ONLY\");",
newline,
newline,
string "if (res == NULL) return 1;",
@@ -438,7 +445,23 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- box [string "PQclear(res);",
+ box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
+ box [newline,
+ string "PQclear(res);",
+ newline,
+ string "return -1;",
+ newline],
+ string "}",
+ newline,
+ string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
+ box [newline,
+ string "PQclear(res);",
+ newline,
+ string "return -1;",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
newline,
string "return 1;",
newline],
diff --git a/src/prepare.sml b/src/prepare.sml
index 7f55959c..89cd1b43 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -201,7 +201,14 @@ fun prepExp (e as (_, loc), st) =
| EReturnBlob {blob, mimeType, t} =>
let
- val (blob, st) = prepExp (blob, st)
+ val (blob, st) = case blob of
+ NONE => (blob, st)
+ | SOME blob =>
+ let
+ val (b, st) = prepExp (blob, st)
+ in
+ (SOME b, st)
+ end
val (mimeType, st) = prepExp (mimeType, st)
in
((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
diff --git a/src/settings.sig b/src/settings.sig
index 40cfbacc..a7a41447 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -258,6 +258,14 @@ signature SETTINGS = sig
val setTimeFormat : string -> unit
val getTimeFormat : unit -> string
- val getCCompiler : unit -> string
- val setCCompiler : string -> unit
+ val getCCompiler : unit -> string
+ val setCCompiler : string -> unit
+
+ val setMangleSql : bool -> unit
+ val mangleSql : string -> string
+ val mangleSqlCatalog : string -> string
+ val mangleSqlTable : string -> string
+
+ val setIsHtml5 : bool -> unit
+ val getIsHtml5 : unit -> bool
end
diff --git a/src/settings.sml b/src/settings.sml
index 948906ed..93f54427 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -187,7 +187,10 @@ val benignBase = basis ["get_cookie",
"preventDefault",
"stopPropagation",
"fresh",
- "giveFocus"]
+ "giveFocus",
+ "currentUrlHasPost",
+ "currentUrlHasQueryString",
+ "currentUrl"]
val benign = ref benignBase
fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
@@ -299,8 +302,10 @@ val jsFuncsBase = basisM [("alert", "alert"),
("isblank", "isBlank"),
("isspace", "isSpace"),
("isxdigit", "isXdigit"),
+ ("isprint", "isPrint"),
("tolower", "toLower"),
("toupper", "toUpper"),
+ ("ord", "ord"),
("checkUrl", "checkUrl"),
("bless", "bless"),
@@ -691,4 +696,28 @@ val timeFormat = ref "%c"
fun setTimeFormat v = timeFormat := v
fun getTimeFormat () = !timeFormat
+fun lowercase s =
+ case s of
+ "" => ""
+ | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+fun capitalize s =
+ case s of
+ "" => ""
+ | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+val mangle = ref true
+fun setMangleSql x = mangle := x
+fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
+ else if #name (currentDbms ()) = "mysql" then capitalize s
+ else lowercase s
+fun mangleSql s = if !mangle then "uw_" ^ s
+ else if #name (currentDbms ()) = "mysql" then lowercase s
+ else lowercase s
+fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
+
+val html5 = ref false
+fun setIsHtml5 b = html5 := b
+fun getIsHtml5 () = !html5
+
end
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 09c4c683..c138415b 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -344,7 +344,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
diff --git a/src/tag.sml b/src/tag.sml
index 9c4807c6..6fef50d1 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -41,9 +41,9 @@ structure SM = BinaryMapFn(struct
fun kind (k, s) = (k, s)
fun con (c, s) = (c, s)
-fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form");
+fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multiple modes (link, form, RPC handler).");
TextIO.output (TextIO.stdErr,
- "Make sure that the signature of the containing module hides any form handlers.\n"))
+ "Make sure that the signature of the containing module hides any form/RPC handlers.\n"))
fun exp env (e, s) =
let
@@ -145,7 +145,7 @@ fun exp env (e, s) =
end
in
case x of
- (CName "Link", _) => tagIt' (Link, "Link")
+ (CName "Link", _) => tagIt' (Link ReadCookieWrite, "Link")
| (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
| _ => ((x, e, t), s)
end)
@@ -180,7 +180,7 @@ fun exp env (e, s) =
| EFfiApp ("Basis", "url", [(e, t)]) =>
let
- val (e, s) = tagIt (e, Link, "Url", s)
+ val (e, s) = tagIt (e, Link ReadCookieWrite, "Url", s)
in
(EFfiApp ("Basis", "url", [(e, t)]), s)
end
@@ -201,7 +201,7 @@ fun exp env (e, s) =
case eo of
SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
let
- val (e, s) = tagIt (e', Link, "Url", s)
+ val (e, s) = tagIt (e', Link ReadCookieWrite, "Url", s)
in
(EFfiApp ("Basis", "url", [(e, t)]), s)
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-21 19:38:22 +0000