From 547adaccb0b29cc02ff89013f84ae6446665144d Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 2 Jan 2010 13:31:59 -0500
Subject: Proper 404 generation

---
 include/urweb.h   |  1 +
 lib/ur/top.ur     | 18 ++++++++++++++++++
 lib/ur/top.urs    | 10 +++++++++-
 src/c/urweb.c     |  4 ++++
 src/cjr_print.sml |  6 +++++-
 5 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/include/urweb.h b/include/urweb.h
index 46ef9558..51f1407d 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -188,6 +188,7 @@ uw_Basis_time uw_Basis_unsqlTime(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string);
 
 void uw_write_header(uw_context, uw_Basis_string);
+void uw_clear_headers(uw_context);
 
 uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string c);
 uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure);
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index b6f6349a..613f5ec5 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -246,6 +246,24 @@ fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {T
               return <xml>{acc}{r}</xml>)
           <xml/>
 
+fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}]
+             (q : sql_query [nm = fs] [])
+             (f : $fs -> transaction (xml ctx inp [])) =
+    query q
+          (fn fs acc =>
+              r <- f fs.nm;
+              return <xml>{acc}{r}</xml>)
+          <xml/>
+
+fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}]
+             (q : sql_query [] exps)
+             (f : $exps -> transaction (xml ctx inp [])) =
+    query q
+          (fn fs acc =>
+              r <- f fs;
+              return <xml>{acc}{r}</xml>)
+          <xml/>
+
 fun hasRows [tables ::: {{Type}}] [exps ::: {Type}]
             [tables ~ exps]
             (q : sql_query tables exps) =
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index d23b3e01..743669ce 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -148,7 +148,15 @@ val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::
               -> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                   -> transaction (xml ctx inp []))
               -> transaction (xml ctx inp [])
-                       
+val queryX1' : nm ::: Name -> fs ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type}
+              -> sql_query [nm = fs] []
+              -> ($fs -> transaction (xml ctx inp []))
+              -> transaction (xml ctx inp [])
+val queryXE' : exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type}
+              -> sql_query [] exps
+              -> ($exps -> transaction (xml ctx inp []))
+              -> transaction (xml ctx inp [])
+
 val hasRows : tables ::: {{Type}} -> exps ::: {Type}
               -> [tables ~ exps] =>
     sql_query tables exps
diff --git a/src/c/urweb.c b/src/c/urweb.c
index e7495347..1bfb3cd5 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1174,6 +1174,10 @@ void uw_write_header(uw_context ctx, uw_Basis_string s) {
   ctx->outHeaders.front += len;
 }
 
+void uw_clear_headers(uw_context ctx) {
+  buf_reset(&ctx->outHeaders);
+}
+
 static void uw_check_script(uw_context ctx, size_t extra) {
   buf_check(&ctx->script, extra);
 }
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 93f50de2..2cfd0663 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2833,7 +2833,11 @@ fun p_file env (ds, ps) =
              newline,
              p_list_sep newline (fn x => x) pds',
              newline,
-             string "uw_error(ctx, FATAL, \"Unknown page\");",
+             string "uw_clear_headers(ctx);",
+             newline,
+             string "uw_write_header(ctx, \"HTTP/1.1 404 Not Found\\r\\nContent-type: text/plain\\r\\n\");",
+             newline,
+             string "uw_write(ctx, \"Not Found\");",
              newline,
              string "}",
              newline,
-- 
cgit v1.2.3