diff options
40 files changed, 710 insertions, 258 deletions
@@ -1,4 +1,16 @@ ======== +20131231 +======== + +- Performance optimizations for Ur/Web's standalone HTTP servers +- New command-line options for those servers: '-k' and '-q' +- New HTML pseudo-tag: <script> +- Trying to recv() from a different client's channel now triggers a run-time + error. +- New compiler command-line argument: -print-cinclude +- Bug fixes and improvements to optimizations, error messages, and documentation + +======== 20131124 ======== diff --git a/configure.ac b/configure.ac index fbf6b162..795e46a6 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20131124]) +AC_INIT([urweb], [20131231]) WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS diff --git a/doc/manual.tex b/doc/manual.tex index ac12c3b7..0a088436 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -64,7 +64,7 @@ apt-get install mlton libssl-dev To build programs that access SQL databases, you also need one of these client libraries for supported backends. \begin{verbatim} -apt-get install libpq-dev libmysqlclient15-dev libsqlite3-dev +apt-get install libpq-dev libmysqlclient-dev libsqlite3-dev \end{verbatim} It is also possible to access the modules of the Ur/Web compiler interactively, within Standard ML of New Jersey. To install the prerequisites in Debian testing: @@ -77,7 +77,7 @@ To begin an interactive session with the Ur compiler modules, run \texttt{make s To run an SQL-backed application with a backend besides SQLite, you will probably want to install one of these servers. \begin{verbatim} -apt-get install postgresql-8.4 mysql-server-5.1 +apt-get install postgresql mysql-server \end{verbatim} To use the Emacs mode, you must have a modern Emacs installed. We assume that you already know how to do this, if you're in the business of looking for an Emacs mode. The demo generation facility of the compiler will also call out to Emacs to syntax-highlight code, and that process depends on the \texttt{htmlize} module, which can be installed in Debian testing via: @@ -146,6 +146,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{effectful Module.ident} registers an FFI function or transaction as having side effects. The optimizer avoids removing, moving, or duplicating calls to such functions. This is the default behavior for \texttt{transaction}-based types. \item \texttt{exe FILENAME} sets the filename to which to write the output executable. The default for file \texttt{P.urp} is \texttt{P.exe}. \item \texttt{ffi FILENAME} reads the file \texttt{FILENAME.urs} to determine the interface to a new FFI module. The name of the module is calculated from \texttt{FILENAME} in the same way as for normal source files. See the files \texttt{include/urweb/urweb\_cpp.h} and \texttt{src/c/urweb.c} for examples of C headers and implementations for FFI modules. In general, every type or value \texttt{Module.ident} becomes \texttt{uw\_Module\_ident} in C. +\item \texttt{html5} activates work-in-progress support for generating HTML5 instead of XHTML. For now, this option only affects the first few tokens on any page, which are always the same. \item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules. \item \texttt{jsFunc Module.ident=name} gives the JavaScript name of an FFI value. \item \texttt{library FILENAME} parses \texttt{FILENAME.urp} and merges its contents with the rest of the current file's contents. If \texttt{FILENAME.urp} doesn't exist, the compiler also tries \texttt{FILENAME/lib.urp}. @@ -170,6 +171,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{linker CMD} sets \texttt{CMD} as the command line prefix to use for linking C object files. The command line will be completed with a space-separated list of \texttt{.o} and \texttt{.a} files, \texttt{-L} and \texttt{-l} flags, and finally with a \texttt{-o} flag to set the location where the executable should be written. \item \texttt{minHeap NUMBYTES} sets the initial size for thread-local heaps used in handling requests. These heaps grow automatically as needed (up to any maximum set with \texttt{limit}), but each regrow requires restarting the request handling process. \item \texttt{monoInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function. (This is one of two options for one of two intermediate languages within the compiler.) +\item \texttt{noMangleSql} avoids adding a \texttt{uw\_} prefix in front of each identifier in SQL. With this experimental feature, the burden is on the programmer to avoid naming tables or columns after SQL keywords! \item \texttt{noXsrfProtection URIPREFIX} turns off automatic cross-site request forgery protection for the page handler identified by the given URI prefix. This will avoid checking cryptographic signatures on cookies, which is generally a reasonable idea for some pages, such as login pages that are going to discard all old cookie values, anyway. \item \texttt{onError Module.var} changes the handling of fatal application errors. Instead of displaying a default, ugly error 500 page, the error page will be generated by calling function \texttt{Module.var} on a piece of XML representing the error message. The error handler should have type $\mt{xbody} \to \mt{transaction} \; \mt{page}$. Note that the error handler \emph{cannot} be in the application's main module, since that would register it as explicitly callable via URLs. \item \texttt{path NAME=VALUE} creates a mapping from \texttt{NAME} to \texttt{VALUE}. This mapping may be used at the beginnings of filesystem paths given to various other configuration directives. A path like \texttt{\$NAME/rest} is expanded to \texttt{VALUE/rest}. There is an initial mapping from the empty name (for paths like \texttt{\$/list}) to the directory where the Ur/Web standard library is installed. If you accept the default \texttt{configure} options, this directory is \texttt{/usr/local/lib/urweb/ur}. @@ -275,6 +277,8 @@ sqlite3 path/to/database/file <app.sql \item \texttt{-print-ccompiler}: Print the C compiler being used. +\item \texttt{-print-cinclude}: Print the name of the directory where C/C++ header files are installed. + \item \texttt{-protocol [http|cgi|fastcgi|static]}: Set the protocol that the generated application speaks. \begin{itemize} \item \texttt{http}: This is the default. It is for building standalone web servers that can be accessed by web browsers directly. @@ -2103,6 +2107,14 @@ $$\begin{array}{l} \mt{val} \; \mt{stopPropagation} : \mt{transaction} \; \mt{unit} \end{array}$$ +Finally, here is an HTML tag to leave a marker in the \cd{<head>} of a document asking for some side-effecting code to be run. This pattern is \emph{much} less common in Ur/Web applications than in normal HTML/JavaScript applications; see Section \ref{signals} for the more idiomatic, functional way of manipulating the visible page. + +$$\begin{array}{l} + \mt{val} \; \mt{script} : \mt{unit} \to \mt{tag} \; [\mt{Code} = \mt{transaction} \; \mt{unit}] \; \mt{head} \; [] \; [] \; [] +\end{array}$$ + +Note that the Ur/Web version of \cd{<script>} is used like \cd{<script code=\{...\}/>}, rather than \cd{<script>...</script>}. + \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 @@ $$\begin{array}{l} \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 --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index 330f7755..cd80b0e7 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -82,7 +82,7 @@ typedef struct { 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 @@ typedef struct { uw_periodic *periodics; // 0-terminated array uw_Basis_string time_format; + + int is_html5; } uw_app; #define ERROR_BUF_LEN 1024 diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 9105a86a..1bb6b2f2 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -37,9 +37,11 @@ void uw_set_on_success(char *); 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 @@ uw_Basis_string uw_Basis_maybe_onunload(struct uw_context *, uw_Basis_string); 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 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string); 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 @@ uw_Basis_postBody uw_getPostBody(struct uw_context *); 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_fieldValue(struct uw_context *, uw_Basis_postField); 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 --git a/lib/js/urweb.js b/lib/js/urweb.js index 59708150..6830945a 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -35,10 +35,11 @@ function isAlnum(c) { return isAlpha(c) || isDigit(c); } 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 @@ function rv(chn, parse, k) { er("May not 'recv' in main thread of 'code' for <active>"); 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 --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 36d2effa..c94f2ba6 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -785,6 +785,7 @@ val redirect : t ::: Type -> url -> transaction t 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 dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] = 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 --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 diff --git a/tests/ahead.ur b/tests/ahead.ur new file mode 100644 index 00000000..29938d07 --- /dev/null +++ b/tests/ahead.ur @@ -0,0 +1,8 @@ +fun main () : transaction page = return <xml> + <head> + <script code={alert "Hi!"}/> + </head> + <body> + <active code={alert "Bye!"; return <xml/>}/> + </body> +</xml> diff --git a/tests/channelThief.ur b/tests/channelThief.ur new file mode 100644 index 00000000..1893979a --- /dev/null +++ b/tests/channelThief.ur @@ -0,0 +1,32 @@ +table t : { Ch : channel string } + +fun go () = + let + fun overwrite () = + dml (DELETE FROM t WHERE TRUE); + ch <- channel; + dml (INSERT INTO t (Ch) VALUES ({[ch]})); + return ch + + fun retrieve () = + oneRowE1 (SELECT (t.Ch) FROM t) + + fun transmit () = + ch <- retrieve (); + send ch "Test" + + fun listenOn ch = + s <- recv ch; + alert s + in + ch <- overwrite (); + return <xml><body onload={listenOn ch}> + <button value="overwrite" onclick={fn _ => ch <- rpc (overwrite ()); listenOn ch}/> + <button value="retrieve" onclick={fn _ => ch <- rpc (retrieve ()); listenOn ch}/> + <button value="transmit" onclick={fn _ => rpc (transmit ())}/> + </body></xml> + end + +fun main () = return <xml><body> + <form><submit action={go}/></form> +</body></xml> diff --git a/tests/channelThief.urp b/tests/channelThief.urp new file mode 100644 index 00000000..dee402d4 --- /dev/null +++ b/tests/channelThief.urp @@ -0,0 +1,5 @@ +database dbname=test +sql channelThief.sql +rewrite url ChannelThief/* + +channelThief diff --git a/tests/channelThief.urs b/tests/channelThief.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/channelThief.urs @@ -0,0 +1 @@ +val main : unit -> transaction page |