summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-12-31 11:41:57 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-12-31 11:41:57 -0500
commit21678b3f280cd85961e3354faecc29aab4819de4 (patch)
treebd23d8cf5bd50193307b43173436dee92553e4cd
parentc0b98201e7415eeada11e08c69264cf165bba50f (diff)
Basis.serialize; separate file for mhash; run transactional finishers in reverse order; set needs_sig properly
-rw-r--r--Makefile.in4
-rw-r--r--lib/ur/basis.urs5
-rw-r--r--src/c/mhash.c41
-rw-r--r--src/c/request.c41
-rw-r--r--src/c/urweb.c20
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/compiler.sml2
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml20
-rw-r--r--src/corify.sml2
-rw-r--r--src/effectize.sml44
-rw-r--r--src/marshalcheck.sml2
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml34
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sml4
-rw-r--r--src/monoize.sml31
-rw-r--r--src/pathcheck.sml2
-rw-r--r--src/rpcify.sml2
-rw-r--r--src/scriptcheck.sml5
-rw-r--r--src/shake.sml2
-rw-r--r--src/tag.sml4
24 files changed, 168 insertions, 115 deletions
diff --git a/Makefile.in b/Makefile.in
index 5016abb3..32e123b4 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -17,7 +17,7 @@ all: smlnj mlton c
smlnj: src/urweb.cm
mlton: bin/urweb
-OBJS := memmem urweb request queue http cgi fastcgi
+OBJS := memmem mhash urweb request queue http cgi fastcgi
SOS := urweb urweb_http urweb_cgi urweb_fastcgi
c: $(OBJS:%=lib/c/%.o) $(SOS:%=lib/c/lib%.so.$(LD_MAJOR).$(LD_MINOR))
@@ -33,7 +33,7 @@ lib/c/%.do: src/c/%.c include/*.h
lib/c/%.o: src/c/%.c include/*.h
gcc -Wimplicit -O3 -I include -c $< -o $@ $(CFLAGS)
-URWEB_OS := memmem urweb queue request
+URWEB_OS := memmem urweb queue request mhash
lib/c/liburweb.so.$(LD_MAJOR).$(LD_MINOR): $(URWEB_OS:%=lib/c/%.do)
gcc -shared -Wl,-soname,liburweb.so.$(LD_MAJOR) -o $@ $^
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ffce96c0..330bea31 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -194,6 +194,11 @@ val sql_blob : sql_injectable_prim blob
val sql_channel : t ::: Type -> sql_injectable_prim (channel t)
val sql_client : sql_injectable_prim client
+con serialized :: Type -> Type
+val serialize : t ::: Type -> t -> serialized t
+val deserialize : t ::: Type -> serialized t -> t
+val sql_serialized : t ::: Type -> sql_injectable_prim (serialized t)
+
con primary_key :: {Type} -> {{Unit}} -> Type
val no_primary_key : fs ::: {Type} -> primary_key fs []
val primary_key : rest ::: {Type} -> t ::: Type -> key1 :: Name -> keys :: {Type}
diff --git a/src/c/mhash.c b/src/c/mhash.c
new file mode 100644
index 00000000..becb9d97
--- /dev/null
+++ b/src/c/mhash.c
@@ -0,0 +1,41 @@
+#include <mhash.h>
+
+#define KEYSIZE 16
+#define PASSSIZE 4
+
+#define HASH_ALGORITHM MHASH_SHA256
+#define HASH_BLOCKSIZE 32
+#define KEYGEN_ALGORITHM KEYGEN_MCRYPT
+
+int uw_hash_blocksize = HASH_BLOCKSIZE;
+
+static int password[PASSSIZE];
+static unsigned char private_key[KEYSIZE];
+
+void uw_init_crypto() {
+ KEYGEN kg = {{HASH_ALGORITHM, HASH_ALGORITHM}};
+ int i;
+
+ assert(mhash_get_block_size(HASH_ALGORITHM) == HASH_BLOCKSIZE);
+
+ for (i = 0; i < PASSSIZE; ++i)
+ password[i] = rand();
+
+ if (mhash_keygen_ext(KEYGEN_ALGORITHM, kg,
+ private_key, sizeof(private_key),
+ (unsigned char*)password, sizeof(password)) < 0) {
+ fprintf(stderr, "Key generation failed\n");
+ exit(1);
+ }
+}
+
+void uw_sign(const char *in, char *out) {
+ MHASH td;
+
+ td = mhash_hmac_init(HASH_ALGORITHM, private_key, sizeof(private_key),
+ mhash_get_hash_pblock(HASH_ALGORITHM));
+
+ mhash(td, in, strlen(in));
+ if (mhash_hmac_deinit(td, out) < 0)
+ fprintf(stderr, "Signing failed\n");
+}
diff --git a/src/c/request.c b/src/c/request.c
index 5c8159cc..f190ec98 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -67,35 +67,6 @@ uw_context uw_request_new_context(uw_app *app, void *logger_data, uw_logger log_
return ctx;
}
-#define KEYSIZE 16
-#define PASSSIZE 4
-
-#define HASH_ALGORITHM MHASH_SHA256
-#define HASH_BLOCKSIZE 32
-#define KEYGEN_ALGORITHM KEYGEN_MCRYPT
-
-int uw_hash_blocksize = HASH_BLOCKSIZE;
-
-static int password[PASSSIZE];
-static unsigned char private_key[KEYSIZE];
-
-static void init_crypto(void *logger_data, uw_logger log_error) {
- KEYGEN kg = {{HASH_ALGORITHM, HASH_ALGORITHM}};
- int i;
-
- assert(mhash_get_block_size(HASH_ALGORITHM) == HASH_BLOCKSIZE);
-
- for (i = 0; i < PASSSIZE; ++i)
- password[i] = rand();
-
- if (mhash_keygen_ext(KEYGEN_ALGORITHM, kg,
- private_key, sizeof(private_key),
- (unsigned char*)password, sizeof(password)) < 0) {
- log_error(logger_data, "Key generation failed\n");
- exit(1);
- }
-}
-
void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) {
uw_context ctx;
failure_kind fk;
@@ -121,20 +92,8 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log
}
uw_free(ctx);
-
- init_crypto(logger_data, log_error);
}
-void uw_sign(const char *in, char *out) {
- MHASH td;
-
- td = mhash_hmac_init(HASH_ALGORITHM, private_key, sizeof(private_key),
- mhash_get_hash_pblock(HASH_ALGORITHM));
-
- mhash(td, in, strlen(in));
- if (mhash_hmac_deinit(td, out) < 0)
- fprintf(stderr, "Signing failed\n");
-}
typedef struct uw_rc {
size_t path_copy_size;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 455b3e1e..3773e1fb 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -289,10 +289,14 @@ static void client_send(client *c, buf *msg) {
// Global entry points
+extern void uw_init_crypto();
+
void uw_global_init() {
srand(time(NULL) ^ getpid());
clients = malloc(0);
+
+ uw_init_crypto();
}
void uw_app_init(uw_app *app) {
@@ -420,7 +424,7 @@ uw_context uw_init() {
ctx->script_header = "";
ctx->needs_push = 0;
ctx->needs_sig = 0;
-
+
ctx->error_message[0] = 0;
ctx->source_count = 0;
@@ -2766,14 +2770,14 @@ uw_unit uw_Basis_send(uw_context ctx, uw_Basis_channel chn, uw_Basis_string msg)
}
void uw_commit(uw_context ctx) {
- unsigned i;
+ int i;
- for (i = 0; i < ctx->used_transactionals; ++i)
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
if (ctx->transactionals[i].rollback != NULL)
if (ctx->transactionals[i].commit)
ctx->transactionals[i].commit(ctx->transactionals[i].data);
- for (i = 0; i < ctx->used_transactionals; ++i)
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
if (ctx->transactionals[i].rollback == NULL)
if (ctx->transactionals[i].commit)
ctx->transactionals[i].commit(ctx->transactionals[i].data);
@@ -2793,7 +2797,7 @@ void uw_commit(uw_context ctx) {
if (ctx->client)
release_client(ctx->client);
- for (i = 0; i < ctx->used_transactionals; ++i)
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
if (ctx->transactionals[i].free)
ctx->transactionals[i].free(ctx->transactionals[i].data);
@@ -2832,7 +2836,7 @@ void uw_commit(uw_context ctx) {
}
int uw_rollback(uw_context ctx) {
- size_t i;
+ int i;
cleanup *cl;
if (ctx->client)
@@ -2843,11 +2847,11 @@ int uw_rollback(uw_context ctx) {
ctx->cleanup_front = ctx->cleanup;
- for (i = 0; i < ctx->used_transactionals; ++i)
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
if (ctx->transactionals[i].rollback != NULL)
ctx->transactionals[i].rollback(ctx->transactionals[i].data);
- for (i = 0; i < ctx->used_transactionals; ++i)
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
if (ctx->transactionals[i].free)
ctx->transactionals[i].free(ctx->transactionals[i].data);
diff --git a/src/cjr.sml b/src/cjr.sml
index f5392d49..53448a29 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -132,6 +132,6 @@ datatype sidedness =
datatype effect = datatype Export.effect
datatype export_kind = datatype Export.export_kind
-type file = decl list * (export_kind * string * int * typ list * typ * sidedness) list
+type file = decl list * (export_kind * string * int * typ list * typ * sidedness * bool) list
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 30e34fad..9f63edaf 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2184,7 +2184,7 @@ fun p_file env (ds, ps) =
end
| _ => NONE
- val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
+ val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
case ek of
Link => fields
| Rpc _ => fields
@@ -2480,7 +2480,7 @@ fun p_file env (ds, ps) =
newline]
end
- fun p_page (ek, s, n, ts, ran, side) =
+ fun p_page (ek, s, n, ts, ran, side, tellSig) =
let
val (ts, defInputs, inputsVar, fields) =
case ek of
@@ -2612,7 +2612,7 @@ fun p_file env (ds, ps) =
string ");",
newline,
string "uw_set_needs_sig(ctx, ",
- string (if couldWrite ek then
+ string (if tellSig then
"1"
else
"0"),
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 0136bdf6..e2807372 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -590,12 +590,12 @@ fun cifyDecl ((d, loc), sm) =
(SOME (L'.DFunRec vis, loc), NONE, sm)
end
- | L.DExport (ek, s, n, ts, t) =>
+ | L.DExport (ek, s, n, ts, t, b) =>
let
val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
val (t, sm) = cifyTyp (t, sm)
in
- (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm)
+ (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm)
end
| L.DTable (s, xts, pe, ce) =>
diff --git a/src/compiler.sml b/src/compiler.sml
index 28b8dc2c..026df6fd 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1029,7 +1029,7 @@ fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
val lib = if Settings.getStaticLinking () then
clibFile "request.o" ^ " " ^ clibFile "queue.o" ^ " " ^ clibFile "urweb.o"
- ^ " " ^ clibFile "memmem.o" ^ " " ^ #linkStatic proto
+ ^ " " ^ clibFile "memmem.o" ^ " " ^ clibFile "mhash.o" ^ " " ^ #linkStatic proto
else
"-L" ^ Config.libC ^ " -lurweb " ^ #linkDynamic proto
diff --git a/src/core.sml b/src/core.sml
index 78a1eded..90005f16 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -127,7 +127,7 @@ datatype decl' =
| DDatatype of (string * int * string list * (string * int * con option) list) list
| DVal of string * int * con * exp * string
| DValRec of (string * int * con * exp * string) list
- | DExport of export_kind * int
+ | DExport of export_kind * int * bool
| DTable of string * int * con * string * exp * con * exp * con
| DSequence of string * int * string
| DView of string * int * string * exp * con
diff --git a/src/core_print.sml b/src/core_print.sml
index c1f93587..d6be76a3 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -547,16 +547,16 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
- | DExport (ek, n) => box [string "export",
- space,
- Export.p_export_kind ek,
- space,
- p_enamed env n,
- space,
- string "as",
- space,
- (p_con env (#2 (E.lookupENamed env n))
- handle E.UnboundNamed _ => string "UNBOUND")]
+ | DExport (ek, n, _) => box [string "export",
+ space,
+ Export.p_export_kind ek,
+ space,
+ p_enamed env n,
+ space,
+ string "as",
+ space,
+ (p_con env (#2 (E.lookupENamed env n))
+ handle E.UnboundNamed _ => string "UNBOUND")]
| DTable (x, n, c, s, pe, _, ce, _) => box [string "table",
space,
p_named x n,
diff --git a/src/corify.sml b/src/corify.sml
index 9259b4f2..a1a5c745 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1001,7 +1001,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
e), loc) :: wds,
(fn st =>
case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
- L'.ENamed n => (L'.DExport (L'.Link, n), loc)
+ L'.ENamed n => (L'.DExport (L'.Link, n, false), loc)
| _ => raise Fail "Corify: Value to export didn't corify properly")
:: eds)
else
diff --git a/src/effectize.sml b/src/effectize.sml
index fcaaa79e..1685fbe9 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -66,6 +66,15 @@ fun effectize file =
con = fn _ => false,
exp = exp evs}
+ fun exp writers readers e =
+ case e of
+ EServerCall (n, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n)
+ | _ => false
+
+ fun couldWriteWithRpc writers readers = U.Exp.exists {kind = fn _ => false,
+ con = fn _ => false,
+ exp = exp writers readers}
+
fun exp evs e =
case e of
EFfi ("Basis", "getCookie") => true
@@ -77,7 +86,7 @@ fun effectize file =
con = fn _ => false,
exp = exp evs}
- fun doDecl (d, evs as (writers, readers)) =
+ fun doDecl (d, evs as (writers, readers, pushers)) =
case #1 d of
DVal (x, n, t, e, s) =>
(d, (if couldWrite writers e then
@@ -87,11 +96,15 @@ fun effectize file =
if couldReadCookie readers e then
IM.insert (readers, n, (#2 d, s))
else
- readers))
+ readers,
+ if couldWriteWithRpc writers readers e then
+ IM.insert (pushers, n, (#2 d, s))
+ else
+ pushers))
| DValRec vis =>
let
fun oneRound evs =
- foldl (fn ((_, n, _, e, s), (changed, (writers, readers))) =>
+ foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) =>
let
val (changed, writers) =
if couldWrite writers e andalso not (IM.inDomain (writers, n)) then
@@ -104,8 +117,15 @@ fun effectize file =
(true, IM.insert (readers, n, (#2 d, s)))
else
(changed, readers)
+
+ val (changed, pushers) =
+ if couldWriteWithRpc writers readers e
+ andalso not (IM.inDomain (pushers, n)) then
+ (true, IM.insert (pushers, n, (#2 d, s)))
+ else
+ (changed, pushers)
in
- (changed, (writers, readers))
+ (changed, (writers, readers, pushers))
end) (false, evs) vis
fun loop evs =
@@ -118,34 +138,34 @@ fun effectize file =
evs
end
in
- (d, loop (writers, readers))
+ (d, loop (writers, readers, pushers))
end
- | DExport (Link, n) =>
+ | DExport (Link, n, _) =>
(case IM.find (writers, n) of
NONE => ()
| SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
- (d, evs))
- | DExport (Action _, n) =>
+ ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs))
+ | DExport (Action _, n, _) =>
((DExport (Action (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
- ReadOnly), n), #2 d),
+ ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
evs)
- | DExport (Rpc _, n) =>
+ | DExport (Rpc _, n, _) =>
((DExport (Rpc (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
ReadCookieWrite
else
ReadWrite
else
- ReadOnly), n), #2 d),
+ ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
evs)
| _ => (d, evs)
- val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
+ val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file
in
file
end
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index 10129aef..de6879ae 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -89,7 +89,7 @@ fun check file =
foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag)))
emap vis)
- | DExport (_, n) =>
+ | DExport (_, n, _) =>
(case IM.find (emap, n) of
NONE => raise Fail "MarshalCheck: Unknown export"
| SOME (t, tag) =>
diff --git a/src/mono.sml b/src/mono.sml
index e5e68bfa..af5e9031 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -127,7 +127,7 @@ datatype decl' =
DDatatype of (string * int * (string * int * typ option) list) list
| DVal of string * int * typ * exp * string
| DValRec of (string * int * typ * exp * string) list
- | DExport of export_kind * string * int * typ list * typ
+ | DExport of export_kind * string * int * typ list * typ * bool
| DTable of string * (string * typ) list * exp * exp
| DSequence of string
diff --git a/src/mono_print.sml b/src/mono_print.sml
index da34c220..d190640e 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -423,23 +423,23 @@ fun p_decl env (dAll as (d, _) : decl) =
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
- | DExport (ek, s, n, ts, t) => box [string "export",
- space,
- Export.p_export_kind ek,
- space,
- p_enamed env n,
- space,
- string "as",
- space,
- string s,
- p_list_sep (string "") (fn t => box [space,
- string "(",
- p_typ env t,
- string ")"]) ts,
- space,
- string "->",
- space,
- p_typ env t]
+ | DExport (ek, s, n, ts, t, _) => box [string "export",
+ space,
+ Export.p_export_kind ek,
+ space,
+ p_enamed env n,
+ space,
+ string "as",
+ space,
+ string s,
+ p_list_sep (string "") (fn t => box [space,
+ string "(",
+ p_typ env t,
+ string ")"]) ts,
+ space,
+ string "->",
+ space,
+ p_typ env t]
| DTable (s, xts, pe, ce) => box [string "(* SQL table ",
string s,
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 048cc190..e53b6930 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -54,7 +54,7 @@ fun shake file =
val (page_cs, page_es) =
List.foldl
- (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
+ (fn ((DExport (_, _, n, _, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
| ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
(page_cs, IS.addList (page_es, [n1, n2]))
| ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 894e35d0..02619437 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -507,12 +507,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
fn vis' =>
(DValRec vis', loc))
end
- | DExport (ek, s, n, ts, t) =>
+ | DExport (ek, s, n, ts, t, b) =>
S.bind2 (ListUtil.mapfold mft ts,
fn ts' =>
S.map2 (mft t,
fn t' =>
- (DExport (ek, s, n, ts', t'), loc)))
+ (DExport (ek, s, n, ts', t', b), loc)))
| DTable (s, xts, pe, ce) =>
S.bind2 (mfe ctx pe,
fn pe' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 0f03111c..afe2012f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -162,6 +162,9 @@ fun monoType env =
(L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
@@ -1975,6 +1978,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
fm)
+ | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
+ ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
+ (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
+ fm)
| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
let
val t = monoType env t
@@ -3235,6 +3242,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
+ let
+ val t = monoType env t
+ val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
+ in
+ ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
+ fm)
+ end
+ | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t), loc)), loc),
+ fm)
+ end
+
| L.EFfiApp ("Basis", "url", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
@@ -3432,7 +3455,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
fm,
[(L'.DValRec vis, loc)])
end
- | L.DExport (ek, n) =>
+ | L.DExport (ek, n, b) =>
let
val (_, t, _, s) = Env.lookupENamed env n
@@ -3447,7 +3470,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val ts = map (monoType env) ts
val ran = monoType env ran
in
- SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
+ SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
end
| L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
let
@@ -3538,8 +3561,8 @@ fun monoize env file =
(* Calculate which exported functions need cookie signature protection *)
val rcook = foldl (fn ((d, _), rcook) =>
case d of
- L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n)
- | L.DExport (L.Rpc L.ReadCookieWrite, n) => IS.add (rcook, n)
+ L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
+ | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
| _ => rcook)
IS.empty file
val () = readCookie := rcook
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index a493595d..15405db7 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -67,7 +67,7 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) =
(funcs, rels, cookies, SS.add (styles, s)))
in
case d of
- DExport (_, s, _, _, _) => doFunc s
+ DExport (_, s, _, _, _, _) => doFunc s
| DTable (s, _, pe, ce) =>
let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 3569e2bc..63330942 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -107,7 +107,7 @@ fun frob file =
(#exported st, #export_decls st)
else
(IS.add (#exported st, n),
- (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
+ (DExport (Rpc ReadWrite, n, false), loc) :: #export_decls st)
val st = {exported = exported,
export_decls = export_decls}
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 5cd056d5..7dec8d80 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -159,7 +159,7 @@ fun classify (ds, ps) =
val foundBad = ref false
- val ps = map (fn (ek, x, n, ts, t, _) =>
+ val ps = map (fn (ek, x, n, ts, t, _, b) =>
(ek, x, n, ts, t,
if IS.member (push_ids, n) then
(if not (#persistent proto) andalso not (!foundBad) then
@@ -172,7 +172,8 @@ fun classify (ds, ps) =
else if IS.member (pull_ids, n) then
ServerAndPull
else
- ServerOnly)) ps
+ ServerOnly,
+ b)) ps
in
(ds, ps)
end
diff --git a/src/shake.sml b/src/shake.sml
index ae3e2ea5..39ebdde0 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -67,7 +67,7 @@ fun shake file =
val (usedE, usedC) =
List.foldl
- (fn ((DExport (_, n), _), (usedE, usedC)) => (IS.add (usedE, n), usedC)
+ (fn ((DExport (_, n, _), _), (usedE, usedC)) => (IS.add (usedE, n), usedC)
| ((DTable (_, _, c, _, pe, pc, ce, cc), _), (usedE, usedC)) =>
let
val usedC = usedVarsC usedC c
diff --git a/src/tag.sml b/src/tag.sml
index f1aef1ce..fdc04c81 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -197,7 +197,7 @@ fun tag file =
fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
case d' of
- DExport (ek, n) =>
+ DExport (ek, n, _) =>
let
val (_, _, _, s) = E.lookupENamed env n
in
@@ -276,7 +276,7 @@ fun tag file =
end
in
(("wrap_" ^ fnam, cn, t, abs, tag),
- (DExport (ek, cn), loc))
+ (DExport (ek, cn, false), loc))
end) newTags
val (newVals, newExports) = ListPair.unzip newDs