changeset 1294:b4480a56cab7

Server-side 'onError'
author Adam Chlipala <adam@chlipala.net>
date Tue, 07 Sep 2010 08:28:07 -0400
parents acabf3935060
children 929981850d9d
files include/types.h include/urweb.h src/c/request.c src/c/urweb.c src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/compiler.sig src/compiler.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/css.sml src/demo.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/reduce.sml src/reduce_local.sml src/settings.sig src/settings.sml src/shake.sml src/source.sml src/source_print.sml src/unnest.sml tests/onerror.ur tests/onerror.urp tests/onerror.urs tests/onerrorE.ur
diffstat 45 files changed, 244 insertions(+), 59 deletions(-) [+]
line wrap: on
line diff
--- a/include/types.h	Sun Sep 05 14:00:57 2010 -0400
+++ b/include/types.h	Tue Sep 07 08:28:07 2010 -0400
@@ -73,6 +73,10 @@
   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
--- a/include/urweb.h	Sun Sep 05 14:00:57 2010 -0400
+++ b/include/urweb.h	Tue Sep 07 08:28:07 2010 -0400
@@ -36,6 +36,7 @@
 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);
--- a/src/c/request.c	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/c/request.c	Tue Sep 07 08:28:07 2010 -0400
@@ -131,6 +131,8 @@
   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 @@
   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);
+      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 (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 @@
 
         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 @@
 
       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))
--- a/src/c/urweb.c	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/c/urweb.c	Tue Sep 07 08:28:07 2010 -0400
@@ -353,8 +353,6 @@
 
 // Single-request state
 
-#define ERROR_BUF_LEN 1024
-
 typedef struct regions {
   struct regions *next;
 } regions;
@@ -714,6 +712,22 @@
   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");
--- a/src/cjr.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/cjr.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -124,6 +124,7 @@
        | DStyle of string
 
        | DTask of task * exp
+       | DOnError of int
 
 withtype decl = decl' located
 
--- a/src/cjr_env.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/cjr_env.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -172,5 +172,6 @@
       | DCookie _ => env
       | DStyle _ => env
       | DTask _ => env
+      | DOnError _ => env
 
 end
--- a/src/cjr_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/cjr_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -113,9 +113,11 @@
 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 @@
                          string "*/"]
 
       | DTask _ => box []
+      | DOnError _ => box []
 
 datatype 'a search =
          Found of 'a
@@ -2791,6 +2794,8 @@
 
         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 @@
                       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 @@
                          "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
--- a/src/cjrize.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/cjrize.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -675,6 +675,7 @@
            | _ => (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
--- a/src/compiler.sig	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/compiler.sig	Tue Sep 07 08:28:07 2010 -0400
@@ -54,7 +54,8 @@
          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
--- a/src/compiler.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/compiler.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -58,7 +58,8 @@
      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 @@
                 val dbms = ref NONE
                 val sigFile = ref (Settings.getSigFile ())
                 val safeGets = ref []
+                val onError = ref NONE
 
                 fun finish sources =
                     let
@@ -425,7 +427,8 @@
                             protocol = !protocol,
                             dbms = !dbms,
                             sigFile = !sigFile,
-                            safeGets = rev (!safeGets)
+                            safeGets = rev (!safeGets),
+                            onError = !onError
                         }
 
                         fun mergeO f (old, new) =
@@ -469,7 +472,8 @@
                             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 @@
                                 (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 @@
                 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 @@
                            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 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
--- a/src/core.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/core.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -136,6 +136,7 @@
        | DStyle of string * int * string
        | DTask of exp * exp
        | DPolicy of exp
+       | DOnError of int
 
 withtype decl = decl' located
 
--- a/src/core_env.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/core_env.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -350,6 +350,7 @@
         end
       | DTask _ => env
       | DPolicy _ => env
+      | DOnError _ => env
 
 fun patBinds env (p, loc) =
     case p of
--- a/src/core_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/core_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -628,6 +628,7 @@
       | DPolicy e1 => box [string "policy",
                            space,
                            p_exp env e1]
+      | DOnError _ => string "ONERROR"
 
 fun p_file env file =
     let
--- a/src/core_util.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/core_util.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -997,6 +997,8 @@
                      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 @@
                                         end
                                       | DTask _ => ctx
                                       | DPolicy _ => ctx
+                                      | DOnError _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -1216,7 +1219,8 @@
                           | DCookie (_, n, _, _) => Int.max (n, count)
                           | DStyle (_, n, _) => Int.max (n, count)
                           | DTask _ => count
-                          | DPolicy _ => count) 0
+                          | DPolicy _ => count
+                          | DOnError _ => count) 0
               
 end
 
--- a/src/corify.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/corify.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -1083,6 +1083,17 @@
       | 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 @@
                              | 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, _) =
--- a/src/css.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/css.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -288,6 +288,7 @@
                   | 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
--- a/src/demo.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/demo.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -115,7 +115,8 @@
             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")
--- a/src/elab.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/elab.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -172,6 +172,7 @@
        | DStyle of int * string * int
        | DTask of exp * exp
        | DPolicy of exp
+       | DOnError of int * string list * string
 
      and str' =
          StrConst of decl list
--- a/src/elab_env.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/elab_env.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -1633,5 +1633,6 @@
         end
       | DTask _ => env
       | DPolicy _ => env
+      | DOnError _ => env
 
 end
--- a/src/elab_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/elab_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -816,6 +816,7 @@
       | DPolicy e1 => box [string "policy",
                            space,
                            p_exp env e1]
+      | DOnError _ => string "ONERROR"
 
 and p_str env (str, _) =
     case str of
--- a/src/elab_util.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/elab_util.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -883,7 +883,8 @@
                                                  | 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 @@
                 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 @@
       | DStyle (n1, _, n2) => Int.max (n1, n2)
       | DTask _ => 0
       | DPolicy _ => 0
+      | DOnError _ => 0
 and maxNameStr (str, _) =
     case str of
         StrConst ds => maxName ds
--- a/src/elaborate.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/elaborate.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -2679,6 +2679,7 @@
       | 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 @@
                     ([(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)];*)
--- a/src/expl.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/expl.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -149,6 +149,7 @@
        | DStyle of int * string * int
        | DTask of exp * exp
        | DPolicy of exp
+       | DOnError of int * string list * string
 
      and str' =
          StrConst of decl list
--- a/src/expl_env.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/expl_env.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -345,6 +345,7 @@
         end
       | DTask _ => env
       | DPolicy _ => env
+      | DOnError _ => env
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
--- a/src/expl_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/expl_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -730,6 +730,7 @@
       | DPolicy e1 => box [string "policy",
                            space,
                            p_exp env e1]
+      | DOnError _ => string "ONERROR"
 
 and p_str env (str, _) =
     case str of
--- a/src/explify.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/explify.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -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 @@
       | 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
--- a/src/mono.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/mono.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -151,6 +151,7 @@
        | DTask of exp * exp
 
        | DPolicy of policy
+       | DOnError of int
 
 withtype decl = decl' located
 
--- a/src/mono_env.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/mono_env.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -131,6 +131,7 @@
       | DStyle _ => env
       | DTask _ => env
       | DPolicy _ => env
+      | DOnError _ => env
 
 fun patBinds env (p, loc) =
     case p of
--- a/src/mono_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/mono_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -527,7 +527,7 @@
       | DPolicy p => box [string "policy",
                           space,
                           p_policy env p]
-
+      | DOnError _ => string "ONERROR"
                           
 fun p_file env file =
     let
--- a/src/mono_shake.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/mono_shake.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -70,6 +70,7 @@
                     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 @@
                                    | ((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 @@
                       | (DCookie _, _) => true
                       | (DStyle _, _) => true
                       | (DTask _, _) => true
-                      | (DPolicy _, _) => true) file
+                      | (DPolicy _, _) => true
+                      | (DOnError _, _) => true) file
     end
 
 end
--- a/src/mono_util.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/mono_util.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -538,6 +538,7 @@
                 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 @@
                                       | DStyle _ => ctx
                                       | DTask _ => ctx
                                       | DPolicy _ => ctx
+                                      | DOnError _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -698,7 +700,8 @@
                           | DCookie _ => count
                           | DStyle _ => count
                           | DTask _ => count
-                          | DPolicy _ => count) 0
+                          | DPolicy _ => count
+                          | DOnError _ => count) 0
 
 end
 
--- a/src/monoize.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/monoize.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -3962,6 +3962,9 @@
             in
                 SOME (env, fm, ps)
             end
+          | L.DOnError n => SOME (env,
+                                  fm,
+                                  [(L'.DOnError n, loc)])
     end
 
 datatype expungable = Client | Channel
--- a/src/prepare.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/prepare.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -331,6 +331,7 @@
         in
             ((DTask (tk, e), loc), st)
         end
+      | DOnError _ => (d, st)
 
 fun prepare (ds, ps) =
     let
--- a/src/reduce.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/reduce.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -803,6 +803,7 @@
                       namedC,
                       namedE))
                 end
+              | DOnError _ => (d, st)
 
         val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
     in
--- a/src/reduce_local.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/reduce_local.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -378,6 +378,7 @@
               | DStyle _ => d
               | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
               | DPolicy e1 => (DPolicy (exp [] e1), loc)
+              | DOnError _ => d
     in
         map doDecl file
     end
--- a/src/settings.sig	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/settings.sig	Tue Sep 07 08:28:07 2010 -0400
@@ -206,4 +206,6 @@
     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
--- a/src/settings.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/settings.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -486,4 +486,8 @@
 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
--- a/src/shake.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/shake.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -101,6 +101,11 @@
                         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 @@
                                    | ((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 @@
                       | (DCookie _, _) => not (!sliceDb)
                       | (DStyle _, _) => not (!sliceDb)
                       | (DTask _, _) => not (!sliceDb)
-                      | (DPolicy _, _) => not (!sliceDb)) file
+                      | (DPolicy _, _) => not (!sliceDb)
+                      | (DOnError _, _) => not (!sliceDb)) file
     end
 
 end
--- a/src/source.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/source.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -169,6 +169,7 @@
        | DStyle of string
        | DTask of exp * exp
        | DPolicy of exp
+       | DOnError of string * string list * string
 
      and str' =
          StrConst of decl list
--- a/src/source_print.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/source_print.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -672,6 +672,7 @@
       | DPolicy e1 => box [string "policy",
                            space,
                            p_exp e1]
+      | DOnError _ => string "ONERROR"
 
 and p_str (str, _) =
     case str of
--- a/src/unnest.sml	Sun Sep 05 14:00:57 2010 -0400
+++ b/src/unnest.sml	Tue Sep 07 08:28:07 2010 -0400
@@ -434,6 +434,7 @@
                   | DStyle _ => default ()
                   | DTask _ => explore ()
                   | DPolicy _ => explore ()
+                  | DOnError _ => default ()
             end
 
         and doStr (all as (str, loc), st) =
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/onerror.ur	Tue Sep 07 08:28:07 2010 -0400
@@ -0,0 +1,4 @@
+fun main n =
+  case n of
+      0 => error <xml>Zero is bad!</xml>
+    | _ => return <xml/>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/onerror.urp	Tue Sep 07 08:28:07 2010 -0400
@@ -0,0 +1,4 @@
+onError OnerrorE.err
+
+onerrorE
+onerror
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/onerror.urs	Tue Sep 07 08:28:07 2010 -0400
@@ -0,0 +1,1 @@
+val main : int -> transaction page
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/onerrorE.ur	Tue Sep 07 08:28:07 2010 -0400
@@ -0,0 +1,5 @@
+fun err x = return <xml><body>
+  <h1>Bad thing!</h1>
+
+  {x}
+</body></xml>