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