Mercurial > urweb
changeset 1104:72670131dace
Basis.serialize; separate file for mhash; run transactional finishers in reverse order; set needs_sig properly
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 31 Dec 2009 11:41:57 -0500 |
| parents | 2f42c61b8d0a |
| children | a5c160636832 |
| files | Makefile.in lib/ur/basis.urs src/c/mhash.c src/c/request.c src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/compiler.sml src/core.sml src/core_print.sml src/corify.sml src/effectize.sml src/marshalcheck.sml src/mono.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/pathcheck.sml src/rpcify.sml src/scriptcheck.sml src/shake.sml src/tag.sml |
| diffstat | 24 files changed, 169 insertions(+), 116 deletions(-) [+] |
line wrap: on
line diff
--- a/Makefile.in Wed Dec 30 09:52:18 2009 -0500 +++ b/Makefile.in Thu Dec 31 11:41:57 2009 -0500 @@ -17,7 +17,7 @@ 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/%.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 $@ $^
--- a/lib/ur/basis.urs Wed Dec 30 09:52:18 2009 -0500 +++ b/lib/ur/basis.urs Thu Dec 31 11:41:57 2009 -0500 @@ -194,6 +194,11 @@ 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}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/c/mhash.c Thu Dec 31 11:41:57 2009 -0500 @@ -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"); +}
--- a/src/c/request.c Wed Dec 30 09:52:18 2009 -0500 +++ b/src/c/request.c Thu Dec 31 11:41:57 2009 -0500 @@ -67,35 +67,6 @@ 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 @@ } 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;
--- a/src/c/urweb.c Wed Dec 30 09:52:18 2009 -0500 +++ b/src/c/urweb.c Thu Dec 31 11:41:57 2009 -0500 @@ -289,10 +289,14 @@ // 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 @@ ctx->script_header = ""; ctx->needs_push = 0; ctx->needs_sig = 0; - + ctx->error_message[0] = 0; ctx->source_count = 0; @@ -2766,14 +2770,14 @@ } void uw_commit(uw_context ctx) { - unsigned i; - - for (i = 0; i < ctx->used_transactionals; ++i) + int 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 @@ 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 @@ } int uw_rollback(uw_context ctx) { - size_t i; + int i; cleanup *cl; if (ctx->client) @@ -2843,11 +2847,11 @@ 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);
--- a/src/cjr.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/cjr.sml Thu Dec 31 11:41:57 2009 -0500 @@ -132,6 +132,6 @@ 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
--- a/src/cjr_print.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/cjr_print.sml Thu Dec 31 11:41:57 2009 -0500 @@ -2184,7 +2184,7 @@ 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 @@ 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 @@ string ");", newline, string "uw_set_needs_sig(ctx, ", - string (if couldWrite ek then + string (if tellSig then "1" else "0"),
--- a/src/cjrize.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/cjrize.sml Thu Dec 31 11:41:57 2009 -0500 @@ -590,12 +590,12 @@ (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) =>
--- a/src/compiler.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/compiler.sml Thu Dec 31 11:41:57 2009 -0500 @@ -1029,7 +1029,7 @@ 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
--- a/src/core.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/core.sml Thu Dec 31 11:41:57 2009 -0500 @@ -127,7 +127,7 @@ | 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
--- a/src/core_print.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/core_print.sml Thu Dec 31 11:41:57 2009 -0500 @@ -547,16 +547,16 @@ 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,
--- a/src/corify.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/corify.sml Thu Dec 31 11:41:57 2009 -0500 @@ -1001,7 +1001,7 @@ 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
--- a/src/effectize.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/effectize.sml Thu Dec 31 11:41:57 2009 -0500 @@ -66,6 +66,15 @@ 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 @@ 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 @@ 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 @@ (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 @@ 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
--- a/src/marshalcheck.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/marshalcheck.sml Thu Dec 31 11:41:57 2009 -0500 @@ -89,7 +89,7 @@ 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) =>
--- a/src/mono.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/mono.sml Thu Dec 31 11:41:57 2009 -0500 @@ -127,7 +127,7 @@ 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
--- a/src/mono_print.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/mono_print.sml Thu Dec 31 11:41:57 2009 -0500 @@ -423,23 +423,23 @@ 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,
--- a/src/mono_shake.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/mono_shake.sml Thu Dec 31 11:41:57 2009 -0500 @@ -54,7 +54,7 @@ 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
--- a/src/mono_util.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/mono_util.sml Thu Dec 31 11:41:57 2009 -0500 @@ -507,12 +507,12 @@ 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' =>
--- a/src/monoize.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/monoize.sml Thu Dec 31 11:41:57 2009 -0500 @@ -162,6 +162,9 @@ (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 @@ ((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 @@ 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 @@ 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 @@ 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 @@ (* 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
--- a/src/pathcheck.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/pathcheck.sml Thu Dec 31 11:41:57 2009 -0500 @@ -67,7 +67,7 @@ (funcs, rels, cookies, SS.add (styles, s))) in case d of - DExport (_, s, _, _, _) => doFunc s + DExport (_, s, _, _, _, _) => doFunc s | DTable (s, _, pe, ce) => let
--- a/src/rpcify.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/rpcify.sml Thu Dec 31 11:41:57 2009 -0500 @@ -107,7 +107,7 @@ (#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}
--- a/src/scriptcheck.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/scriptcheck.sml Thu Dec 31 11:41:57 2009 -0500 @@ -159,7 +159,7 @@ 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 @@ else if IS.member (pull_ids, n) then ServerAndPull else - ServerOnly)) ps + ServerOnly, + b)) ps in (ds, ps) end
--- a/src/shake.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/shake.sml Thu Dec 31 11:41:57 2009 -0500 @@ -67,7 +67,7 @@ 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
--- a/src/tag.sml Wed Dec 30 09:52:18 2009 -0500 +++ b/src/tag.sml Thu Dec 31 11:41:57 2009 -0500 @@ -197,7 +197,7 @@ 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 @@ 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