diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2010-09-07 08:28:07 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2010-09-07 08:28:07 -0400 |
| commit | 5545969f485ef2fb944db8e7b0237acbabeb8d4c (patch) | |
| tree | ab4a39c6f88b3e8719c9e41dfcd7f147126ef790 | |
| parent | ee175ea1f9151123e47d9cbfee0c6329b2e5d934 (diff) | |
Server-side 'onError'
45 files changed, 244 insertions, 59 deletions
diff --git a/include/types.h b/include/types.h index 138760e5..ac70c34f 100644 --- a/include/types.h +++ b/include/types.h @@ -73,6 +73,10 @@ typedef struct { uw_Basis_string (*cookie_sig)(uw_context); int (*check_url)(const char *); int (*check_mime)(const char *); + + void (*on_error)(uw_context, char *); } uw_app; +#define ERROR_BUF_LEN 1024 + #endif diff --git a/include/urweb.h b/include/urweb.h index 32e9b4e1..f254da2a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,6 +36,7 @@ failure_kind uw_begin_init(uw_context); void uw_set_on_success(char *); void uw_set_headers(uw_context, char *(*get_header)(void *, const char *), void *get_header_data); failure_kind uw_begin(uw_context, char *path); +failure_kind uw_begin_onError(uw_context, char *msg); void uw_login(uw_context); void uw_commit(uw_context); int uw_rollback(uw_context); diff --git a/src/c/request.c b/src/c/request.c index 5e57d7b0..f72a3199 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -131,6 +131,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx, char *inputs; const char *prefix = uw_get_url_prefix(ctx); char *s; + int had_error = 0; + char errmsg[ERROR_BUF_LEN]; for (s = path; *s; ++s) { if (s[0] == '%' && s[1] == '2' && s[2] == '7') { @@ -336,32 +338,42 @@ request_result uw_request(uw_request_context rc, uw_context ctx, log_debug(logger_data, "Serving URI %s....\n", path); while (1) { - size_t path_len = strlen(path); + if (!had_error) { + size_t path_len = strlen(path); - on_success(ctx); + on_success(ctx); + + if (path_len + 1 > rc->path_copy_size) { + rc->path_copy_size = path_len + 1; + rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); + } + strcpy(rc->path_copy, path); + fk = uw_begin(ctx, rc->path_copy); + } else + fk = uw_begin_onError(ctx, errmsg); - if (path_len + 1 > rc->path_copy_size) { - rc->path_copy_size = path_len + 1; - rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); - } - strcpy(rc->path_copy, path); - fk = uw_begin(ctx, rc->path_copy); if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { uw_commit(ctx); - if (uw_has_error(ctx)) { + if (uw_has_error(ctx) && !had_error) { log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx)); uw_reset_keep_error_message(ctx); on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n</body></html>"); + + if (uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n</body></html>"); - return FAILED; + return FAILED; + } } else - return SERVED; + return had_error ? FAILED : SERVED; } else if (fk == BOUNDED_RETRY) { if (retries_left) { log_debug(logger_data, "Error triggers bounded retry: %s\n", uw_error_message(ctx)); @@ -372,14 +384,19 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Fatal error (out of retries): "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); - - return FAILED; + if (!had_error && uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Fatal error (out of retries): "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); + + return FAILED; + } } } else if (fk == UNLIMITED_RETRY) log_debug(logger_data, "Error triggers unlimited retry: %s\n", uw_error_message(ctx)); @@ -388,26 +405,36 @@ request_result uw_request(uw_request_context rc, uw_context ctx, try_rollback(ctx, logger_data, log_error); - uw_reset_keep_error_message(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/html\r\n"); - uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); - uw_write(ctx, "Fatal error: "); - uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n</body></html>"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n</body></html>"); - return FAILED; + return FAILED; + } } else { log_error(logger_data, "Unknown uw_handle return code!\n"); try_rollback(ctx, logger_data, log_error); - uw_reset_keep_request(ctx); - on_failure(ctx); - uw_write_header(ctx, "Content-type: text/plain\r\n"); - uw_write(ctx, "Unknown uw_handle return code!\n"); + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, "Unknown uw_handle return code"); + } else { + uw_reset_keep_request(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Unknown uw_handle return code!\n"); - return FAILED; + return FAILED; + } } if (try_rollback(ctx, logger_data, log_error)) diff --git a/src/c/urweb.c b/src/c/urweb.c index 74e1b12e..cac518ec 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -353,8 +353,6 @@ int uw_time = 0; // Single-request state -#define ERROR_BUF_LEN 1024 - typedef struct regions { struct regions *next; } regions; @@ -714,6 +712,22 @@ failure_kind uw_begin(uw_context ctx, char *path) { return r; } +failure_kind uw_begin_onError(uw_context ctx, char *msg) { + int r = setjmp(ctx->jmp_buf); + + if (ctx->app->on_error) { + if (r == 0) { + if (ctx->app->db_begin(ctx)) + uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); + + ctx->app->on_error(ctx, msg); + } + + return r; + } else + uw_error(ctx, FATAL, "Tried to run nonexistent onError handler"); +} + uw_Basis_client uw_Basis_self(uw_context ctx) { if (ctx->client == NULL) uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code"); diff --git a/src/cjr.sml b/src/cjr.sml index f34662dc..5013033f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -124,6 +124,7 @@ datatype decl' = | DStyle of string | DTask of task * exp + | DOnError of int withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index ac83f263..21188b51 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -172,5 +172,6 @@ fun declBinds env (d, loc) = | DCookie _ => env | DStyle _ => env | DTask _ => env + | DOnError _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7331196f..9b5edab5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -113,9 +113,11 @@ and p_typ env = p_typ' false env fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) -fun p_enamed env n = - string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n) - handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n) +fun p_enamed' env n = + "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n + handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n + +fun p_enamed env n = string (p_enamed' env n) fun p_con_named env n = string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) @@ -2156,6 +2158,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "*/"] | DTask _ => box [] + | DOnError _ => box [] datatype 'a search = Found of 'a @@ -2791,6 +2794,8 @@ fun p_file env (ds, ps) = val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds + val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds + val now = Time.now () val nowD = Date.fromTimeUniv now val rfcFmt = "%a, %d %b %Y %H:%M:%S" @@ -2957,6 +2962,18 @@ fun p_file env (ds, ps) = string "static void uw_initializer(uw_context ctx) { };", newline], + case onError of + NONE => box [] + | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", + newline, + box [string "uw_write(ctx, ", + p_enamed env n, + string "(ctx, msg, uw_unit_v));", + newline], + string "}", + newline, + newline], + string "uw_app uw_application = {", p_list_sep (box [string ",", newline]) string [Int.toString (SM.foldl Int.max 0 fnums + 1), @@ -2965,7 +2982,8 @@ fun p_file env (ds, ps) = "uw_client_init", "uw_initializer", "uw_expunger", "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", "uw_handle", - "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime"], + "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", + case onError of NONE => "NULL" | SOME _ => "uw_onError"], string "};", newline] end diff --git a/src/cjrize.sml b/src/cjrize.sml index 22463cd4..2e7afa43 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -675,6 +675,7 @@ fun cifyDecl ((d, loc), sm) = | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; (NONE, NONE, sm))) | L.DPolicy _ => (NONE, NONE, sm) + | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) fun cjrize ds = let diff --git a/src/compiler.sig b/src/compiler.sig index c9b96a52..d0f6ac72 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -54,7 +54,8 @@ signature COMPILER = sig protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } val compile : string -> bool val compiler : string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index 6167f08a..c01024f0 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -58,7 +58,8 @@ type job = { protocol : string option, dbms : string option, sigFile : string option, - safeGets : string list + safeGets : string list, + onError : (string * string list * string) option } type ('src, 'dst) phase = { @@ -396,6 +397,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val safeGets = ref [] + val onError = ref NONE fun finish sources = let @@ -425,7 +427,8 @@ fun parseUrp' accLibs fname = protocol = !protocol, dbms = !dbms, sigFile = !sigFile, - safeGets = rev (!safeGets) + safeGets = rev (!safeGets), + onError = !onError } fun mergeO f (old, new) = @@ -469,7 +472,8 @@ 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), - safeGets = #safeGets old @ #safeGets new + safeGets = #safeGets old @ #safeGets new, + onError = mergeO #2 (#onError old, #onError new) } in if accLibs then @@ -631,6 +635,12 @@ fun parseUrp' accLibs fname = (case String.fields (fn ch => ch = #"=") arg of [n, v] => pathmap := M.insert (!pathmap, n, v) | _ => ErrorMsg.error "path argument not of the form name=value'") + | "onError" => + (case String.fields (fn ch => ch = #".") arg of + m1 :: (fs as _ :: _) => + onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) + | _ => ErrorMsg.error "invalid 'onError' argument") + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -657,6 +667,7 @@ fun parseUrp' accLibs fname = Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); Settings.setSafeGets (#safeGets job); + Settings.setOnError (#onError job); job end in @@ -709,7 +720,7 @@ structure SS = BinarySetFn(struct end) val parse = { - func = fn {database, sources = fnames, ffi, ...} : job => + func = fn {database, sources = fnames, ffi, onError, ...} : job => let val mrs = !moduleRoots @@ -884,6 +895,10 @@ val parse = { val ds = case database of NONE => ds | SOME s => (Source.DDatabase s, loc) :: ds + + val ds = case onError of + NONE => ds + | SOME v => ds @ [(Source.DOnError v, loc)] in ds end handle Empty => ds diff --git a/src/core.sml b/src/core.sml index e5358f48..6d9e56b6 100644 --- a/src/core.sml +++ b/src/core.sml @@ -136,6 +136,7 @@ datatype decl' = | DStyle of string * int * string | DTask of exp * exp | DPolicy of exp + | DOnError of int withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 478ef495..9a4f9ec7 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -350,6 +350,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index f18ea4b9..ca8066b3 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -628,6 +628,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index eedcd2bb..e71d7276 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -997,6 +997,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = fn e' => (DPolicy e', loc)) + | DOnError _ => S.return2 dAll + and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, fn t' => @@ -1152,6 +1154,7 @@ fun mapfoldB (all as {bind, ...}) = end | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -1216,7 +1219,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count) | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/corify.sml b/src/corify.sml index 88473455..27e6c4c7 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1083,6 +1083,17 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | L.DPolicy e1 => ([(L'.DPolicy (corifyExp st e1), loc)], st) + | L.DOnError (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupValByName st x of + St.ENormal n => ([(L'.DOnError n, loc)], st) + | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; + ([], st)) + end + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1141,7 +1152,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n') | L.DTask _ => n - | L.DPolicy _ => n) + | L.DPolicy _ => n + | L.DOnError _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/css.sml b/src/css.sml index 31c4b9b1..73f180d9 100644 --- a/src/css.sml +++ b/src/css.sml @@ -288,6 +288,7 @@ fun summarize file = | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) | DTask _ => st | DPolicy _ => st + | DOnError _ => st end val (globals, classes) = foldl decl (IM.empty, IM.empty) file diff --git a/src/demo.sml b/src/demo.sml index a67411de..358815de 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -115,7 +115,8 @@ 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), - safeGets = [] + safeGets = [], + onError = NONE } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") diff --git a/src/elab.sml b/src/elab.sml index e040a059..6d405af6 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -172,6 +172,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index bb34c345..16596622 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1633,5 +1633,6 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env end diff --git a/src/elab_print.sml b/src/elab_print.sml index 42a0a107..4fb7ee73 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -816,6 +816,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index ec6c51ba..ccfb86a3 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -883,7 +883,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DStyle (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) | DTask _ => ctx - | DPolicy _ => ctx, + | DPolicy _ => ctx + | DOnError _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -1018,6 +1019,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfe ctx e1, fn e1' => (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1162,6 +1164,7 @@ and maxNameDecl (d, _) = | DStyle (n1, _, n2) => Int.max (n1, n2) | DTask _ => 0 | DPolicy _ => 0 + | DOnError _ => 0 and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 505699bd..e7848f21 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2679,6 +2679,7 @@ and sgiOfDecl (d, loc) = | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] | L'.DPolicy _ => [] + | L'.DOnError _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3858,6 +3859,32 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) end + | L.DOnError (m1, ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, []))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + + val page = (L'.CModProj (!basis_r, [], "page"), loc) + val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) + val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) + in + unifyCons env loc t func; + ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) + end) + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) diff --git a/src/expl.sml b/src/expl.sml index 1212383f..119c1d92 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -149,6 +149,7 @@ datatype decl' = | DStyle of int * string * int | DTask of exp * exp | DPolicy of exp + | DOnError of int * string list * string and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 9abe7099..f5a5eb0a 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -345,6 +345,7 @@ fun declBinds env (d, loc) = end | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index 5a914194..d89b0512 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -730,6 +730,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp env e1] + | DOnError _ => string "ONERROR" and p_str env (str, _) = case str of diff --git a/src/explify.sml b/src/explify.sml index 0013906f..4f4f83e1 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -197,6 +197,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) + | L.DOnError v => SOME (L'.DOnError v, loc) and explifyStr (str, loc) = case str of diff --git a/src/mono.sml b/src/mono.sml index 554b1dc5..1d446dda 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -151,6 +151,7 @@ datatype decl' = | DTask of exp * exp | DPolicy of policy + | DOnError of int withtype decl = decl' located diff --git a/src/mono_env.sml b/src/mono_env.sml index 87f96488..1df38db3 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -131,6 +131,7 @@ fun declBinds env (d, loc) = | DStyle _ => env | DTask _ => env | DPolicy _ => env + | DOnError _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index c3f2866e..63c98f44 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -527,7 +527,7 @@ fun p_decl env (dAll as (d, _) : decl) = | DPolicy p => box [string "policy", space, p_policy env p] - + | DOnError _ => string "ONERROR" fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 50c4b387..d8baf07e 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -70,6 +70,7 @@ fun shake file = in usedVars st e1 end + | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) | (_, st) => st) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => @@ -87,7 +88,8 @@ fun shake file = | ((DCookie _, _), acc) => acc | ((DStyle _, _), acc) => acc | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -155,7 +157,8 @@ fun shake file = | (DCookie _, _) => true | (DStyle _, _) => true | (DTask _, _) => true - | (DPolicy _, _) => true) file + | (DPolicy _, _) => true + | (DOnError _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 8a567e83..d75b8300 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -538,6 +538,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = S.map2 (mfpol ctx pol, fn p' => (DPolicy p', loc)) + | DOnError _ => S.return2 dAll and mfpol ctx pol = case pol of @@ -644,6 +645,7 @@ fun mapfoldB (all as {bind, ...}) = | DStyle _ => ctx | DTask _ => ctx | DPolicy _ => ctx + | DOnError _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -698,7 +700,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DCookie _ => count | DStyle _ => count | DTask _ => count - | DPolicy _ => count) 0 + | DPolicy _ => count + | DOnError _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 07e69834..bd5787b4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3962,6 +3962,9 @@ fun monoDecl (env, fm) (all as (d, loc)) = in SOME (env, fm, ps) end + | L.DOnError n => SOME (env, + fm, + [(L'.DOnError n, loc)]) end datatype expungable = Client | Channel diff --git a/src/prepare.sml b/src/prepare.sml index 81de2fa7..4d81940f 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -331,6 +331,7 @@ fun prepDecl (d as (_, loc), st) = in ((DTask (tk, e), loc), st) end + | DOnError _ => (d, st) fun prepare (ds, ps) = let diff --git a/src/reduce.sml b/src/reduce.sml index 36c9f44e..7a962926 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -803,6 +803,7 @@ fun reduce file = namedC, namedE)) end + | DOnError _ => (d, st) val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in diff --git a/src/reduce_local.sml b/src/reduce_local.sml index cfa6bfd8..0e87e34a 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -378,6 +378,7 @@ fun reduce file = | DStyle _ => d | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d in map doDecl file end diff --git a/src/settings.sig b/src/settings.sig index 51d06902..3ebf9300 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -206,4 +206,6 @@ signature SETTINGS = sig val setSafeGets : string list -> unit val isSafeGet : string -> bool + val setOnError : (string * string list * string) option -> unit + val getOnError : unit -> (string * string list * string) option end diff --git a/src/settings.sml b/src/settings.sml index af16f9ca..5da1a24e 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -486,4 +486,8 @@ val safeGet = ref SS.empty fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) fun isSafeGet x = SS.member (!safeGet, x) +val onError = ref (NONE : (string * string list * string) option) +fun setOnError x = onError := x +fun getOnError () = !onError + end diff --git a/src/shake.sml b/src/shake.sml index bc81def9..096c31fd 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -101,6 +101,11 @@ fun shake file = st else usedVars st e1 + | ((DOnError n, _), st as (usedE, usedC)) => + if !sliceDb then + st + else + (IS.add (usedE, n), usedC) | (_, acc) => acc) (IS.empty, IS.empty) file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) @@ -128,7 +133,8 @@ fun shake file = | ((DStyle (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DTask _, _), acc) => acc - | ((DPolicy _, _), acc) => acc) + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -216,7 +222,8 @@ fun shake file = | (DCookie _, _) => not (!sliceDb) | (DStyle _, _) => not (!sliceDb) | (DTask _, _) => not (!sliceDb) - | (DPolicy _, _) => not (!sliceDb)) file + | (DPolicy _, _) => not (!sliceDb) + | (DOnError _, _) => not (!sliceDb)) file end end diff --git a/src/source.sml b/src/source.sml index 9768cfc0..b85384ab 100644 --- a/src/source.sml +++ b/src/source.sml @@ -169,6 +169,7 @@ datatype decl' = | DStyle of string | DTask of exp * exp | DPolicy of exp + | DOnError of string * string list * string and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 590d15d5..f6218d22 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -672,6 +672,7 @@ fun p_decl ((d, _) : decl) = | DPolicy e1 => box [string "policy", space, p_exp e1] + | DOnError _ => string "ONERROR" and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index a2ec32b0..2d6956cb 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -434,6 +434,7 @@ fun unnest file = | DStyle _ => default () | DTask _ => explore () | DPolicy _ => explore () + | DOnError _ => default () end and doStr (all as (str, loc), st) = diff --git a/tests/onerror.ur b/tests/onerror.ur new file mode 100644 index 00000000..9877d8d7 --- /dev/null +++ b/tests/onerror.ur @@ -0,0 +1,4 @@ +fun main n = + case n of + 0 => error <xml>Zero is bad!</xml> + | _ => return <xml/> diff --git a/tests/onerror.urp b/tests/onerror.urp new file mode 100644 index 00000000..39d7ac7d --- /dev/null +++ b/tests/onerror.urp @@ -0,0 +1,4 @@ +onError OnerrorE.err + +onerrorE +onerror diff --git a/tests/onerror.urs b/tests/onerror.urs new file mode 100644 index 00000000..38b757ea --- /dev/null +++ b/tests/onerror.urs @@ -0,0 +1 @@ +val main : int -> transaction page diff --git a/tests/onerrorE.ur b/tests/onerrorE.ur new file mode 100644 index 00000000..b2948c71 --- /dev/null +++ b/tests/onerrorE.ur @@ -0,0 +1,5 @@ +fun err x = return <xml><body> + <h1>Bad thing!</h1> + + {x} +</body></xml> |