helm/http_getter/main.ml

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