]> matita.cs.unibo.it Git - helm.git/commitdiff
projects / helm.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 989b06d)
No longer return HTTP 400 answers or non-xml answers: all document returned
authorStefano Zacchiroli <zack@upsilon.cc>
Mon, 17 Jan 2005 16:23:26 +0000 (16:23 +0000)
committerStefano Zacchiroli <zack@upsilon.cc>
Mon, 17 Jan 2005 16:23:26 +0000 (16:23 +0000)
by the getter are now XHTML documents, possibly with the addition of an
attribute helm:exception on the root <html> element in the
http://www.cs.unibo.it/helm namespace. The presence of such an attribute
means that an exception has occured, its value is meant to be a string
encoding of the relevant ocaml exception

helm/http_getter/main.ml patch | blob | history

diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml
index 47784d137ba4ba51d84b43bf747b14fd124177b8..f65e991b7c263fbd7a714e3efbd755684080a3c4 100644 (file)
--- a/helm/http_getter/main.ml
+++ b/helm/http_getter/main.ml
@@ -29,6 +29,7 @@
 open Printf
 
 open Http_getter_common
+open Http_getter_const
 open Http_getter_misc
 open Http_getter_types
 
@@ -89,22 +90,38 @@ let parse_rdf_class (req: Http_types.request) =
   | "backward" -> `Backward
   | c -> raise (Bad_request ("Invalid RDF class: " ^ c))
 
+let html_tag ?exn () =
+  let xml_decl = "<?xml version=\"1.0\"?>\n" in
+  match exn with
+  | Some exn ->
+      sprintf
+        "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\">\n"
+        xml_decl xhtml_ns helm_ns exn
+  | None ->
+      sprintf "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\">\n"
+        xml_decl xhtml_ns helm_ns
+
 let mk_return_fun pp_fun contype msg outchan =
   Http_daemon.respond
     ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan
-let pp_error s =
-  sprintf "<html><body>Http Getter error: <span style=\"color:red\">%s</span></body></html>" s
-let pp_internal_error s =
-  sprintf "<html><body>Http Getter Internal error: <span style=\"color:red\">%s</span></body></html>" s
-let pp_msg s = sprintf "<html><body>%s</body></html>" s
+let pp_msg s = sprintf "%s<body>%s</body></html>" (html_tag ()) s
 let null_pp s = s
-let return_html_error = mk_return_fun pp_error "text/html"
-let return_html_internal_error = mk_return_fun pp_internal_error "text/html"
-let return_html_msg = mk_return_fun pp_msg "text/html"
-let return_html_raw = mk_return_fun null_pp "text/html"
+let return_html_error exn =
+  let pp_error s =
+    sprintf "%s\n<body>Http Getter error: <span style=\"color:red\">%s</span></body></html>"
+      (html_tag ~exn ()) s
+  in
+  mk_return_fun pp_error "text/xml"
+let return_html_internal_error exn =
+  let pp_internal_error s =
+    sprintf "%s\n<body>Http Getter Internal error: <span style=\"color:red\">%s</span></body></html>"
+      (html_tag ~exn ()) s
+  in
+  mk_return_fun pp_internal_error "text/xml"
+let return_html_msg = mk_return_fun pp_msg "text/xml"
+let return_html_raw = mk_return_fun null_pp "text/xml"
 let return_xml_raw = mk_return_fun null_pp "text/xml"
-let return_400 body outchan =
-  Http_daemon.respond_error ~code:(`Code 400) ~body outchan
+let return_400 exn body = return_html_error exn body
 
 let return_all_foo_uris doctype uris outchan =
   Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
@@ -200,7 +217,8 @@ let return_resolve uri outchan =
 
 let return_list_servers outchan =
   return_html_raw
-    (sprintf "<html><body><table>\n%s\n</table></body></html>"
+    (sprintf "%s<body><table>\n%s\n</table></body></html>"
+      (html_tag ())
       (String.concat "\n"
         (List.map
           (fun (pos, server) ->
@@ -216,9 +234,10 @@ let log_failure msg = Http_getter_logger.log ("Request not fulfilled: " ^ msg)
    * Channel is closed afterwards. *)
 let send_log_to ?prepend action outchan =
   Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
-  Http_daemon.send_header "Content-Type" "text/html" outchan;
+  Http_daemon.send_header "Content-Type" "text/xml" outchan;
   Http_daemon.send_CRLF outchan;
-  output_string outchan "<html><body>\n"; flush outchan;
+  output_string outchan (sprintf "%s<body>\n" (html_tag ()));
+  flush outchan;
   (match prepend with
   | None -> ()
   | Some text -> output_string outchan text; flush outchan);
@@ -298,13 +317,13 @@ let callback (req: Http_types.request) outchan =
   | Http_types.Param_not_found attr_name ->
       let msg = sprintf "Parameter '%s' is missing" attr_name in
       log_failure msg;
-      return_400 msg outchan
+      return_400 "Bad_request" msg outchan
   | Bad_request msg ->
       log_failure msg;
-      return_html_error msg outchan
+      return_html_error "Bad_request" msg outchan
   | Internal_error msg ->
       log_failure msg;
-      return_html_internal_error msg outchan
+      return_html_internal_error "Internal_error" msg outchan
   | Shell.Subprocess_error l ->
       let msgs =
         List.map
@@ -313,11 +332,12 @@ let callback (req: Http_types.request) outchan =
           l
       in
       log_failure (String.concat ", " msgs);
-      return_html_internal_error (String.concat "<br />\n" msgs) outchan
+      return_html_internal_error "Subprocess_error"
+        (String.concat "<br />\n" msgs) outchan
   | exc ->
       let msg = "Uncaught exception: " ^ (Printexc.to_string exc) in
       log_failure msg;
-      return_html_error msg outchan
+      return_html_error "Uncaught_exception" msg outchan
 
     (* Main *)
 
Unnamed repository; edit this file 'description' to name the repository.