summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/types.h13
-rw-r--r--include/urweb.h15
-rw-r--r--lib/ur/basis.urs12
-rw-r--r--src/c/driver.c198
-rw-r--r--src/c/urweb.c151
-rw-r--r--src/cjr_print.sml85
-rw-r--r--src/marshalcheck.sml1
-rw-r--r--src/monoize.sml19
-rw-r--r--tests/blob.ur22
-rw-r--r--tests/blob.urp5
-rw-r--r--tests/blob.urs1
11 files changed, 454 insertions, 68 deletions
diff --git a/include/types.h b/include/types.h
index c80653d3..0cb81cb5 100644
--- a/include/types.h
+++ b/include/types.h
@@ -4,6 +4,10 @@ typedef long long uw_Basis_int;
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 @@ typedef struct {
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;
diff --git a/include/urweb.h b/include/urweb.h
index 99ae3e69..4244aa6d 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -39,10 +39,13 @@ void uw_memstats(uw_context);
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_bool uw_Basis_unurlifyBool(uw_context, char **);
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_Basis_bless(uw_context, uw_Basis_string);
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);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 99ac50fe..ce969a37 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -2,6 +2,7 @@ type int
type float
type string
type time
+type blob
type unit = {}
@@ -134,6 +135,7 @@ val sql_int : sql_injectable_prim int
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 textarea : formTag string [] [Rows = int, Cols = int]
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 [] [] []
diff --git a/src/c/driver.c b/src/c/driver.c
index f7456ed9..fa4f474b 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -1,5 +1,6 @@
-#include <stdio.h>
+#define _GNU_SOURCE
+#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
@@ -147,9 +148,11 @@ void uw_sign(const char *in, char *out) {
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
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 @@ static void *worker(void *data) {
}
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 @@ static void *worker(void *data) {
break;
}
- 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);
+ if (boundary) {
+ char *part = after_headers, *after_sub_headers, *header, *after_header;
+ size_t part_len;
+
+ part = strstr(part, boundary);
+ if (!part) {
+ fprintf(stderr, "Missing first multipart boundary\n");
+ break;
+ }
+ part += boundary_len;
+
+ 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;
+ }
+ ++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, "");
}
- else
- uw_set_input(ctx, name, "");
}
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 6266e12d..99564605 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -282,11 +282,23 @@ typedef struct {
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 @@ uw_context uw_init() {
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_keep_request(uw_context ctx) {
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 @@ char *uw_error_message(uw_context ctx) {
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 @@ void uw_set_input(uw_context ctx, char *name, char *value) {
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 @@ char *uw_get_input(uw_context ctx, int n) {
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 @@ char *uw_get_optional_input(uw_context ctx, int n) {
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 @@ uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_str
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 @@ uw_Basis_string uw_Basis_strdup(uw_context ctx, uw_Basis_string s1) {
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 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
if (isprint(c))
*s2++ = c;
else {
- sprintf(s2, "\\%3o", c);
+ sprintf(s2, "\\%03o", c);
s2 += 4;
}
}
@@ -1488,6 +1551,43 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
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_makeSigString(uw_context ctx, uw_Basis_string sig) {
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];
+}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 69332b49..8450c467 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -400,7 +400,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
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 @@ datatype sql_type =
| 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 @@ fun p_sql_type' t =
| 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 @@ fun getPargs (e, _) =
| 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 @@ fun p_ensql t e =
| 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 @@ fun notLeaky env allowHeapAllocated =
| 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 @@ fun p_exp' par env (e, loc) =
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 @@ fun p_exp' par env (e, loc) =
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 @@ fun p_exp' par env (e, loc) =
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 @@ fun p_sqltype'' env (tAll as (t, loc)) =
| 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 @@ fun p_file env (ds, ps) =
(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),
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index c48fd14f..3d517779 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -57,6 +57,7 @@ val clientToServer = [("Basis", "int"),
("Basis", "float"),
("Basis", "string"),
("Basis", "time"),
+ ("Basis", "files"),
("Basis", "unit"),
("Basis", "option"),
("Basis", "bool")]
diff --git a/src/monoize.sml b/src/monoize.sml
index 62a46277..8ccb84fc 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1663,6 +1663,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
raise Fail "No name passed to ltextarea tag"))
| "checkbox" => input "checkbox"
+ | "upload" => input "file"
| "radio" =>
(case targs of
@@ -2475,6 +2480,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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,
diff --git a/tests/blob.ur b/tests/blob.ur
new file mode 100644
index 00000000..a62eefc1
--- /dev/null
+++ b/tests/blob.ur
@@ -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>
diff --git a/tests/blob.urp b/tests/blob.urp
new file mode 100644
index 00000000..2c6be994
--- /dev/null
+++ b/tests/blob.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=blob
+sql blob.sql
+
+blob
diff --git a/tests/blob.urs b/tests/blob.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/blob.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-16 23:09:39 +0000