summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/Makefile.am2
-rw-r--r--src/c/cgi.c21
-rw-r--r--src/c/fastcgi.c12
-rw-r--r--src/c/http.c13
-rw-r--r--src/c/request.c4
-rw-r--r--src/c/static.c12
-rw-r--r--src/c/urweb.c216
-rw-r--r--src/cjr_print.sml54
-rw-r--r--src/compiler.sig6
-rw-r--r--src/compiler.sml50
-rw-r--r--src/css.sml1
-rw-r--r--src/demo.sml4
-rw-r--r--src/elab_env.sml2
-rw-r--r--src/elaborate.sml3
-rw-r--r--src/filecache.sig35
-rw-r--r--src/filecache.sml230
-rw-r--r--src/main.mlton.sml343
-rw-r--r--src/mono_util.sml6
-rw-r--r--src/monoize.sml35
-rw-r--r--src/mysql.sml3
-rw-r--r--src/postgres.sml14
-rw-r--r--src/settings.sig11
-rw-r--r--src/settings.sml29
-rw-r--r--src/sources3
-rw-r--r--src/sqlite.sml10
25 files changed, 910 insertions, 209 deletions
diff --git a/src/c/Makefile.am b/src/c/Makefile.am
index f4d9bef8..58f5153c 100644
--- a/src/c/Makefile.am
+++ b/src/c/Makefile.am
@@ -7,7 +7,7 @@ liburweb_fastcgi_la_SOURCES = fastcgi.c fastcgi.h
liburweb_static_la_SOURCES = static.c
AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES)
-AM_CFLAGS = -Wimplicit -Wall -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS)
+AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS)
liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \
-export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)'
liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS)
diff --git a/src/c/cgi.c b/src/c/cgi.c
index d060532c..4d0f82b0 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -17,6 +17,8 @@ static char *uppercased;
static size_t uppercased_len;
static char *get_header(void *data, const char *h) {
+ (void)data;
+
size_t len = strlen(h);
char *s, *r;
const char *saved_h = h;
@@ -41,16 +43,21 @@ static char *get_header(void *data, const char *h) {
}
static char *get_env(void *data, const char *name) {
+ (void)data;
return getenv(name);
}
-static void on_success(uw_context ctx) { }
+static void on_success(uw_context ctx) {
+ (void)ctx;
+}
static void on_failure(uw_context ctx) {
uw_write_header(ctx, "Status: 500 Internal Server Error\r\n");
}
static void log_error(void *data, const char *fmt, ...) {
+ (void)data;
+
va_list ap;
va_start(ap, fmt);
@@ -58,11 +65,16 @@ static void log_error(void *data, const char *fmt, ...) {
}
static void log_debug(void *data, const char *fmt, ...) {
+ (void)data;
+ (void)fmt;
}
static uw_loggers ls = {NULL, log_error, log_debug};
int main(int argc, char *argv[]) {
+ (void)argc;
+ (void)argv;
+
uw_context ctx = uw_request_new_context(0, &uw_application, &ls);
uw_request_context rc = uw_new_request_context();
request_result rr;
@@ -130,12 +142,17 @@ void *uw_init_client_data() {
}
void uw_free_client_data(void *data) {
+ (void)data;
}
void uw_copy_client_data(void *dst, void *src) {
+ (void)dst;
+ (void)src;
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
+ (void)data;
+
uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
@@ -144,6 +161,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
}
void uw_post_expunge(uw_context ctx, void *data) {
+ (void)ctx;
+ (void)data;
}
int uw_supports_direct_status = 0;
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index c37debf7..196b3d51 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -127,7 +127,9 @@ static FCGI_Record *fastcgi_recv(FCGI_Input *i) {
}
}
-static void on_success(uw_context ctx) { }
+static void on_success(uw_context ctx) {
+ (void)ctx;
+}
static void on_failure(uw_context ctx) {
uw_write_header(ctx, "Status: 500 Internal Server Error\r\n");
@@ -554,6 +556,7 @@ static void help(char *cmd) {
}
static void sigint(int signum) {
+ (void)signum;
printf("Exiting....\n");
exit(0);
}
@@ -674,12 +677,17 @@ void *uw_init_client_data() {
}
void uw_free_client_data(void *data) {
+ (void)data;
}
void uw_copy_client_data(void *dst, void *src) {
+ (void)dst;
+ (void)src;
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
+ (void)data;
+
uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
@@ -688,6 +696,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
}
void uw_post_expunge(uw_context ctx, void *data) {
+ (void)ctx;
+ (void)data;
}
int uw_supports_direct_status = 0;
diff --git a/src/c/http.c b/src/c/http.c
index 21ad809f..72685508 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -46,6 +46,7 @@ static char *get_header(void *data, const char *h) {
}
static char *get_env(void *data, const char *name) {
+ (void)data;
return getenv(name);
}
@@ -58,6 +59,8 @@ static void on_failure(uw_context ctx) {
}
static void log_error(void *data, const char *fmt, ...) {
+ (void)data;
+
va_list ap;
va_start(ap, fmt);
@@ -65,6 +68,8 @@ static void log_error(void *data, const char *fmt, ...) {
}
static void log_debug(void *data, const char *fmt, ...) {
+ (void)data;
+
if (!quiet) {
va_list ap;
va_start(ap, fmt);
@@ -332,6 +337,7 @@ static void help(char *cmd) {
}
static void sigint(int signum) {
+ (void)signum;
printf("Exiting....\n");
exit(0);
}
@@ -542,12 +548,17 @@ void *uw_init_client_data() {
}
void uw_free_client_data(void *data) {
+ (void)data;
}
void uw_copy_client_data(void *dst, void *src) {
+ (void)dst;
+ (void)src;
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
+ (void)data;
+
uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
@@ -556,6 +567,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
}
void uw_post_expunge(uw_context ctx, void *data) {
+ (void)ctx;
+ (void)data;
}
int uw_supports_direct_status = 1;
diff --git a/src/c/request.c b/src/c/request.c
index a7f23851..3e7ac34c 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -78,6 +78,8 @@ uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls) {
}
static void *ticker(void *data) {
+ (void)data;
+
while (1) {
usleep(100000);
++uw_time;
@@ -133,6 +135,8 @@ static unsigned long long stackSize;
int pthread_create_big(pthread_t *outThread, void *foo, void *threadFunc, void *arg)
{
+ (void)foo;
+
if (stackSize > 0) {
int err;
pthread_attr_t stackSizeAttribute;
diff --git a/src/c/static.c b/src/c/static.c
index d70881e2..76fe4129 100644
--- a/src/c/static.c
+++ b/src/c/static.c
@@ -8,6 +8,8 @@
extern uw_app uw_application;
static void log_(void *data, const char *fmt, ...) {
+ (void)data;
+
va_list ap;
va_start(ap, fmt);
@@ -17,6 +19,8 @@ static void log_(void *data, const char *fmt, ...) {
static uw_loggers loggers = {NULL, log_, log_};
static char *get_header(void *data, const char *h) {
+ (void)data;
+ (void)h;
return NULL;
}
@@ -56,15 +60,23 @@ void *uw_init_client_data() {
}
void uw_free_client_data(void *data) {
+ (void)data;
}
void uw_copy_client_data(void *dst, void *src) {
+ (void)dst;
+ (void)src;
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
+ (void)ctx;
+ (void)cli;
+ (void)data;
}
void uw_post_expunge(uw_context ctx, void *data) {
+ (void)ctx;
+ (void)data;
}
int uw_supports_direct_status = 0;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 6f2dde38..e7efae38 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -13,8 +13,8 @@
#include <stdint.h>
#include <sys/types.h>
#include <sys/socket.h>
-#include <openssl/des.h>
#include <openssl/rand.h>
+#include <openssl/sha.h>
#include <time.h>
#include <math.h>
@@ -514,6 +514,11 @@ struct uw_context {
uw_Sqlcache_Unlock *cacheUnlock;
int remoteSock;
+
+ int file_cache_missed;
+ // Set if we are recovering from a miss in the file cache in handling an SQL
+ // query that only returns hashes of files. If so, this time around we will
+ // run queries to return actual file contents instead.
};
size_t uw_headers_max = SIZE_MAX;
@@ -608,6 +613,8 @@ uw_context uw_init(int id, uw_loggers *lg) {
ctx->cacheUnlock = NULL;
+ ctx->file_cache_missed = 0;
+
return ctx;
}
@@ -1519,6 +1526,7 @@ uw_Basis_string uw_Basis_maybe_onunload(uw_context ctx, uw_Basis_string s) {
}
const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) {
+ (void)u;
if (ctx->client == NULL) {
if (ctx->needs_sig) {
char *sig = ctx->app->cookie_sig(ctx);
@@ -1847,6 +1855,7 @@ char *uw_Basis_attrifyChar(uw_context ctx, uw_Basis_char c) {
}
char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) {
+ (void)ctx;
return s;
}
@@ -1973,6 +1982,7 @@ char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) {
}
char *uw_Basis_urlifyBool(uw_context ctx, uw_Basis_bool b) {
+ (void)ctx;
if (b == uw_Basis_False)
return "0";
else
@@ -2093,6 +2103,8 @@ static char *uw_unurlify_advance(char *s) {
}
uw_Basis_int uw_Basis_unurlifyInt(uw_context ctx, char **s) {
+ (void)ctx;
+
char *new_s = uw_unurlify_advance(*s);
uw_Basis_int r;
@@ -2102,6 +2114,8 @@ uw_Basis_int uw_Basis_unurlifyInt(uw_context ctx, char **s) {
}
uw_Basis_float uw_Basis_unurlifyFloat(uw_context ctx, char **s) {
+ (void)ctx;
+
char *new_s = uw_unurlify_advance(*s);
uw_Basis_float r;
@@ -2165,6 +2179,8 @@ static uw_Basis_string uw_unurlifyString_to(int fromClient, uw_context ctx, char
}
uw_Basis_bool uw_Basis_unurlifyBool(uw_context ctx, char **s) {
+ (void)ctx;
+
char *new_s = uw_unurlify_advance(*s);
uw_Basis_bool r;
@@ -2192,6 +2208,7 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context ctx, char **s) {
}
uw_Basis_unit uw_Basis_unurlifyUnit(uw_context ctx, char **s) {
+ (void)ctx;
*s = uw_unurlify_advance(*s);
return uw_unit_v;
}
@@ -2345,6 +2362,7 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) {
}
uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) {
+ (void)ctx;
if (b == uw_Basis_False)
return "False";
else
@@ -2428,10 +2446,13 @@ uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_i
}
uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) {
+ (void)ctx;
return strlen(s);
}
uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int n) {
+ (void)ctx;
+
while (n > 0) {
if (*s == 0)
return uw_Basis_False;
@@ -2444,10 +2465,12 @@ uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int
}
uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) {
+ (void)ctx;
return strchr(s, ch);
}
uw_Basis_int uw_Basis_strcspn(uw_context ctx, uw_Basis_string s, uw_Basis_string chs) {
+ (void)ctx;
return strcspn(s, chs);
}
@@ -2794,6 +2817,7 @@ uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) {
}
char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) {
+ (void)ctx;
if (b == uw_Basis_False)
return "FALSE";
else
@@ -2914,6 +2938,7 @@ uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) {
}
uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) {
+ (void)ctx;
if (b == uw_Basis_False)
return "False";
else
@@ -2979,6 +3004,7 @@ uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) {
}
uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) {
+ (void)ctx;
static uw_Basis_bool true = uw_Basis_True;
static uw_Basis_bool false = uw_Basis_False;
@@ -3353,6 +3379,8 @@ static delta *allocate_delta(uw_context ctx, unsigned client) {
}
uw_Basis_channel uw_Basis_new_channel(uw_context ctx, uw_unit u) {
+ (void)u;
+
if (ctx->client == NULL)
uw_error(ctx, FATAL, "Attempt to create channel on request not associated with a persistent connection");
@@ -3622,6 +3650,8 @@ int uw_commit(uw_context ctx) {
}
}
+ ctx->file_cache_missed = 0;
+
return 0;
}
@@ -3929,37 +3959,45 @@ int uw_streq(uw_Basis_string s1, uw_Basis_string s2) {
}
uw_Basis_string uw_Basis_sigString(uw_context ctx, uw_unit u) {
+ (void)u;
ctx->usedSig = 1;
return ctx->app->cookie_sig(ctx);
}
uw_Basis_string uw_Basis_fileName(uw_context ctx, uw_Basis_file f) {
+ (void)ctx;
return f.name;
}
uw_Basis_string uw_Basis_fileMimeType(uw_context ctx, uw_Basis_file f) {
+ (void)ctx;
return f.type;
}
uw_Basis_int uw_Basis_blobSize(uw_context ctx, uw_Basis_blob b) {
+ (void)ctx;
return b.size;
}
uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) {
+ (void)ctx;
uw_Basis_blob b = {strlen(s), s};
return b;
}
uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) {
+ (void)ctx;
return f.data;
}
uw_Basis_string uw_Basis_postType(uw_context ctx, uw_Basis_postBody pb) {
+ (void)ctx;
return pb.type;
}
uw_Basis_string uw_Basis_postData(uw_context ctx, uw_Basis_postBody pb) {
+ (void)ctx;
return pb.data;
}
@@ -4156,24 +4194,29 @@ uw_Basis_string uw_Basis_mstrcat(uw_context ctx, ...) {
const uw_Basis_time uw_Basis_minTime = {};
uw_Basis_time uw_Basis_now(uw_context ctx) {
+ (void)ctx;
uw_Basis_time r = { time(NULL) };
return r;
}
uw_Basis_time uw_Basis_addSeconds(uw_context ctx, uw_Basis_time tm, uw_Basis_int n) {
+ (void)ctx;
tm.seconds += n;
return tm;
}
uw_Basis_int uw_Basis_diffInSeconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) {
+ (void)ctx;
return difftime(tm2.seconds, tm1.seconds);
}
uw_Basis_int uw_Basis_toMilliseconds(uw_context ctx, uw_Basis_time tm) {
+ (void)ctx;
return tm.seconds * 1000 + tm.microseconds / 1000;
}
uw_Basis_time uw_Basis_fromMilliseconds(uw_context ctx, uw_Basis_int n) {
+ (void)ctx;
uw_Basis_time tm = {n / 1000, n % 1000 * 1000};
return tm;
}
@@ -4183,10 +4226,12 @@ uw_Basis_int uw_Basis_diffInMilliseconds(uw_context ctx, uw_Basis_time tm1, uw_B
}
uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) {
+ (void)ctx;
return tm.seconds;
}
uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) {
+ (void)ctx;
struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day,
.tm_hour = hour, .tm_min = minute, .tm_sec = second,
.tm_isdst = -1 };
@@ -4195,42 +4240,49 @@ uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_
}
uw_Basis_int uw_Basis_datetimeYear(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_year + 1900;
}
uw_Basis_int uw_Basis_datetimeMonth(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_mon;
}
uw_Basis_int uw_Basis_datetimeDay(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_mday;
}
uw_Basis_int uw_Basis_datetimeHour(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_hour;
}
uw_Basis_int uw_Basis_datetimeMinute(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_min;
}
uw_Basis_int uw_Basis_datetimeSecond(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_sec;
}
uw_Basis_int uw_Basis_datetimeDayOfWeek(uw_context ctx, uw_Basis_time time) {
+ (void)ctx;
struct tm tm;
localtime_r(&time.seconds, &tm);
return tm.tm_wday;
@@ -4272,66 +4324,82 @@ void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*))
}
uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isalnum((int)c);
}
uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isalpha((int)c);
}
uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isblank((int)c);
}
uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!iscntrl((int)c);
}
uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isdigit((int)c);
}
uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isgraph((int)c);
}
uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!islower((int)c);
}
uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isprint((int)c);
}
uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!ispunct((int)c);
}
uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isspace((int)c);
}
uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isupper((int)c);
}
uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return !!isxdigit((int)c);
}
uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return tolower((int)c);
}
uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return toupper((int)c);
}
uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) {
+ (void)ctx;
return (unsigned char)c;
}
uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) {
+ (void)ctx;
return n;
}
@@ -4431,16 +4499,13 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
return r;
}
-uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) {
- char buf[14];
- return uw_strdup(ctx, DES_fcrypt(key, salt, buf));
-}
-
uw_Basis_bool uw_Basis_eq_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
+ (void)ctx;
return !!(t1.seconds == t2.seconds && t1.microseconds == t2.microseconds);
}
uw_Basis_bool uw_Basis_lt_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
+ (void)ctx;
return !!(t1.seconds < t2.seconds || (t1.seconds == t2.seconds && t1.microseconds < t2.microseconds));
}
@@ -4505,66 +4570,82 @@ uw_Basis_string uw_Basis_fresh(uw_context ctx) {
}
uw_Basis_float uw_Basis_floatFromInt(uw_context ctx, uw_Basis_int n) {
+ (void)ctx;
return n;
}
uw_Basis_int uw_Basis_ceil(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return ceil(n);
}
uw_Basis_int uw_Basis_trunc(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return trunc(n);
}
uw_Basis_int uw_Basis_round(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return round(n);
}
uw_Basis_int uw_Basis_floor(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return floor(n);
}
uw_Basis_float uw_Basis_pow(uw_context ctx, uw_Basis_float n, uw_Basis_float m) {
+ (void)ctx;
return pow(n,m);
}
uw_Basis_float uw_Basis_sqrt(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return sqrt(n);
}
uw_Basis_float uw_Basis_sin(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return sin(n);
}
uw_Basis_float uw_Basis_cos(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return cos(n);
}
uw_Basis_float uw_Basis_log(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return log(n);
}
uw_Basis_float uw_Basis_exp(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return exp(n);
}
uw_Basis_float uw_Basis_asin(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return asin(n);
}
uw_Basis_float uw_Basis_acos(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return acos(n);
}
uw_Basis_float uw_Basis_atan(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return atan(n);
}
uw_Basis_float uw_Basis_atan2(uw_context ctx, uw_Basis_float n, uw_Basis_float m) {
+ (void)ctx;
return atan2(n, m);
}
uw_Basis_float uw_Basis_abs(uw_context ctx, uw_Basis_float n) {
+ (void)ctx;
return fabs(n);
}
@@ -4612,14 +4693,17 @@ uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) {
}
uw_Basis_string uw_Basis_fieldName(uw_context ctx, uw_Basis_postField f) {
+ (void)ctx;
return f.name;
}
uw_Basis_string uw_Basis_fieldValue(uw_context ctx, uw_Basis_postField f) {
+ (void)ctx;
return f.value;
}
uw_Basis_string uw_Basis_remainingFields(uw_context ctx, uw_Basis_postField f) {
+ (void)ctx;
return f.remaining;
}
@@ -4754,6 +4838,7 @@ static char *uw_Sqlcache_keyCopy(char *buf, char *key) {
// The NUL-terminated prefix of [key] below always looks something like "_k1_k2_k3..._kn".
uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) {
+ (void)ctx;
int doBump = random() % 1024 == 0;
if (doBump) {
pthread_rwlock_wrlock(&cache->lockIn);
@@ -4836,6 +4921,8 @@ static void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw
}
static void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) {
+ (void)cache;
+ (void)keys;
}
static void uw_Sqlcache_commit(void *data) {
@@ -4854,6 +4941,7 @@ static void uw_Sqlcache_commit(void *data) {
}
static void uw_Sqlcache_free(void *data, int dontCare) {
+ (void)dontCare;
uw_context ctx = (uw_context)data;
uw_Sqlcache_Update *update = ctx->cacheUpdate;
while (update) {
@@ -4929,6 +5017,7 @@ void uw_Sqlcache_store(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys, uw
}
void uw_Sqlcache_flush(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) {
+ (void)ctx;
// A flush has to happen immediately so that subsequent stores in the same transaction fail.
// This is safe to do because we will always call [uw_Sqlcache_wlock] earlier.
// If the transaction fails, the only harm done is a few extra cache misses.
@@ -4978,3 +5067,118 @@ int strcmp_nullsafe(const char *str1, const char *str2) {
else
return 1;
}
+
+static int is_valid_hash(uw_Basis_string hash) {
+ for (; *hash; ++hash)
+ if (!isxdigit(*hash))
+ return 0;
+
+ return 1;
+}
+
+uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) {
+ char *dir = ctx->app->file_cache, path[1024], tempfile[1024];
+ unsigned char *res, *hash;
+ char *hash_encoded;
+ int fd, len, i;
+ ssize_t written_so_far = 0;
+
+ if (!dir)
+ return uw_unit_v;
+
+ hash = uw_malloc(ctx, SHA512_DIGEST_LENGTH);
+ res = SHA512((unsigned char *)contents.data, contents.size, hash);
+ if (!res)
+ uw_error(ctx, FATAL, "Can't hash file contents");
+
+ hash_encoded = uw_malloc(ctx, SHA512_DIGEST_LENGTH * 2 + 1);
+ for (i = 0; i < SHA512_DIGEST_LENGTH; ++i)
+ sprintf(hash_encoded + 2 * i, "%02x", (int)hash[i]);
+ hash_encoded[SHA512_DIGEST_LENGTH * 2] = 0;
+
+ len = snprintf(tempfile, sizeof tempfile, "%s/tmpXXXXXX", dir);
+ if (len < 0 || len >= sizeof tempfile)
+ uw_error(ctx, FATAL, "Error assembling file path for cache (temporary)");
+
+ fd = mkstemp(tempfile);
+ if (fd < 0)
+ uw_error(ctx, FATAL, "Error creating temporary file for cache");
+
+ while (written_so_far < contents.size) {
+ ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far);
+ if (written_just_now <= 0) {
+ close(fd);
+ uw_error(ctx, FATAL, "Error writing all bytes to cached file");
+ }
+ written_so_far += written_just_now;
+ }
+
+ close(fd);
+
+ len = snprintf(path, sizeof path, "%s/%s", dir, hash_encoded);
+ if (len < 0 || len >= sizeof path)
+ uw_error(ctx, FATAL, "Error assembling file path for cache");
+
+ if (rename(tempfile, path))
+ uw_error(ctx, FATAL, "Error renaming temporary file into cache");
+
+ return uw_unit_v;
+}
+
+uw_Basis_blob uw_Basis_check_filecache(uw_context ctx, uw_Basis_string hash) {
+ char path[1024], *dir = ctx->app->file_cache, *filedata;
+ int len;
+ long size, read_so_far = 0;
+ FILE *fp;
+ uw_Basis_blob res;
+
+ // Hashes come formatted for printing by Postgres, which means they start with
+ // two extra characters. Let's remove them.
+ if (!hash[0] || !hash[1])
+ uw_error(ctx, FATAL, "Hash to check against file cache came in not in Postgres format: %s", hash);
+ hash += 2;
+
+ if (!dir)
+ uw_error(ctx, FATAL, "Checking file cache when no directory is set");
+
+ if (!is_valid_hash(hash))
+ uw_error(ctx, FATAL, "Checking file cache with invalid hash %s", hash);
+
+ len = snprintf(path, sizeof path, "%s/%s", dir, hash);
+ if (len < 0 || len >= sizeof path)
+ uw_error(ctx, FATAL, "Error assembling file path for cache");
+
+ fp = fopen(path, "r");
+ if (!fp) {
+ ctx->file_cache_missed = 1;
+ uw_error(ctx, UNLIMITED_RETRY, "Missed in the file cache for hash %s", hash);
+ }
+ uw_push_cleanup(ctx, (void (*)(void *))fclose, fp);
+
+ if (fseek(fp, 0L, SEEK_END))
+ uw_error(ctx, FATAL, "Error seeking to end of cached file");
+
+ size = ftell(fp);
+ if (size < 0)
+ uw_error(ctx, FATAL, "Error getting size of cached file");
+
+ rewind(fp);
+ filedata = uw_malloc(ctx, size);
+
+ while (read_so_far < size) {
+ size_t just_read = fread(filedata + read_so_far, 1, size - read_so_far, fp);
+ if (just_read <= 0)
+ uw_error(ctx, FATAL, "Error reading all bytes of cached file");
+ read_so_far += just_read;
+ }
+
+ uw_pop_cleanup(ctx);
+
+ res.size = size;
+ res.data = filedata;
+ return res;
+}
+
+uw_Basis_bool uw_Basis_filecache_missed(uw_context ctx) {
+ return !!(ctx->file_cache_missed);
+}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 53587ff7..87d2576c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -482,6 +482,11 @@ fun isFile (t : typ) =
TFfi ("Basis", "file") => true
| _ => false
+fun isString (t : typ) =
+ case #1 t of
+ TFfi ("Basis", "string") => true
+ | _ => false
+
fun p_sql_type t = string (Settings.p_sql_ctype t)
fun getPargs (e, _) =
@@ -654,7 +659,16 @@ fun unurlify fromClient env (t, loc) =
doEm rest,
string ")"]
in
- doEm xncs
+ box [string "(",
+ string request,
+ string "[0] == '/' ? ++",
+ string request,
+ string " : ",
+ string request,
+ string ",",
+ newline,
+ doEm xncs,
+ string ")"]
end
| TDatatype (Option, i, xncs) =>
@@ -2181,6 +2195,25 @@ and p_exp' par tail env (e, loc) =
string ";"])
inputs,
newline,
+ case Settings.getFileCache () of
+ NONE => box []
+ | SOME _ =>
+ p_list_sepi newline
+ (fn i => fn (_, t) =>
+ case t of
+ Settings.Blob =>
+ box [string "uw_Basis_cache_file(ctx, arg",
+ string (Int.toString (i + 1)),
+ string ");"]
+ | Settings.Nullable Settings.Blob =>
+ box [string "if (arg",
+ string (Int.toString (i + 1)),
+ string ") uw_Basis_cache_file(ctx, arg",
+ string (Int.toString (i + 1)),
+ string ");"]
+ | _ => box [])
+ inputs,
+ newline,
string "uw_ensure_transaction(ctx);",
newline,
newline,
@@ -2789,7 +2822,7 @@ fun p_file env (ds, ps) =
string "}"]
end
- fun getInput (x, t) =
+ fun getInput includesFile (x, t) =
let
val n = case SM.find (fnums, x) of
NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums")
@@ -2839,7 +2872,7 @@ fun p_file env (ds, ps) =
xts,
newline,
p_list_sep (box []) (fn (x, t) =>
- box [getInput (x, t),
+ box [getInput includesFile (x, t),
string "result.__uwf_",
string x,
space,
@@ -2902,7 +2935,7 @@ fun p_file env (ds, ps) =
xts,
newline,
p_list_sep (box []) (fn (x, t) =>
- box [getInput (x, t),
+ box [getInput includesFile (x, t),
string "result->__uwf_1.__uwf_",
string x,
space,
@@ -2955,7 +2988,10 @@ fun p_file env (ds, ps) =
space,
string "=",
space,
- unurlify true env t,
+ if includesFile andalso isString t then
+ string "request"
+ else
+ unurlify true env t,
string ";",
newline]
end
@@ -2975,6 +3011,7 @@ fun p_file env (ds, ps) =
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
+ val includesFile = List.exists (fn (_, t) => isFile t) xts
in
(List.take (ts, length ts - 2),
box [box (map (fn (x, t) => box [p_typ env t,
@@ -2984,7 +3021,7 @@ fun p_file env (ds, ps) =
string ";",
newline]) xts),
newline,
- box (map getInput xts),
+ box (map (getInput includesFile) xts),
case i of
0 => string "uw_unit uw_inputs;"
| _ => box [string "struct __uws_",
@@ -3665,7 +3702,10 @@ fun p_file env (ds, ps) =
"uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", "uw_check_meta",
case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
"\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"",
- if Settings.getIsHtml5 () then "1" else "0"],
+ if Settings.getIsHtml5 () then "1" else "0",
+ (case Settings.getFileCache () of
+ NONE => "NULL"
+ | SOME s => "\"" ^ Prim.toCString s ^ "\"")],
string "};",
newline]
end
diff --git a/src/compiler.sig b/src/compiler.sig
index 952c7070..bcf69fd4 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -60,9 +60,11 @@ signature COMPILER = sig
protocol : string option,
dbms : string option,
sigFile : string option,
+ fileCache : string option,
safeGets : string list,
onError : (string * string list * string) option,
- minHeap : int
+ minHeap : int,
+ mimeTypes : string option
}
val compile : string -> bool
val compiler : string -> unit
@@ -124,6 +126,7 @@ signature COMPILER = sig
val pathcheck : (Mono.file, Mono.file) phase
val sidecheck : (Mono.file, Mono.file) phase
val sigcheck : (Mono.file, Mono.file) phase
+ val filecache : (Mono.file, Mono.file) phase
val sqlcache : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
val prepare : (Cjr.file, Cjr.file) phase
@@ -190,6 +193,7 @@ signature COMPILER = sig
val toPathcheck : (string, Mono.file) transform
val toSidecheck : (string, Mono.file) transform
val toSigcheck : (string, Mono.file) transform
+ val toFilecache : (string, Mono.file) transform
val toSqlcache : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
val toPrepare : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index c13de304..f724bf56 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -64,9 +64,11 @@ type job = {
protocol : string option,
dbms : string option,
sigFile : string option,
+ fileCache : string option,
safeGets : string list,
onError : (string * string list * string) option,
- minHeap : int
+ minHeap : int,
+ mimeTypes : string option
}
type ('src, 'dst) phase = {
@@ -386,7 +388,9 @@ fun institutionalizeJob (job : job) =
Settings.setSafeGets (#safeGets job);
Settings.setOnError (#onError job);
Settings.setMinHeap (#minHeap job);
- Settings.setSigFile (#sigFile job))
+ Settings.setSigFile (#sigFile job);
+ Settings.setFileCache (#fileCache job);
+ Settings.setMimeFilePath (Option.getOpt (#mimeTypes job, "/etc/mime.types")))
datatype commentableLine =
EndOfFile
@@ -465,9 +469,11 @@ fun parseUrp' accLibs fname =
protocol = NONE,
dbms = NONE,
sigFile = NONE,
+ fileCache = NONE,
safeGets = [],
onError = NONE,
- minHeap = 0}
+ minHeap = 0,
+ mimeTypes = NONE}
in
institutionalizeJob job;
{Job = job, Libs = []}
@@ -598,9 +604,11 @@ fun parseUrp' accLibs fname =
val protocol = ref NONE
val dbms = ref NONE
val sigFile = ref (Settings.getSigFile ())
+ val fileCache = ref (Settings.getFileCache ())
val safeGets = ref []
val onError = ref NONE
val minHeap = ref 0
+ val mimeTypes = ref NONE
fun finish sources =
let
@@ -636,9 +644,11 @@ fun parseUrp' accLibs fname =
protocol = !protocol,
dbms = !dbms,
sigFile = !sigFile,
+ fileCache = !fileCache,
safeGets = rev (!safeGets),
onError = !onError,
- minHeap = !minHeap
+ minHeap = !minHeap,
+ mimeTypes = !mimeTypes
}
fun mergeO f (old, new) =
@@ -697,9 +707,11 @@ fun parseUrp' accLibs fname =
protocol = mergeO #2 (#protocol old, #protocol new),
dbms = mergeO #2 (#dbms old, #dbms new),
sigFile = mergeO #2 (#sigFile old, #sigFile new),
+ fileCache = mergeO #2 (#fileCache old, #fileCache new),
safeGets = #safeGets old @ #safeGets new,
onError = mergeO #2 (#onError old, #onError new),
- minHeap = Int.max (#minHeap old, #minHeap new)
+ minHeap = Int.max (#minHeap old, #minHeap new),
+ mimeTypes = mergeO #2 (#mimeTypes old, #mimeTypes new)
}
in
if accLibs then
@@ -784,6 +796,10 @@ fun parseUrp' accLibs fname =
(case !sigFile of
NONE => sigFile := SOME arg
| SOME _ => ())
+ | "filecache" =>
+ (case !fileCache of
+ NONE => fileCache := SOME arg
+ | SOME _ => ())
| "exe" =>
(case !exe of
NONE => exe := SOME (relify arg)
@@ -914,13 +930,20 @@ fun parseUrp' accLibs fname =
| "html5" => Settings.setIsHtml5 true
| "xhtml" => Settings.setIsHtml5 false
| "lessSafeFfi" => Settings.setLessSafeFfi true
+ | "mimeTypes" => Settings.setMimeFilePath (relify arg)
| "file" =>
(case String.fields Char.isSpace arg of
- [uri, fname] => (Settings.setFilePath thisPath;
- Settings.addFile {Uri = uri,
- LoadFromFilename = fname};
- url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url)
+ uri :: fname :: rest =>
+ (Settings.setFilePath thisPath;
+ Settings.addFile {Uri = uri,
+ LoadFromFilename = fname,
+ MimeType = case rest of
+ [] => NONE
+ | [ty] => SOME ty
+ | _ => (ErrorMsg.error "Bad 'file' arguments";
+ NONE)};
+ url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url)
| _ => ErrorMsg.error "Bad 'file' arguments")
| "jsFile" =>
@@ -1500,6 +1523,13 @@ val sigcheck = {
val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
+val filecache = {
+ func = FileCache.instrument,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toFilecache = transform filecache "filecache" o toSigcheck
+
val sqlcache = {
func = (fn file =>
if Settings.getSqlcache ()
@@ -1508,7 +1538,7 @@ val sqlcache = {
print = MonoPrint.p_file MonoEnv.empty
}
-val toSqlcache = transform sqlcache "sqlcache" o toSigcheck
+val toSqlcache = transform sqlcache "sqlcache" o toFilecache
val cjrize = {
func = Cjrize.cjrize,
diff --git a/src/css.sml b/src/css.sml
index 9e50686f..17ec01d5 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -104,6 +104,7 @@ val tags = [("span", inline),
("cpassword", replaced),
("button", replaced),
("ccheckbox", replaced),
+ ("cradio", replaced),
("cselect", replaced),
("ctextarea", replaced),
("tabl", table),
diff --git a/src/demo.sml b/src/demo.sml
index 62b9037a..1e58e2f8 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -123,9 +123,11 @@ fun make' {prefix, dirname, guided} =
protocol = mergeWith #2 (#protocol combined, #protocol urp),
dbms = mergeWith #2 (#dbms combined, #dbms urp),
sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
+ fileCache = mergeWith #2 (#fileCache combined, #fileCache urp),
safeGets = #safeGets combined @ #safeGets urp,
onError = NONE,
- minHeap = 0
+ minHeap = 0,
+ mimeTypes = mergeWith #2 (#mimeTypes combined, #mimeTypes urp)
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 8402bcba..0474bf7c 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1663,7 +1663,7 @@ fun declBinds env (d, loc) =
| DVal (x, n, t, _) => pushENamedAs env x n t
| DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis
| DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
- | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn
+ | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn
| DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn
| DConstraint _ => env
| DExport _ => env
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 4a04d4bf..51d00bd8 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -4046,7 +4046,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
| L.PAnnot (p', _) => singleVar p'
| _ => NONE
in
- unifyCons env loc et pt;
+ (unifyCons env loc et pt
+ handle CUnify (c1, c2, env', err) => expError env (Unify (e', c1, c2, env', err)));
(case exhaustive (env, et, [p'], loc) of
NONE => ()
diff --git a/src/filecache.sig b/src/filecache.sig
new file mode 100644
index 00000000..db57135f
--- /dev/null
+++ b/src/filecache.sig
@@ -0,0 +1,35 @@
+(* Copyright (c) 2013, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Instrument to check a cache in the file system, to reconsitute blobs without
+ * silly shipping over an SQL connection. *)
+
+signature FILE_CACHE = sig
+
+ val instrument : Mono.file -> Mono.file
+
+end
diff --git a/src/filecache.sml b/src/filecache.sml
new file mode 100644
index 00000000..e2291c10
--- /dev/null
+++ b/src/filecache.sml
@@ -0,0 +1,230 @@
+(* Copyright (c) 2013, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure FileCache :> FILE_CACHE = struct
+
+open Mono
+
+structure SS = BinarySetFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
+
+val hasBlob =
+ MonoUtil.Typ.exists (fn TFfi ("Basis", "blob") => true
+ | _ => false)
+
+val unBlob =
+ MonoUtil.Typ.map (fn TFfi ("Basis", "blob") => TFfi ("Basis", "string")
+ | t => t)
+
+fun nodups (exps : (string * typ) list, tables : (string * (string * typ) list) list) =
+ let
+ val cols = map #1 exps @ ListUtil.mapConcat (map #1 o #2) tables
+
+ val (_, good) =
+ foldl (fn (name, (names, good)) =>
+ if SS.member(names, name) then
+ (names, false)
+ else
+ (SS.add (names, name), good)) (SS.empty, true) cols
+ in
+ good
+ end
+
+fun instrument file =
+ let
+ fun exp e =
+ case e of
+ EQuery {exps, tables, state, query, body, initial} =>
+ if (List.exists (hasBlob o #2) exps
+ orelse List.exists (List.exists (hasBlob o #2) o #2) tables)
+ andalso nodups (exps, tables) then
+ let
+ val exps = ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ exps
+ val tables = ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ tables
+ val tables = map (fn (x, xts) =>
+ (x, ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ xts)) tables
+
+ val loc = #2 query
+
+ fun wrapCol (name, t) =
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ "DIGEST(" ^ name ^ ", 'sha512')"
+ | TOption t' => wrapCol (name, t')
+ | _ => name
+
+ val mangle = Settings.mangleSql
+
+ val cols = map (fn (name, t) => (mangle name, t)) exps
+ @ ListUtil.mapConcat (fn (_, cols) =>
+ map (fn (name, t) =>
+ (mangle name,
+ t)) cols) tables
+
+ val prequery =
+ "SELECT "
+ ^ String.concatWith ", " (map wrapCol cols)
+ ^ " FROM ("
+
+ val postquery =
+ ") AS Wrap"
+
+ val wrapped_query =
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, prequery)), loc),
+ (EStrcat (query,
+ (EPrim (Prim.String (Prim.Normal, postquery)), loc)), loc)), loc)
+ val wrapped_query = MonoOpt.optExp wrapped_query
+
+ val exps' = map (fn (name, t) => (name, unBlob t)) exps
+ val tables' = map (fn (name, cols) =>
+ (name,
+ map (fn (cname, t) => (cname, unBlob t)) cols)) tables
+
+ val blob = (TFfi ("Basis", "blob"), loc)
+ val string = (TFfi ("Basis", "string"), loc)
+
+ fun trycache (name, e, t : typ) =
+ (name,
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ (EFfiApp ("Basis",
+ "check_filecache",
+ [(e, string)]), loc)
+ | TOption (TFfi ("Basis", "blob"), _) =>
+ (ECase (e,
+ [((PNone string, loc),
+ (ENone blob, loc)),
+ ((PSome (string, (PVar ("hash", string), loc)), loc),
+ (ESome (blob,
+ (EFfiApp ("Basis",
+ "check_filecache",
+ [((ERel 0, loc), string)]), loc)), loc))],
+ {disc = (TOption string, loc),
+ result = (TOption blob, loc)}), loc)
+ | _ => e,
+ t)
+
+ val wrapped_body_trycache =
+ (ELet ("uncached",
+ (TRecord (exps @ map (fn (name, cols) =>
+ (name, (TRecord cols, loc))) tables),
+ loc),
+ (ERecord (map (fn (name, t) =>
+ trycache (name,
+ (EField ((ERel 1, loc),
+ name), loc),
+ t)) exps
+ @ map (fn (tname, cols) =>
+ (tname,
+ (ERecord (map (fn (name, t) =>
+ trycache (name,
+ (EField ((EField ((ERel 1, loc), tname), loc), name), loc),
+ t)) cols), loc),
+ (TRecord cols, loc))) tables), loc),
+ MonoEnv.subExpInExp (2, (ERel 0, loc))
+
+
+ (MonoEnv.liftExpInExp 0 body)), loc)
+
+ fun maybeadd (e, t, acc) =
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ (ESeq ((EFfiApp ("Basis",
+ "cache_file",
+ [(e, blob)]), loc),
+ acc), loc)
+ | TOption (TFfi ("Basis", "blob"), _) =>
+ (ESeq ((ECase (e,
+ [((PNone blob, loc),
+ (ERecord [], loc)),
+ ((PSome (blob, (PVar ("blob", blob), loc)), loc),
+ (EFfiApp ("Basis",
+ "cache_file",
+ [((ERel 0, loc), blob)]), loc))],
+ {disc = t,
+ result = (TRecord [], loc)}), loc),
+ acc), loc)
+ | _ => acc
+
+ val wrapped_body_addtocache =
+ foldl (fn ((name, t), e) =>
+ maybeadd ((EField ((ERel 1, loc), name), loc),
+ t, e))
+ (foldl (fn ((tname, cols), e) =>
+ foldl (fn ((name, t), e) =>
+ maybeadd ((EField ((EField ((ERel 1, loc), tname), loc), name), loc),
+ t, e)) e cols) body tables)
+ exps
+ in
+ ECase ((EFfiApp ("Basis", "filecache_missed", []), loc),
+ [((PCon (Enum,
+ PConFfi {mod = "Basis",
+ datatyp = "bool",
+ con = "False",
+ arg = NONE},
+ NONE), loc),
+ (EQuery {exps = exps',
+ tables = tables',
+ state = state,
+ query = wrapped_query,
+ body = wrapped_body_trycache,
+ initial = initial}, loc)),
+ ((PCon (Enum,
+ PConFfi {mod = "Basis",
+ datatyp = "bool",
+ con = "True",
+ arg = NONE},
+ NONE), loc),
+ (EQuery {exps = exps,
+ tables = tables,
+ state = state,
+ query = query,
+ body = wrapped_body_addtocache,
+ initial = initial}, loc))],
+ {disc = (TFfi ("Basis", "bool"), loc),
+ result = state})
+ end
+ else
+ e
+ | _ => e
+ in
+ case Settings.getFileCache () of
+ NONE => file
+ | SOME _ => MonoUtil.File.map {typ = fn t => t,
+ exp = exp,
+ decl = fn d => d} file
+ end
+
+end
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 2caa43f8..1229d552 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -27,15 +27,79 @@
val socket = ".urweb_daemon"
-(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
-
exception Code of OS.Process.status
+datatype flag_arity =
+ ZERO of (unit -> unit)
+ | ONE of string * (string -> unit)
+ | TWO of string * string * (string * string -> unit)
+
+fun parse_flags flag_info args =
+ let
+ fun search_pred flag0 =
+ (* Remove preceding "-". *)
+ let val flag0 = String.extract (flag0, 1, NONE)
+ in
+ fn (flag1, _, _) => flag0 = flag1
+ end
+
+ fun loop [] : string list = []
+ | loop (arg :: args) =
+ if String.isPrefix "-" arg then
+ case List.find (search_pred arg) flag_info of
+ NONE => raise Fail ("Unknown flag "^arg^", see -help")
+ | SOME x => exec x args
+ else
+ arg :: loop args
+
+ and exec (_, ZERO f, _) args =
+ (f (); loop args)
+ | exec (_, ONE (_, f), _) (x :: args) =
+ (f x; loop args)
+ | exec (_, TWO (_, _, f), _) (x :: y :: args) =
+ (f (x, y); loop args)
+ | exec (flag, ONE _, _) [] =
+ raise Fail ("Flag "^flag^" is missing an argument, see -help")
+ | exec (flag, TWO _, _) [] =
+ raise Fail ("Flag "^flag^" is missing two arguments, see -help")
+ | exec (flag, TWO _, _) [_] =
+ raise Fail ("Flag "^flag^" is missing an argument, see -help")
+ in
+ loop args
+ end
+
+fun usage flag_info =
+ let
+ val name = CommandLine.name ()
+
+ fun print_desc NONE = print "\n"
+ | print_desc (SOME s) = (print " : "; print s; print "\n")
+
+ fun print_args (ZERO _) = ()
+ | print_args (ONE (x, _)) = print (" " ^ x)
+ | print_args (TWO (x, y, _)) = print (" " ^ x ^ " " ^ y)
+
+ fun print_flag (flag, args, desc) =
+ (print (" -" ^ flag);
+ print_args args;
+ print_desc desc)
+ in
+ print "usage: \n";
+ print (" " ^ name ^ " daemon [stop|start]\n");
+ print (" " ^ name ^ " [flag ...] project-name\n");
+ print "Supported flags are:\n";
+ app print_flag flag_info;
+ raise Code OS.Process.success
+ end
+
+
+
+(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
+
fun oneRun args =
let
val timing = ref false
val tc = ref false
- val sources = ref ([] : string list)
val demo = ref (NONE : (string * bool) option)
val tutorial = ref false
val css = ref false
@@ -52,162 +116,143 @@ fun oneRun args =
val () = Compiler.beforeC := MLton.GC.pack
- fun printVersion () = (print (Config.versionString ^ "\n");
- 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 printCInclude () = (print (Config.includ ^ "\n");
- raise Code OS.Process.success)
-
- fun doArgs args =
- case args of
- [] => ()
- | "-version" :: rest =>
- printVersion ()
- | "-numeric-version" :: rest =>
- printNumericVersion ()
- | "-css" :: rest =>
- (css := true;
- doArgs rest)
- | "-print-ccompiler" :: rest =>
- printCCompiler ()
- | "-print-cinclude" :: rest =>
- printCInclude ()
- | "-ccompiler" :: ccomp :: rest =>
- (Settings.setCCompiler ccomp;
- doArgs rest)
- | "-demo" :: prefix :: rest =>
- (demo := SOME (prefix, false);
- doArgs rest)
- | "-guided-demo" :: prefix :: rest =>
- (demo := SOME (prefix, true);
- doArgs rest)
- | "-tutorial" :: rest =>
- (tutorial := true;
- doArgs rest)
- | "-protocol" :: name :: rest =>
- (Settings.setProtocol name;
- doArgs rest)
- | "-prefix" :: prefix :: rest =>
- (Settings.setUrlPrefix prefix;
- doArgs rest)
- | "-db" :: s :: rest =>
- (Settings.setDbstring (SOME s);
- doArgs rest)
- | "-dbms" :: name :: rest =>
- (Settings.setDbms name;
- doArgs rest)
- | "-debug" :: rest =>
- (Settings.setDebug true;
- doArgs rest)
- | "-verbose" :: rest =>
- (Compiler.debug := true;
- Elaborate.verbose := true;
- doArgs rest)
- | "-timing" :: rest =>
- (timing := true;
- doArgs rest)
- | "-tc" :: rest =>
- (tc := true;
- doArgs rest)
- | "-dumpTypes" :: rest =>
- (Elaborate.dumpTypes := true;
- doArgs rest)
- | "-dumpTypesOnError" :: rest =>
- (Elaborate.dumpTypesOnError := true;
- doArgs rest)
- | "-unifyMore" :: rest =>
- (Elaborate.unifyMore := true;
- doArgs rest)
- | "-dumpSource" :: rest =>
- (Compiler.dumpSource := true;
- doArgs rest)
- | "-dumpVerboseSource" :: rest =>
- (Compiler.dumpSource := true;
- ElabPrint.debug := true;
- ExplPrint.debug := true;
- CorePrint.debug := true;
- MonoPrint.debug := true;
- doArgs rest)
- | "-output" :: s :: rest =>
- (Settings.setExe (SOME s);
- doArgs rest)
- | "-js" :: s :: rest =>
- (Settings.setOutputJsFile (SOME s);
- doArgs rest)
- | "-sql" :: s :: rest =>
- (Settings.setSql (SOME s);
- doArgs rest)
- | "-static" :: rest =>
- (Settings.setStaticLinking true;
- doArgs rest)
- | "-stop" :: phase :: rest =>
- (Compiler.setStop phase;
- doArgs rest)
- | "-path" :: name :: path :: rest =>
- (Compiler.addPath (name, path);
- doArgs rest)
- | "-root" :: name :: root :: rest =>
- (Compiler.addModuleRoot (root, name);
- doArgs rest)
- | "-boot" :: rest =>
- (Compiler.enableBoot ();
- Settings.setBootLinking true;
- doArgs rest)
- | "-sigfile" :: name :: rest =>
- (Settings.setSigFile (SOME name);
- doArgs rest)
- | "-iflow" :: rest =>
- (Compiler.doIflow := true;
- doArgs rest)
- | "-sqlcache" :: rest =>
- (Settings.setSqlcache true;
- doArgs rest)
- | "-heuristic" :: h :: rest =>
- (Sqlcache.setHeuristic h;
- doArgs rest)
- | "-moduleOf" :: fname :: _ =>
- (print (Compiler.moduleOf fname ^ "\n");
- raise Code OS.Process.success)
- | "-noEmacs" :: rest =>
- (Demo.noEmacs := true;
- doArgs rest)
- | "-limit" :: class :: num :: rest =>
- (case Int.fromString num of
- NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
- | SOME n =>
- if n < 0 then
- raise Fail ("Invalid limit number '" ^ num ^ "'")
- else
- Settings.addLimit (class, n);
- doArgs rest)
- | "-explainEmbed" :: rest =>
- (JsComp.explainEmbed := true;
- doArgs rest)
- | arg :: rest =>
- (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
- raise Fail ("Unknown flag " ^ arg)
+ fun print_and_exit msg () =
+ (print msg; print "\n";
+ raise Code OS.Process.success)
+
+ val printVersion = print_and_exit Config.versionString
+ val printNumericVersion = print_and_exit Config.versionNumber
+ fun printCCompiler () = print_and_exit (Settings.getCCompiler ()) ()
+ val printCInclude = print_and_exit Config.includ
+
+ fun printModuleOf fname =
+ print_and_exit (Compiler.moduleOf fname) ()
+
+ fun add_class (class, num) =
+ case Int.fromString num of
+ NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
+ | SOME n =>
+ if n < 0 then
+ raise Fail ("Invalid limit number '" ^ num ^ "'")
else
- sources := arg :: !sources;
- doArgs rest)
+ Settings.addLimit (class, n)
+
+ fun set_true flag = ZERO (fn () => flag := true)
+ fun call_true f = ZERO (fn () => f true)
+
+ (* This is a function, and not simply a value, because it
+ * is recursive in the help-flag. *)
+ fun flag_info () = [
+ ("help", ZERO (fn () => usage (flag_info ())),
+ SOME "print this overview"),
+ ("version", ZERO printVersion,
+ SOME "print version number and exit"),
+ ("numeric-version", ZERO printNumericVersion,
+ SOME "print numeric version number and exit"),
+ ("css", set_true css,
+ SOME "print categories of CSS properties"),
+ ("print-ccompiler", ZERO printCCompiler,
+ SOME "print C compiler and exit"),
+ ("print-cinclude", ZERO printCInclude,
+ SOME "print directory of C headers and exit"),
+ ("ccompiler", ONE ("<program>", Settings.setCCompiler),
+ SOME "set the C compiler to <program>"),
+ ("demo", ONE ("<prefix>", fn prefix =>
+ demo := SOME (prefix, false)),
+ NONE),
+ ("guided-demo", ONE ("<prefix>", fn prefix =>
+ demo := SOME (prefix, true)),
+ NONE),
+ ("tutorial", set_true tutorial,
+ NONE),
+ ("protocol", ONE ("[http|cgi|fastcgi|static]",
+ Settings.setProtocol),
+ SOME "set server protocol"),
+ ("prefix", ONE ("<prefix>", Settings.setUrlPrefix),
+ SOME "set prefix used before all URI's"),
+ ("db", ONE ("<string>", Settings.setDbstring o SOME),
+ SOME "database connection information"),
+ ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms),
+ SOME "select database engine"),
+ ("debug", call_true Settings.setDebug,
+ NONE),
+ ("verbose", ZERO (fn () =>
+ (Compiler.debug := true;
+ Elaborate.verbose := true)),
+ NONE),
+ ("timing", set_true timing,
+ SOME "time compilation phases"),
+ ("tc", set_true tc,
+ SOME "stop after type checking"),
+ ("dumpTypes", set_true Elaborate.dumpTypes,
+ SOME "print kinds and types"),
+ ("dumpTypesOnError", set_true Elaborate.dumpTypesOnError,
+ SOME "print kinds and types if there is an error"),
+ ("unifyMore", set_true Elaborate.unifyMore,
+ SOME "continue unification before reporting type error"),
+ ("dumpSource", set_true Compiler.dumpSource,
+ NONE),
+ ("dumpVerboseSource", ZERO (fn () =>
+ (Compiler.dumpSource := true;
+ ElabPrint.debug := true;
+ ExplPrint.debug := true;
+ CorePrint.debug := true;
+ MonoPrint.debug := true)),
+ NONE),
+ ("output", ONE ("<file>", Settings.setExe o SOME),
+ SOME "output executable as <file>"),
+ ("js", ONE ("<file>", Settings.setOutputJsFile o SOME),
+ SOME "serve JavaScript as <file>"),
+ ("sql", ONE ("<file>", Settings.setSql o SOME),
+ SOME "output sql script as <file>"),
+ ("static", call_true Settings.setStaticLinking,
+ SOME "enable static linking"),
+ ("stop", ONE ("<phase>", Compiler.setStop),
+ SOME "stop compilation after <phase>"),
+ ("path", TWO ("<name>", "<path>", Compiler.addPath),
+ NONE),
+ ("root", TWO ("<name>", "<path>",
+ (fn (name, path) =>
+ Compiler.addModuleRoot (path, name))),
+ NONE),
+ ("boot", ZERO (fn () =>
+ (Compiler.enableBoot ();
+ Settings.setBootLinking true)),
+ NONE),
+ ("sigfile", ONE ("<file>", Settings.setSigFile o SOME),
+ NONE),
+ ("iflow", set_true Compiler.doIflow,
+ NONE),
+ ("sqlcache", call_true Settings.setSqlcache,
+ NONE),
+ ("heuristic", ONE ("<h>", Sqlcache.setHeuristic),
+ NONE),
+ ("moduleOf", ONE ("<file>", printModuleOf),
+ SOME "print module name of <file> and exit"),
+ ("noEmacs", set_true Demo.noEmacs,
+ NONE),
+ ("limit", TWO ("<class>", "<num>", add_class),
+ NONE),
+ ("explainEmbed", set_true JsComp.explainEmbed,
+ SOME ("explain errors about embedding of server-side "^
+ "values in client code"))
+ ]
val () = case args of
["daemon", "stop"] => OS.Process.exit OS.Process.success
| _ => ()
- val () = doArgs args
+ val sources = parse_flags (flag_info ()) args
val job =
- case !sources of
+ case sources of
[file] => file
+ | [] =>
+ raise Fail "No project specified, see -help"
| files =>
- if List.exists (fn s => s <> "-version") args then
- raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
- ^ String.concatWith ", " files)
- else
- printVersion ()
+ raise Fail ("Multiple projects specified;"^
+ " only one is allowed.\nSpecified projects: "^
+ String.concatWith ", " files)
in
case (!css, !demo, !tutorial) of
(true, _, _) =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index fc1a2bcb..fdf48d20 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -107,16 +107,16 @@ fun mapfold fc =
| TOption t =>
S.map2 (mft t,
fn t' =>
- (TOption t, loc))
+ (TOption t', loc))
| TList t =>
S.map2 (mft t,
fn t' =>
- (TList t, loc))
+ (TList t', loc))
| TSource => S.return2 cAll
| TSignal t =>
S.map2 (mft t,
fn t' =>
- (TSignal t, loc))
+ (TSignal t', loc))
in
mft
end
diff --git a/src/monoize.sml b/src/monoize.sml
index ddf6cd4c..11c6ea31 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1792,18 +1792,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
NONE), loc),
str "")],
{disc = b, result = s}), loc),
- strcatComma (map (fn (x, t) =>
- strcat [
- (L'.EField (gf "SelectExps", x), loc),
- str (" AS " ^ Settings.mangleSql x)
- ]) sexps
- @ map (fn (x, xts) =>
- strcatComma
- (map (fn (x', _) =>
- str ("T_" ^ x
- ^ "."
- ^ Settings.mangleSql x'))
- xts)) stables),
+ if List.null sexps andalso List.all (List.null o #2) stables then
+ str "0"
+ else
+ strcatComma (map (fn (x, t) =>
+ strcat [
+ (L'.EField (gf "SelectExps", x), loc),
+ str (" AS " ^ Settings.mangleSql x)
+ ]) sexps
+ @ map (fn (x, xts) =>
+ strcatComma
+ (map (fn (x', _) =>
+ str ("T_" ^ x
+ ^ "."
+ ^ Settings.mangleSql x'))
+ xts)) stables),
(L'.ECase (gf "From",
[((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
str ""),
@@ -3067,7 +3070,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => (attrs, NONE)
- val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
+ val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cradio", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
fun isSome (e, _) =
case e of
@@ -3281,6 +3284,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
SOME (strcat [str "addOnChange(d,exec(",
(L'.EJavaScript (L'.Script, e), loc),
str "));"])
+ | ("Oninput", e, _) =>
+ SOME (strcat [str "addOnInput(d,exec(",
+ (L'.EJavaScript (L'.Script, e), loc),
+ str "));"])
| (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
@@ -3553,6 +3560,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "ctime" => cinput ("time", "time")
| "ccheckbox" => cinput ("checkbox", "chk")
+ | "cradio" => cinput ("radio", "crad")
+
| "cselect" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
diff --git a/src/mysql.sml b/src/mysql.sml
index 52e4921e..e7cad84e 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1609,6 +1609,7 @@ val () = addDbms {name = "mysql",
onlyUnion = true,
nestedRelops = false,
windowFunctions = false,
- supportsIsDistinctFrom = true}
+ supportsIsDistinctFrom = true,
+ supportsSHA512 = false}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index 404384d2..2b6bee8c 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -612,6 +612,13 @@ fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
getter t
end
+(* We turn 0-output queries into 1-output queries to satisfy SQL.
+ * This function adjusts our length expectations. *)
+fun bumpedLength ls =
+ case ls of
+ [] => 1
+ | _ => length ls
+
fun queryCommon {loc, query, cols, doCols} =
box [string "int n, i;",
newline,
@@ -658,7 +665,7 @@ fun queryCommon {loc, query, cols, doCols} =
newline,
string "if (PQnfields(res) != ",
- string (Int.toString (length cols)),
+ string (Int.toString (bumpedLength cols)),
string ") {",
newline,
box [string "int nf = PQnfields(res);",
@@ -668,7 +675,7 @@ fun queryCommon {loc, query, cols, doCols} =
string "uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
string ": Query returned %d columns instead of ",
- string (Int.toString (length cols)),
+ string (Int.toString (bumpedLength cols)),
string ":\\n%s\\n%s\", nf, ",
query,
string ", PQerrorMessage(conn));",
@@ -1146,7 +1153,8 @@ val () = addDbms {name = "postgres",
onlyUnion = false,
nestedRelops = true,
windowFunctions = true,
- supportsIsDistinctFrom = true}
+ supportsIsDistinctFrom = true,
+ supportsSHA512 = true}
val () = setDbms "postgres"
diff --git a/src/settings.sig b/src/settings.sig
index 256a12b5..986d6ed7 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -219,7 +219,8 @@ signature SETTINGS = sig
onlyUnion : bool,
nestedRelops : bool,
windowFunctions : bool,
- supportsIsDistinctFrom : bool
+ supportsIsDistinctFrom : bool,
+ supportsSHA512 : bool
}
val addDbms : dbms -> unit
@@ -253,6 +254,9 @@ signature SETTINGS = sig
val setSigFile : string option -> unit
val getSigFile : unit -> string option
+ val setFileCache : string option -> unit
+ val getFileCache : unit -> string option
+
(* Which GET-able functions should be allowed to have side effects? *)
val setSafeGets : string list -> unit
val isSafeGet : string -> bool
@@ -298,7 +302,7 @@ signature SETTINGS = sig
val setFilePath : string -> unit
(* Sets the directory where we look for files being added below. *)
- val addFile : {Uri : string, LoadFromFilename : string} -> unit
+ val addFile : {Uri : string, LoadFromFilename : string, MimeType : string option} -> unit
val listFiles : unit -> {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector} list
val addJsFile : string (* filename *) -> unit
@@ -306,4 +310,7 @@ signature SETTINGS = sig
val setOutputJsFile : string option (* filename *) -> unit
val getOutputJsFile : unit -> string option
+
+ val setMimeFilePath : string -> unit
+ (* Set unusual location for /etc/mime.types. *)
end
diff --git a/src/settings.sml b/src/settings.sml
index a3263c06..cfbe98a5 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -646,7 +646,8 @@ type dbms = {
onlyUnion : bool,
nestedRelops : bool,
windowFunctions: bool,
- supportsIsDistinctFrom : bool
+ supportsIsDistinctFrom : bool,
+ supportsSHA512 : bool
}
val dbmses = ref ([] : dbms list)
@@ -679,7 +680,8 @@ val curDb = ref ({name = "",
onlyUnion = false,
nestedRelops = false,
windowFunctions = false,
- supportsIsDistinctFrom = false} : dbms)
+ supportsIsDistinctFrom = false,
+ supportsSHA512 = false} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =
@@ -724,6 +726,15 @@ val sigFile = ref (NONE : string option)
fun setSigFile v = sigFile := v
fun getSigFile () = !sigFile
+val fileCache = ref (NONE : string option)
+fun setFileCache v =
+ (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then
+ ErrorMsg.error "The selected database engine is incompatible with file caching."
+ else
+ ();
+ fileCache := v)
+fun getFileCache () = !fileCache
+
structure SS = BinarySetFn(struct
type ord_key = string
val compare = String.compare
@@ -843,14 +854,17 @@ structure SM = BinaryMapFn(struct
val noMimeFile = ref false
+val mimeFilePath = ref "/etc/mime.types"
+fun setMimeFilePath file = mimeFilePath := file
+
fun noMime () =
- (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n");
+ (TextIO.output (TextIO.stdErr, "WARNING: Error opening " ^ !mimeFilePath ^ ". Static files will be served with no suggested MIME types.\n");
noMimeFile := true;
SM.empty)
fun readMimeTypes () =
let
- val inf = FileIO.txtOpenIn "/etc/mime.types"
+ val inf = FileIO.txtOpenIn (!mimeFilePath)
fun loop m =
case TextIO.inputLine inf of
@@ -908,9 +922,10 @@ val filePath = ref "."
fun setFilePath path = filePath := path
-fun addFile {Uri, LoadFromFilename} =
+fun addFile {Uri, LoadFromFilename, MimeType} =
let
val path = OS.Path.concat (!filePath, LoadFromFilename)
+ handle Path => LoadFromFilename
in
case SM.find (!files, Uri) of
SOME (path', _) =>
@@ -926,7 +941,9 @@ fun addFile {Uri, LoadFromFilename} =
Uri,
(path,
{Uri = Uri,
- ContentType = mimeTypeOf path,
+ ContentType = case MimeType of
+ NONE => mimeTypeOf path
+ | _ => MimeType,
LastModified = OS.FileSys.modTime path,
Bytes = BinIO.inputAll inf}));
BinIO.closeIn inf
diff --git a/src/sources b/src/sources
index 52b1bdd7..5c0b2a84 100644
--- a/src/sources
+++ b/src/sources
@@ -231,6 +231,9 @@ $(SRC)/sidecheck.sml
$(SRC)/sigcheck.sig
$(SRC)/sigcheck.sml
+$(SRC)/filecache.sig
+$(SRC)/filecache.sml
+
$(SRC)/mono_inline.sml
$(SRC)/sha1.sig
diff --git a/src/sqlite.sml b/src/sqlite.sml
index a9b6389d..db7052d1 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -273,6 +273,11 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
string "\"Can't open SQLite database.\");",
newline,
newline,
+ string "if (sqlite3_exec(sqlite, \"PRAGMA foreign_keys = ON\", NULL, NULL, NULL) != SQLITE_OK)",
+ newline,
+ box [string "uw_error(ctx, FATAL, \"Can't enable foreign_keys for SQLite database\");",
+ newline],
+ newline,
string "if (uw_database_max < SIZE_MAX) {",
newline,
box [string "char buf[100];",
@@ -843,13 +848,14 @@ val () = addDbms {name = "sqlite",
textKeysNeedLengths = false,
supportsNextval = false,
supportsNestedPrepared = false,
- sqlPrefix = "",
+ sqlPrefix = "PRAGMA foreign_keys = ON;\nPRAGMA journal_mode = WAL;\n\n",
supportsOctetLength = false,
trueString = "1",
falseString = "0",
onlyUnion = false,
nestedRelops = false,
windowFunctions = false,
- supportsIsDistinctFrom = false}
+ supportsIsDistinctFrom = false,
+ supportsSHA512 = false}
end