Mercurial > urweb
changeset 737:d049d31a1966
Initial support for blobs and upload
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 25 Apr 2009 13:59:11 -0400 |
| parents | 796e42c93c48 |
| children | 7fa4871e8272 |
| files | include/types.h include/urweb.h lib/ur/basis.urs src/c/driver.c src/c/urweb.c src/cjr_print.sml src/marshalcheck.sml src/monoize.sml tests/blob.ur tests/blob.urp tests/blob.urs |
| diffstat | 11 files changed, 452 insertions(+), 66 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Thu Apr 23 16:13:02 2009 -0400 +++ b/include/types.h Sat Apr 25 13:59:11 2009 -0400 @@ -4,6 +4,10 @@ typedef double uw_Basis_float; typedef char* uw_Basis_string; typedef time_t uw_Basis_time; +typedef struct { + size_t size; + char *data; +} uw_Basis_blob; struct __uws_0 { }; @@ -24,6 +28,15 @@ unsigned cli, chn; } uw_Basis_channel; +typedef struct uw_Basis_file { + uw_Basis_string name; + uw_Basis_blob data; +} uw_Basis_file; + +typedef struct uw_Basis_files { + size_t size; + uw_Basis_file *files; +} uw_Basis_files; typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY } failure_kind;
--- a/include/urweb.h Thu Apr 23 16:13:02 2009 -0400 +++ b/include/urweb.h Sat Apr 25 13:59:11 2009 -0400 @@ -39,10 +39,13 @@ int uw_send(uw_context, int sock); -void uw_set_input(uw_context, char *name, char *value); +void uw_set_input(uw_context, const char *name, char *value); char *uw_get_input(uw_context, int name); char *uw_get_optional_input(uw_context, int name); +void uw_set_file_input(uw_context, char *name, uw_Basis_files fs); +uw_Basis_files uw_get_file_input(uw_context, int name); + void uw_write(uw_context, const char*); uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string); @@ -101,14 +104,15 @@ uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **); uw_Basis_string uw_Basis_strcat(uw_context, const char *, const char *); -uw_Basis_string uw_Basis_strdup(uw_context, const char *); -uw_Basis_string uw_Basis_maybe_strdup(uw_context, const char *); +uw_Basis_string uw_strdup(uw_context, const char *); +uw_Basis_string uw_maybe_strdup(uw_context, const char *); uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); +uw_Basis_string uw_Basis_sqlifyBlob(uw_context, uw_Basis_blob); uw_Basis_string uw_Basis_sqlifyChannel(uw_context, uw_Basis_channel); uw_Basis_string uw_Basis_sqlifyClient(uw_context, uw_Basis_client); @@ -157,3 +161,8 @@ uw_Basis_string uw_unnull(uw_Basis_string); uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sigString(uw_context, uw_unit); + +uw_Basis_string uw_Basis_fileName(uw_context, uw_Basis_file); +uw_Basis_blob uw_Basis_fileData(uw_context, uw_Basis_file); +uw_Basis_int uw_Basis_numFiles(uw_context, uw_Basis_files); +uw_Basis_file uw_Basis_fileNum(uw_context, uw_Basis_files, uw_Basis_int);
--- a/lib/ur/basis.urs Thu Apr 23 16:13:02 2009 -0400 +++ b/lib/ur/basis.urs Sat Apr 25 13:59:11 2009 -0400 @@ -2,6 +2,7 @@ type float type string type time +type blob type unit = {} @@ -134,6 +135,7 @@ val sql_float : sql_injectable_prim float val sql_string : sql_injectable_prim string val sql_time : sql_injectable_prim time +val sql_blob : sql_injectable_prim blob val sql_channel : t ::: Type -> sql_injectable_prim (channel t) val sql_client : sql_injectable_prim client @@ -512,6 +514,16 @@ val checkbox : formTag bool [] [Checked = bool] +type file +val fileName : file -> option string +val fileData : file -> blob + +type files +val numFiles : files -> int +val fileNum : files -> int -> file + +val upload : formTag files [] [Value = string, Size = int] + con radio = [Body, Radio] val radio : formTag string radio [] val radioOption : unit -> tag [Value = string] radio [] [] []
--- a/src/c/driver.c Thu Apr 23 16:13:02 2009 -0400 +++ b/src/c/driver.c Sat Apr 25 13:59:11 2009 -0400 @@ -1,5 +1,6 @@ +#define _GNU_SOURCE + #include <stdio.h> - #include <string.h> #include <stdlib.h> #include <sys/types.h> @@ -147,9 +148,11 @@ static void *worker(void *data) { int me = *(int *)data, retries_left = MAX_RETRIES; uw_context ctx = new_context(); + size_t buf_size = 1; + char *buf = malloc(buf_size); while (1) { - char buf[uw_bufsize+1], *back = buf, *s, *post; + char *back = buf, *s, *post; int sock, dont_close = 0; pthread_mutex_lock(&queue_mutex); @@ -162,7 +165,17 @@ while (1) { unsigned retries_left = MAX_RETRIES; - int r = recv(sock, back, uw_bufsize - (back - buf), 0); + int r; + + if (back - buf == buf_size) { + char *new_buf; + buf_size *= 2; + new_buf = realloc(buf, buf_size); + back = new_buf + (back - buf); + buf = new_buf; + } + + r = recv(sock, back, buf_size - (back - buf), 0); if (r < 0) { fprintf(stderr, "Recv failed\n"); @@ -182,8 +195,12 @@ if (s = strstr(buf, "\r\n\r\n")) { failure_kind fk; int is_post = 0; + char *boundary = NULL; + size_t boundary_len; char *cmd, *path, *headers, path_copy[uw_bufsize+1], *inputs, *after_headers; + //printf("All: %s\n", buf); + s[2] = 0; after_headers = s + 4; @@ -196,7 +213,7 @@ headers = s + 2; cmd = s = buf; - printf("Read: %s\n", buf); + //printf("Read: %s\n", buf); if (!strsep(&s, " ")) { fprintf(stderr, "No first space in HTTP command\n"); @@ -208,17 +225,25 @@ if (!strcmp(cmd, "POST")) { char *clen_s = uw_Basis_requestHeader(ctx, "Content-length"); if (!clen_s) { - printf("No Content-length with POST\n"); + fprintf(stderr, "No Content-length with POST\n"); goto done; } int clen = atoi(clen_s); if (clen < 0) { - printf("Negative Content-length with POST\n"); + fprintf(stderr, "Negative Content-length with POST\n"); goto done; } while (back - after_headers < clen) { - r = recv(sock, back, uw_bufsize - (back - buf), 0); + if (back - buf == buf_size) { + char *new_buf; + buf_size *= 2; + new_buf = realloc(buf, buf_size); + back = new_buf + (back - buf); + buf = new_buf; + } + + r = recv(sock, back, buf_size - (back - buf), 0); if (r < 0) { fprintf(stderr, "Recv failed\n"); @@ -235,6 +260,19 @@ } is_post = 1; + + clen_s = uw_Basis_requestHeader(ctx, "Content-type"); + if (clen_s && !strncasecmp(clen_s, "multipart/form-data", 19)) { + if (strncasecmp(clen_s + 19, "; boundary=", 11)) { + fprintf(stderr, "Bad multipart boundary spec"); + break; + } + + boundary = clen_s + 28; + boundary[0] = '-'; + boundary[1] = '-'; + boundary_len = strlen(boundary); + } } else if (strcmp(cmd, "GET")) { fprintf(stderr, "Not ready for non-GET/POST command: %s\n", cmd); break; @@ -262,26 +300,134 @@ break; } - if (is_post) - inputs = after_headers; - else if (inputs = strchr(path, '?')) - *inputs++ = 0; - if (inputs) { - char *name, *value; + if (boundary) { + char *part = after_headers, *after_sub_headers, *header, *after_header; + size_t part_len; - while (*inputs) { - name = inputs; - if (inputs = strchr(inputs, '&')) - *inputs++ = 0; - else - inputs = strchr(name, 0); + part = strstr(part, boundary); + if (!part) { + fprintf(stderr, "Missing first multipart boundary\n"); + break; + } + part += boundary_len; - if (value = strchr(name, '=')) { - *value++ = 0; - uw_set_input(ctx, name, value); + while (1) { + char *name = NULL, *filename = NULL, *type = NULL; + + if (part[0] == '-' && part[1] == '-') + break; + + if (*part != '\r') { + fprintf(stderr, "No \\r after multipart boundary\n"); + goto done; } - else - uw_set_input(ctx, name, ""); + ++part; + if (*part != '\n') { + fprintf(stderr, "No \\n after multipart boundary\n"); + goto done; + } + ++part; + + if (!(after_sub_headers = strstr(part, "\r\n\r\n"))) { + fprintf(stderr, "Missing end of headers after multipart boundary\n"); + goto done; + } + after_sub_headers[2] = 0; + after_sub_headers += 4; + + for (header = part; after_header = strstr(header, "\r\n"); header = after_header + 2) { + char *colon, *after_colon; + + *after_header = 0; + if (!(colon = strchr(header, ':'))) { + fprintf(stderr, "Missing colon in multipart sub-header\n"); + goto done; + } + *colon++ = 0; + if (*colon++ != ' ') { + fprintf(stderr, "No space after colon in multipart sub-header\n"); + goto done; + } + + if (!strcasecmp(header, "Content-Disposition")) { + if (strncmp(colon, "form-data; ", 11)) { + fprintf(stderr, "Multipart data is not \"form-data\"\n"); + goto done; + } + + for (colon += 11; after_colon = strchr(colon, '='); colon = after_colon) { + char *data; + after_colon[0] = 0; + if (after_colon[1] != '"') { + fprintf(stderr, "Disposition setting is missing initial quote\n"); + goto done; + } + data = after_colon+2; + if (!(after_colon = strchr(data, '"'))) { + fprintf(stderr, "Disposition setting is missing final quote\n"); + goto done; + } + after_colon[0] = 0; + ++after_colon; + if (after_colon[0] == ';' && after_colon[1] == ' ') + after_colon += 2; + + if (!strcasecmp(colon, "name")) + name = data; + else if (!strcasecmp(colon, "filename")) + filename = data; + } + } else if (!strcasecmp(header, "Content-Type")) { + type = colon; + } + } + + part = memmem(after_sub_headers, back - after_sub_headers, boundary, boundary_len); + if (!part) { + fprintf(stderr, "Missing boundary after multipart payload\n"); + goto done; + } + part[-2] = 0; + part_len = part - after_sub_headers - 2; + part[0] = 0; + part += boundary_len; + + if (filename) { + uw_Basis_file *f = malloc(sizeof(uw_Basis_file)); + uw_Basis_files fs = { 1, f }; + + f->name = filename; + f->data.size = part_len; + f->data.data = after_sub_headers; + + uw_set_file_input(ctx, name, fs); + } else + uw_set_input(ctx, name, after_sub_headers); + } + } + else { + if (is_post) + inputs = after_headers; + else if (inputs = strchr(path, '?')) + *inputs++ = 0; + + if (inputs) { + char *name, *value; + + while (*inputs) { + name = inputs; + if (inputs = strchr(inputs, '&')) + *inputs++ = 0; + else + inputs = strchr(name, 0); + + if (value = strchr(name, '=')) { + *value++ = 0; + uw_set_input(ctx, name, value); + } + else + uw_set_input(ctx, name, ""); + } } }
--- a/src/c/urweb.c Thu Apr 23 16:13:02 2009 -0400 +++ b/src/c/urweb.c Sat Apr 25 13:59:11 2009 -0400 @@ -282,11 +282,23 @@ buf msgs; } delta; +typedef enum { + UNSET, NORMAL, FILES +} input_kind; + +typedef struct { + input_kind kind; + union { + char *normal; + uw_Basis_files files; + } data; +} input; + struct uw_context { char *headers, *headers_end; buf outHeaders, page, heap, script; - char **inputs; + input *inputs; int source_count; @@ -325,7 +337,7 @@ buf_init(&ctx->script, 1); ctx->script.start[0] = 0; - ctx->inputs = calloc(uw_inputs_len, sizeof(char *)); + ctx->inputs = calloc(uw_inputs_len, sizeof(input)); ctx->db = NULL; @@ -398,7 +410,7 @@ void uw_reset(uw_context ctx) { uw_reset_keep_request(ctx); - memset(ctx->inputs, 0, uw_inputs_len * sizeof(char *)); + memset(ctx->inputs, 0, uw_inputs_len * sizeof(input)); } void uw_db_init(uw_context); @@ -544,9 +556,9 @@ return ctx->error_message; } -int uw_input_num(char*); +extern int uw_input_num(const char*); -void uw_set_input(uw_context ctx, char *name, char *value) { +void uw_set_input(uw_context ctx, const char *name, char *value) { int n = uw_input_num(name); if (n < 0) @@ -555,9 +567,8 @@ if (n >= uw_inputs_len) uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n); - ctx->inputs[n] = value; - - //printf("[%d] %s = %s\n", n, name, value); + ctx->inputs[n].kind = NORMAL; + ctx->inputs[n].data.normal = value; } char *uw_get_input(uw_context ctx, int n) { @@ -565,8 +576,17 @@ uw_error(ctx, FATAL, "Negative input index %d", n); if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); - //printf("[%d] = %s\n", n, ctx->inputs[n]); - return ctx->inputs[n]; + + switch (ctx->inputs[n].kind) { + case UNSET: + return NULL; + case FILES: + uw_error(ctx, FATAL, "Tried to read a files form input as normal"); + case NORMAL: + return ctx->inputs[n].data.normal; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } } char *uw_get_optional_input(uw_context ctx, int n) { @@ -574,8 +594,51 @@ uw_error(ctx, FATAL, "Negative input index %d", n); if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); - //printf("[%d] = %s\n", n, ctx->inputs[n]); - return (ctx->inputs[n] == NULL ? "" : ctx->inputs[n]); + + switch (ctx->inputs[n].kind) { + case UNSET: + return ""; + case FILES: + uw_error(ctx, FATAL, "Tried to read a files form input as normal"); + case NORMAL: + return ctx->inputs[n].data.normal; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +void uw_set_file_input(uw_context ctx, const char *name, uw_Basis_files fs) { + int n = uw_input_num(name); + + if (n < 0) + uw_error(ctx, FATAL, "Bad file input name %s", name); + + if (n >= uw_inputs_len) + uw_error(ctx, FATAL, "For file input name %s, index %d is out of range", name, n); + + ctx->inputs[n].kind = FILES; + ctx->inputs[n].data.files = fs; +} + +uw_Basis_files uw_get_file_input(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative file input index %d", n); + if (n >= uw_inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds file input index %d", n); + + switch (ctx->inputs[n].kind) { + case UNSET: + { + uw_Basis_files fs = {}; + return fs; + } + case FILES: + return ctx->inputs[n].data.files; + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input as files"); + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } } void uw_set_script_header(uw_context ctx, const char *s) { @@ -1393,7 +1456,7 @@ return s; } -uw_Basis_string uw_Basis_strdup(uw_context ctx, uw_Basis_string s1) { +uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { int len = strlen(s1) + 1; char *s; @@ -1407,9 +1470,9 @@ return s; } -uw_Basis_string uw_Basis_maybe_strdup(uw_context ctx, uw_Basis_string s1) { +uw_Basis_string uw_maybe_strdup(uw_context ctx, uw_Basis_string s1) { if (s1) - return uw_Basis_strdup(ctx, s1); + return uw_strdup(ctx, s1); else return NULL; } @@ -1477,7 +1540,7 @@ if (isprint(c)) *s2++ = c; else { - sprintf(s2, "\\%3o", c); + sprintf(s2, "\\%03o", c); s2 += 4; } } @@ -1488,6 +1551,43 @@ return r; } +uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) { + char *r, *s2; + size_t i; + + uw_check_heap(ctx, b.size * 5 + 11); + + r = s2 = ctx->heap.front; + *s2++ = 'E'; + *s2++ = '\''; + + for (i = 0; i < b.size; ++i) { + char c = b.data[i]; + + switch (c) { + case '\'': + strcpy(s2, "\\'"); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\\\\\"); + s2 += 4; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\\\%03o", c); + s2 += 5; + } + } + } + + strcpy(s2, "'::bytea"); + ctx->heap.front = s2 + 9; + return r; +} + char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel chn) { int len; char *r; @@ -2020,3 +2120,22 @@ uw_Basis_string uw_Basis_sigString(uw_context ctx, uw_unit u) { return uw_cookie_sig(ctx); } + +uw_Basis_string uw_Basis_fileName(uw_context ctx, uw_Basis_file f) { + return f.name; +} + +uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { + return f.data; +} + +uw_Basis_int uw_Basis_numFiles(uw_context ctx, uw_Basis_files fs) { + return fs.size; +} + +uw_Basis_file uw_Basis_fileNum(uw_context ctx, uw_Basis_files fs, uw_Basis_int n) { + if (n < 0 || n >= fs.size) + uw_error(ctx, FATAL, "Files index out of bounds"); + else + return fs.files[n]; +}
--- a/src/cjr_print.sml Thu Apr 23 16:13:02 2009 -0400 +++ b/src/cjr_print.sml Sat Apr 25 13:59:11 2009 -0400 @@ -400,7 +400,7 @@ if wontLeakStrings then e else - box [string "uw_Basis_strdup(ctx, ", e, string ")"] + box [string "uw_strdup(ctx, ", e, string ")"] | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] @@ -447,10 +447,20 @@ | String | Bool | Time + | Blob | Channel | Client | Nullable of sql_type +fun isBlob Blob = true + | isBlob (Nullable t) = isBlob t + | isBlob _ = false + +fun isFiles (t : typ) = + case #1 t of + TFfi ("Basis", "files") => true + | _ => false + fun p_sql_type' t = case t of Int => "uw_Basis_int" @@ -458,6 +468,7 @@ | String => "uw_Basis_string" | Bool => "uw_Basis_bool" | Time => "uw_Basis_time" + | Blob => "uw_Basis_blob" | Channel => "uw_Basis_channel" | Client => "uw_Basis_client" | Nullable String => "uw_Basis_string" @@ -475,6 +486,7 @@ | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] + | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)] | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)] @@ -501,6 +513,7 @@ | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"] + | Blob => box [e, string ".data"] | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"] | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"] | Nullable String => e @@ -534,6 +547,7 @@ | SOME t => nl ok' t) cons end) | TFfi ("Basis", "string") => false + | TFfi ("Basis", "blob") => false | TFfi _ => true | TOption t => allowHeapAllocated andalso nl ok t in @@ -1478,6 +1492,19 @@ newline, newline, + string "const int paramFormats[] = { ", + p_list_sep (box [string ",", space]) + (fn (_, t) => if isBlob t then string "1" else string "0") ets, + string " };", + newline, + string "const int paramLengths[] = { ", + p_list_sepi (box [string ",", space]) + (fn i => fn (_, Blob) => string ("arg" ^ Int.toString (i + 1) ^ ".size") + | (_, Nullable Blob) => string ("arg" ^ Int.toString (i + 1) + ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") + | _ => string "0") ets, + string " };", + newline, string "const char *paramValues[] = { ", p_list_sepi (box [string ",", space]) (fn i => fn (_, t) => p_ensql t (box [string "arg", @@ -1495,7 +1522,7 @@ string (Int.toString n), string "\", ", string (Int.toString (length (getPargs query))), - string ", paramValues, NULL, NULL, 0);"], + string ", paramValues, paramLengths, paramFormats, 0);"], newline, newline, @@ -1790,7 +1817,7 @@ in box [string "({", newline, - string "uw_Basis_string request = uw_Basis_maybe_strdup(ctx, ", + string "uw_Basis_string request = uw_maybe_strdup(ctx, ", p_exp env e, string ");", newline, @@ -2173,6 +2200,7 @@ | TFfi ("Basis", "string") => "text" | TFfi ("Basis", "bool") => "bool" | TFfi ("Basis", "time") => "timestamp" + | TFfi ("Basis", "blob") => "bytea" | TFfi ("Basis", "channel") => "int8" | TFfi ("Basis", "client") => "int4" | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; @@ -2382,26 +2410,37 @@ (TFfi ("Basis", "bool"), _) => "optional_" | _ => "" in - box [string "request = uw_get_", - string f, - string "input(ctx, ", - string (Int.toString n), - string ");", - newline, - string "if (request == NULL)", - newline, - box [string "uw_error(ctx, FATAL, \"Missing input ", - string x, - string "\");"], - newline, - string "uw_input_", - p_ident x, - space, - string "=", - space, - unurlify env t, - string ";", - newline] + if isFiles t then + box [string "uw_input_", + p_ident x, + space, + string "=", + space, + string "uw_get_file_input(ctx, ", + string (Int.toString n), + string ");", + newline] + else + box [string "request = uw_get_", + string f, + string "input(ctx, ", + string (Int.toString n), + string ");", + newline, + string "if (request == NULL)", + newline, + box [string "uw_error(ctx, FATAL, \"Missing input ", + string x, + string "\");"], + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + unurlify env t, + string ";", + newline] end) xts), string "struct __uws_", string (Int.toString i),
--- a/src/marshalcheck.sml Thu Apr 23 16:13:02 2009 -0400 +++ b/src/marshalcheck.sml Sat Apr 25 13:59:11 2009 -0400 @@ -57,6 +57,7 @@ ("Basis", "float"), ("Basis", "string"), ("Basis", "time"), + ("Basis", "files"), ("Basis", "unit"), ("Basis", "option"), ("Basis", "bool")]
--- a/src/monoize.sml Thu Apr 23 16:13:02 2009 -0400 +++ b/src/monoize.sml Sat Apr 25 13:59:11 2009 -0400 @@ -1663,6 +1663,10 @@ ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_blob") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) => ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc), @@ -2339,6 +2343,7 @@ raise Fail "No name passed to ltextarea tag")) | "checkbox" => input "checkbox" + | "upload" => input "file" | "radio" => (case targs of @@ -2475,6 +2480,13 @@ fm) end + val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = fn e => + case e of + L.EFfi ("Basis", "upload") => true + | _ => false} xml + val (xml, fm) = monoExp (env, st, fm) xml val xml = @@ -2514,6 +2526,13 @@ end else xml + + val action = if hasUpload then + (L'.EStrcat (action, + (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc) + else + action + in ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), (L'.EStrcat (action,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/blob.ur Sat Apr 25 13:59:11 2009 -0400 @@ -0,0 +1,22 @@ +sequence s +table t : { Id : int, Nam : option string, Data : blob, Desc : string } + +fun save r = + if numFiles r.Data <> 1 then + error <xml>Please submit exactly one file.</xml> + else + let + val f = fileNum r.Data 0 + in + id <- nextval s; + dml (INSERT INTO t (Id, Nam, Data, Desc) VALUES ({[id]}, {[fileName f]}, {[fileData f]}, {[r.Desc]})); + main () + end + +and main () = return <xml><body> + <form> + <textbox{#Desc}/> + <upload{#Data}/> + <submit action={save}/> + </form> +</body></xml>