daemons/http_getter/main.ml

   1 (* Copyright (C) 2003-2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 open Printf
  27
  28 open Http_getter_common
  29 open Http_getter_const
  30 open Http_getter_misc
  31 open Http_getter_types
  32
  33   (* constants *)
  34
  35 let configuration_file = BuildTimeOpts.conffile
  36
  37 let common_headers = [
  38   "Cache-Control", "no-cache";
  39   "Pragma", "no-cache";
  40   "Expires", "0"
  41 ]
  42
  43   (* HTTP queries argument parsing *)
  44
  45   (* parse encoding ("format" parameter), default is `Normal *)
  46 let parse_enc (req: Http_types.request) =
  47   try
  48     (match req#param "format" with
  49     | "normal" -> `Normal
  50     | "gz" -> `Gzipped
  51     | s -> raise (Bad_request ("Invalid format: " ^ s)))
  52   with Http_types.Param_not_found _ -> `Normal
  53
  54   (* parse "patch_dtd" parameter, default is true *)
  55 let parse_patch (req: Http_types.request) =
  56   try
  57     (match req#param "patch_dtd" with
  58     | s when String.lowercase s = "yes" -> true
  59     | s when String.lowercase s = "no" -> false
  60     | s -> raise (Bad_request ("Invalid patch_dtd value: " ^ s)))
  61   with Http_types.Param_not_found _ -> true
  62
  63   (* parse output format ("format" parameter), no default value *)
  64 let parse_output_format meth (req: Http_types.request) =
  65   match req#param "format" with
  66   | s when String.lowercase s = "txt" -> `Text
  67   | s when String.lowercase s = "xml" -> `Xml
  68   | s -> raise (Bad_request ("Invalid /" ^ meth ^ " format: " ^ s))
  69
  70 let xml_escape = Netencoding.Html.encode ~in_enc:`Enc_utf8 ()
  71
  72 let html_tag ?exn () =
  73   let xml_decl = "<?xml version=\"1.0\"?>\n" in
  74   match exn with
  75   | Some (exn, arg) ->
  76       let (exn, arg) = (xml_escape exn, xml_escape arg) in
  77       sprintf
  78         ("%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\n"
  79         ^^ "helm:exception=\"%s\"\nhelm:exception_arg=\"%s\">\n")
  80         xml_decl xhtml_ns helm_ns exn arg
  81   | None ->
  82       sprintf "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\">\n"
  83         xml_decl xhtml_ns helm_ns
  84
  85 let mk_return_fun pp_fun contype msg outchan =
  86   Http_daemon.respond
  87     ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan
  88
  89 let pp_msg s = sprintf "%s<body>%s</body></html>" (html_tag ()) s
  90 let null_pp s = s
  91
  92 let return_html_error exn =
  93   let pp_error s =
  94     sprintf
  95       ("%s\n<body>Http Getter error: <span style=\"color:red\">%s"
  96       ^^ "</span></body></html>")
  97       (html_tag ~exn ()) s
  98   in
  99   mk_return_fun pp_error "text/xml"
 100
 101 let return_html_internal_error exn =
 102   let pp_internal_error s =
 103     sprintf
 104       ("%s\n<body>Http Getter Internal error: <span style=\"color:red\">%s"
 105       ^^ "</span></body></html>")
 106       (html_tag ~exn ()) s
 107   in
 108   mk_return_fun pp_internal_error "text/xml"
 109
 110 let return_html_msg = mk_return_fun pp_msg "text/xml"
 111 let return_html_raw = mk_return_fun null_pp "text/xml"
 112 let return_xml_raw = mk_return_fun null_pp "text/xml"
 113 let return_400 exn body = return_html_error exn body
 114
 115 let return_all_uris doctype uris outchan =
 116   Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
 117   Http_daemon.send_header "Content-Type" "text/xml" outchan;
 118   Http_daemon.send_headers common_headers outchan;
 119   Http_daemon.send_CRLF outchan;
 120   output_string
 121     outchan
 122     (sprintf
 123 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 124 <!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">
 125
 126 <%s>
 127 "
 128       doctype
 129       (Lazy.force Http_getter_env.my_own_url)
 130       doctype
 131       doctype);
 132   List.iter
 133     (fun uri -> output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri))
 134     uris;
 135   output_string outchan (sprintf "</%s>\n" doctype)
 136
 137 let return_all_xml_uris fmt outchan =
 138   let uris = Http_getter.getalluris () in
 139   match fmt with
 140   | `Text ->
 141       let buf = Buffer.create 10240 in
 142       List.iter (bprintf buf "%s\n") uris ;
 143       let body = Buffer.contents buf in
 144       Http_daemon.respond
 145         ~headers:(("Content-Type", "text/plain") :: common_headers)
 146         ~body outchan
 147    | `Xml -> return_all_uris "alluris" uris outchan
 148
 149 let return_ls regexp fmt outchan =
 150   let ls_items = Http_getter.ls regexp in
 151   let buf = Buffer.create 10240 in
 152   (match fmt with
 153   | `Text ->
 154       List.iter
 155         (function
 156           | Ls_section dir -> bprintf buf "dir, %s\n" dir
 157           | Ls_object obj ->
 158               bprintf buf "object, %s, <%s,%s,%s,%s>\n"
 159               obj.uri (if obj.ann then "YES" else "NO")
 160               (string_of_ls_flag obj.types)
 161               (string_of_ls_flag obj.body)
 162               (string_of_ls_flag obj.proof_tree))
 163         ls_items
 164   | `Xml ->
 165       Buffer.add_string buf "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
 166       bprintf buf "<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">\n"
 167         (Lazy.force Http_getter_env.my_own_url);
 168       Buffer.add_string buf "<ls>\n";
 169       List.iter
 170         (function
 171           | Ls_section dir -> bprintf buf "<section>%s</section>\n" dir
 172           | Ls_object obj ->
 173               bprintf buf
 174 "<object name=\"%s\">
 175 \t<ann value=\"%s\" />
 176 \t<types value=\"%s\" />
 177 \t<body value=\"%s\" />
 178 \t<proof_tree value=\"%s\" />
 179 </object>
 180 "
 181               obj.uri (if obj.ann then "YES" else "NO")
 182               (string_of_ls_flag obj.types)
 183               (string_of_ls_flag obj.body)
 184               (string_of_ls_flag obj.proof_tree))
 185         ls_items;
 186       Buffer.add_string buf "</ls>\n");
 187   let body = Buffer.contents buf in
 188   Http_daemon.respond
 189     ~headers:(("Content-Type", "text/plain") :: common_headers)
 190     ~body outchan
 191
 192 let return_help outchan = return_html_raw (Http_getter.help ()) outchan
 193
 194 let return_resolve writable uri outchan =
 195   try
 196     return_xml_raw
 197       (sprintf "<url value=\"%s\" />\n" (Http_getter.resolve ~writable uri))
 198       outchan
 199   with
 200   | Unresolvable_URI _ -> return_xml_raw "<unresolvable />\n" outchan
 201   | Key_not_found _ -> return_xml_raw "<not_found />\n" outchan
 202
 203 let log_failure msg = Http_getter_logger.log ("Request not fulfilled: " ^ msg)
 204
 205 let convert_file ~from_enc ~to_enc fname =
 206   let remove f = fun () -> if Sys.file_exists f then Sys.remove f in
 207   match from_enc, to_enc with
 208   | `Normal, `Normal
 209   | `Gzipped, `Gzipped -> fname, (fun () -> ())
 210   | `Normal, `Gzipped ->
 211       let tmp = Http_getter_misc.tempfile () in
 212       Http_getter_misc.gzip ~keep:true ~output:tmp fname;
 213       tmp, remove tmp
 214   | `Gzipped, `Normal ->
 215       let tmp = Http_getter_misc.tempfile () in
 216       Http_getter_misc.gunzip ~keep:true ~output:tmp fname;
 217       tmp, remove tmp
 218
 219 let is_gzip fname = Http_getter_misc.extension fname = ".gz"
 220
 221 let patch_fun_for uri url =
 222   let xmlbases =
 223     if Http_getter_common.is_theory_uri uri then
 224       Some (Filename.dirname uri, Filename.dirname url)
 225     else
 226       None
 227   in
 228   Http_getter_common.patch_xml ?xmlbases ~via_http:true ()
 229
 230 let respond_dtd patch_dtd fname outchan =
 231   let via_http = false in
 232   let patch_fun =
 233     if patch_dtd then Some (Http_getter_common.patch_dtd ~via_http ())
 234     else None
 235   in
 236   Http_getter_common.return_file ~via_http:true ~fname ~contype:"text/plain"
 237     ~gunzip:false ?patch_fun ~enc:`Normal outchan
 238
 239 (* let respond_xsl
 240   ?(via_http = true) ?(enc = `Normal) ?(patch = true) ~url outchan
 241   =
 242   let patch_fun =
 243     if patch then Http_getter_common.patch_xsl ~via_http () else (fun x -> x)
 244   in
 245   let fname = tempfile () in
 246   finally (fun () -> Sys.remove fname) (lazy (
 247     wget ~output:fname url;
 248     return_file ~via_http ~fname ~contype:"text/xml" ~patch_fun ~enc outchan
 249   )) *)
 250 (*  | "/getxslt" ->
 251      Http_getter_cache.respond_xsl
 252       ~url:(Http_getter.resolve (req#param "uri"))
 253       ~patch:(parse_patch req) outchan *)
 254
 255 let respond_xslt patch_xslt xslt_name outchan =
 256   let fname = Http_getter.getxslt xslt_name in
 257   let patch_fun =
 258     if patch_xslt then Some (Http_getter_common.patch_xsl ~via_http:true ())
 259     else None
 260   in
 261   Http_getter_common.return_file ~fname ~contype:"text/xml" ?patch_fun
 262     ~gunzip:false ~via_http:true ~enc:`Normal outchan
 263
 264   (* thread action *)
 265
 266 let callback (req: Http_types.request) outchan =
 267   try
 268     Http_getter_logger.log ("Connection from " ^ req#clientAddr);
 269     Http_getter_logger.log ("Received request: " ^ req#uri);
 270     (match req#path with
 271     | "/help" -> return_help outchan
 272     | "/getxml" ->
 273         let uri = req#param "uri" in
 274         let fname = Http_getter.getxml uri in (* local name, in cache *)
 275         (* remote name *)
 276         let remote_name = Http_getter.resolve ~writable:false uri in
 277         let src_enc = if is_gzip fname then `Gzipped else `Normal in
 278         let enc = parse_enc req in
 279         let fname, cleanup = convert_file ~from_enc:src_enc ~to_enc:enc fname in
 280         let contenc = if enc = `Gzipped then Some "x-gzip" else None in
 281         let patch_fun =
 282           if parse_patch req
 283           then Some (patch_fun_for uri remote_name)
 284           else None
 285         in
 286         let gunzip = (enc = `Gzipped) in
 287         (try
 288           Http_getter_common.return_file
 289             ~fname ~contype:"text/xml" ?contenc ?patch_fun ~gunzip
 290             ~via_http:true ~enc outchan;
 291         with exn -> cleanup (); raise exn);
 292         cleanup ()
 293     | "/getxslt" -> respond_xslt (parse_patch req) (req#param "uri") outchan
 294     | "/getdtd" ->
 295         let fname = Http_getter.getdtd (req#param "uri") in
 296         respond_dtd (parse_patch req) fname outchan
 297     | "/resolve" ->
 298         let writable =
 299           match req#param ~default:"false" "writable" with
 300           | "true" -> true
 301           | _ -> false
 302         in
 303         return_resolve writable (req#param "uri") outchan
 304     | "/clean_cache" ->
 305         Http_getter.clean_cache ();
 306         return_html_msg "Done." outchan
 307     | "/getalluris" ->
 308        return_all_xml_uris (parse_output_format "getalluris" req) outchan
 309     | "/ls" ->
 310         return_ls (req#param "baseuri") (parse_output_format "ls" req) outchan
 311     | "/getempty" ->
 312         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
 313     | invalid_request ->
 314         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 315           outchan);
 316     Http_getter_logger.log "Done!\n"
 317   with
 318   | Http_types.Param_not_found attr_name ->
 319       let msg = sprintf "Parameter '%s' is missing" attr_name in
 320       log_failure msg;
 321       return_400 ("bad_request", msg) msg outchan
 322   | Bad_request msg ->
 323       log_failure msg;
 324       return_html_error ("bad_request", msg) msg outchan
 325   | Internal_error msg ->
 326       log_failure msg;
 327       return_html_internal_error ("internal_error", msg) msg outchan
 328   | exn ->
 329       let msg = "uncaught exception: " ^ (Printexc.to_string exn) in
 330       (match exn with
 331       | Http_getter_types.Key_not_found uri ->
 332           return_html_error ("key_not_found", uri) msg outchan
 333       | _ ->
 334           log_failure msg;
 335           return_html_error ("uncaught_exception", msg) msg outchan)
 336
 337 let batch_update = ref false
 338
 339 let args = [ ]
 340
 341     (* Main *)
 342 let main () =
 343   Arg.parse args (fun _-> ()) "http_getter honors the following options:\n";
 344   Helm_registry.load_from configuration_file;
 345   Http_getter.init ();
 346   print_string (Http_getter_env.env_to_string ());
 347   flush stdout;
 348   Sys.catch_break true;
 349   let d_spec = Http_daemon.daemon_spec
 350      ~mode:`Thread ~timeout:(Some 600)
 351      ~port:(Lazy.force Http_getter_env.port)
 352      ~auto_close:true
 353      ~callback:callback ()
 354   in
 355   try
 356     Http_daemon.main d_spec
 357   with Sys.Break -> ()
 358
 359 let _ = main ()
 360