+let xml_escape = Netencoding.Html.encode ~in_enc:`Enc_utf8 ()
+
+let html_tag ?exn () =
+ let xml_decl = "<?xml version=\"1.0\"?>\n" in
+ match exn with
+ | Some (exn, arg) ->
+ let (exn, arg) = (xml_escape exn, xml_escape arg) in
+ sprintf
+ "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\"\nhelm:exception_arg=\"%s\">\n"
+ xml_decl xhtml_ns helm_ns exn arg
+ | 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_msg s = sprintf "%s<body>%s</body></html>" (html_tag ()) s
+let null_pp s = s
+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 exn body = return_html_error exn body
+