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_misc
  33 open Http_getter_types
  34 open Http_getter_debugger
  35
  36   (* constants *)
  37
  38 (* let configuration_file = "/projects/helm/etc/http_getter.conf.xml" *)
  39 let configuration_file = "http_getter.conf.xml"
  40
  41 let common_headers = [
  42   "Cache-Control", "no-cache";
  43   "Pragma", "no-cache";
  44   "Expires", "0"
  45 ]
  46
  47   (* HTTP queries argument parsing *)
  48
  49   (* parse encoding ("format" parameter), default is `Normal *)
  50 let parse_enc (req: Http_types.request) =
  51   try
  52     (match req#param "format" with
  53     | "normal" -> `Normal
  54     | "gz" -> `Gzipped
  55     | s -> raise (Bad_request ("Invalid format: " ^ s)))
  56   with Http_types.Param_not_found _ -> `Normal
  57
  58   (* parse "patch_dtd" parameter, default is true *)
  59 let parse_patch (req: Http_types.request) =
  60   try
  61     (match req#param "patch_dtd" with
  62     | s when String.lowercase s = "yes" -> true
  63     | s when String.lowercase s = "no" -> false
  64     | s -> raise (Bad_request ("Invalid patch_dtd value: " ^ s)))
  65   with Http_types.Param_not_found _ -> true
  66
  67   (* parse output format ("format" parameter), no default value *)
  68 let parse_output_format meth (req: Http_types.request) =
  69   match req#param "format" with
  70   | s when String.lowercase s = "txt" -> `Text
  71   | s when String.lowercase s = "xml" -> `Xml
  72   | s -> raise (Bad_request ("Invalid /" ^ meth ^ " format: " ^ s))
  73
  74   (* parse "baseuri" format for /ls method, no default value *)
  75 let parse_ls_uri =
  76   let parse_ls_RE = Pcre.regexp "^(\\w+):(.*)$" in
  77   let trailing_slash_RE = Pcre.regexp "/+$" in
  78   let wrong_uri uri =
  79     raise (Bad_request ("Invalid /ls baseuri: " ^ uri))
  80   in
  81   fun (req: Http_types.request) ->
  82     let baseuri = req#param "baseuri" in
  83     try
  84       let subs =
  85         Pcre.extract ~rex:parse_ls_RE
  86           (Pcre.replace ~rex:trailing_slash_RE  baseuri)
  87       in
  88       (match (subs.(1), subs.(2)) with
  89       | "cic", uri -> Cic uri
  90       | "theory", uri -> Theory uri
  91       | _ -> wrong_uri baseuri)
  92     with Not_found -> wrong_uri baseuri
  93
  94   (* parse "position" argument, default is 0 *)
  95 let parse_position (req: Http_types.request) =
  96   try
  97     let res = int_of_string (req#param "position") in
  98     if res < 0 then
  99       raise (Failure "int_of_string");
 100     res
 101   with
 102   | Http_types.Param_not_found _ -> 0
 103   | Failure "int_of_string" ->
 104     raise (Bad_request
 105       (sprintf "position must be a non negative integer (%s given)"
 106         (req#param "position")))
 107
 108 let parse_rdf_class (req: Http_types.request) =
 109   match req#param "class" with
 110   | "forward" -> `Forward
 111   | "backward" -> `Backward
 112   | c -> raise (Bad_request ("Invalid RDF class: " ^ c))
 113
 114 let mk_return_fun pp_fun contype msg outchan =
 115   Http_daemon.respond
 116     ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan
 117 let pp_error s =
 118   sprintf "<html><body>Http Getter error: <span style=\"color:red\">%s</span></body></html>" s
 119 let pp_internal_error s =
 120   sprintf "<html><body>Http Getter Internal error: <span style=\"color:red\">%s</span></body></html>" s
 121 let pp_msg s = sprintf "<html><body>%s</body></html>" s
 122 let null_pp s = s
 123 let return_html_error = mk_return_fun pp_error "text/html"
 124 let return_html_internal_error = mk_return_fun pp_internal_error "text/html"
 125 let return_html_msg = mk_return_fun pp_msg "text/html"
 126 let return_html_raw = mk_return_fun null_pp "text/html"
 127 let return_xml_raw = mk_return_fun null_pp "text/xml"
 128 let return_400 body outchan = Http_daemon.respond_error ~code:400 ~body outchan
 129
 130 let return_all_foo_uris doctype uris outchan =
 131   Http_daemon.send_basic_headers ~code:200 outchan;
 132   Http_daemon.send_header "Content-Type" "text/xml" outchan;
 133   Http_daemon.send_headers common_headers outchan;
 134   Http_daemon.send_CRLF outchan;
 135   output_string
 136     outchan
 137     (sprintf
 138 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 139 <!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">
 140
 141 <%s>
 142 "
 143       doctype
 144       (Lazy.force Http_getter_env.my_own_url)
 145       doctype
 146       doctype);
 147   List.iter
 148     (fun uri -> output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri))
 149     uris;
 150   output_string outchan (sprintf "</%s>\n" doctype)
 151
 152 let return_all_xml_uris fmt outchan =
 153  let uris = Http_getter.getalluris () in
 154   match fmt with
 155    | `Text ->
 156       let buf = Buffer.create 10240 in
 157        List.iter (bprintf buf "%s\n") uris ;
 158        let body = Buffer.contents buf in
 159        Http_daemon.respond
 160          ~headers:(("Content-Type", "text/plain") :: common_headers)
 161          ~body outchan
 162    | `Xml ->
 163       return_all_foo_uris "alluris" uris outchan
 164
 165 let return_all_rdf_uris classs outchan =
 166   return_all_foo_uris "allrdfuris" (Http_getter.getallrdfuris classs) outchan
 167
 168 let return_ls xmluri fmt outchan =
 169   let ls_items = Http_getter.ls xmluri in
 170   let buf = Buffer.create 10240 in
 171   (match fmt with
 172   | `Text ->
 173       List.iter
 174         (function
 175           | Ls_section dir -> bprintf buf "dir, %s\n" dir
 176           | Ls_object obj ->
 177               bprintf buf "object, %s, <%s,%s,%s,%s>\n"
 178               obj.uri (if obj.ann then "YES" else "NO")
 179               (string_of_ls_flag obj.types)
 180               (string_of_ls_flag obj.body)
 181               (string_of_ls_flag obj.proof_tree))
 182         ls_items
 183   | `Xml ->
 184       Buffer.add_string buf "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
 185       bprintf buf "<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">\n"
 186         (Lazy.force Http_getter_env.my_own_url);
 187       Buffer.add_string buf "<ls>\n";
 188       List.iter
 189         (function
 190           | Ls_section dir -> bprintf buf "<section>%s</section>\n" dir
 191           | Ls_object obj ->
 192               bprintf buf
 193 "<object name=\"%s\">
 194 \t<ann value=\"%s\" />
 195 \t<types value=\"%s\" />
 196 \t<body value=\"%s\" />
 197 \t<proof_tree value=\"%s\" />
 198 </object>
 199 "
 200               obj.uri (if obj.ann then "YES" else "NO")
 201               (string_of_ls_flag obj.types)
 202               (string_of_ls_flag obj.body)
 203               (string_of_ls_flag obj.proof_tree))
 204         ls_items;
 205       Buffer.add_string buf "</ls>\n");
 206   let body = Buffer.contents buf in
 207   Http_daemon.respond
 208     ~headers:(("Content-Type", "text/plain") :: common_headers)
 209     ~body outchan
 210
 211 let return_help outchan = return_html_raw (Http_getter.help ()) outchan
 212
 213 let return_resolve uri outchan =
 214   try
 215     return_xml_raw
 216       (sprintf "<url value=\"%s\" />\n" (Http_getter.resolve uri))
 217       outchan
 218   with Unresolvable_URI uri ->
 219     return_xml_raw "<unresolved />\n" outchan
 220
 221 let return_list_servers outchan =
 222   return_html_raw
 223     (sprintf "<html><body><table>\n%s\n</table></body></html>"
 224       (String.concat "\n"
 225         (List.map
 226           (fun (pos, server) ->
 227             sprintf "<tr><td>%d</td><td>%s</td></tr>" pos server)
 228           (Http_getter.list_servers ()))))
 229     outchan
 230
 231 let log_failure msg = debug_print ("Request not fulfilled: " ^ msg)
 232
 233   (** given an action (i.e. a function which expects a logger and do something
 234    * using it as a logger), perform it sending its output incrementally to the
 235    * given output channel. Response is sent embedded in an HTML document.
 236    * Channel is closed afterwards. *)
 237 let send_log_to ?prepend action outchan =
 238   Http_daemon.send_basic_headers ~code:200 outchan;
 239   Http_daemon.send_header "Content-Type" "text/html" outchan;
 240   Http_daemon.send_CRLF outchan;
 241   output_string outchan "<html><body>\n"; flush outchan;
 242   (match prepend with
 243   | None -> ()
 244   | Some text -> output_string outchan text; flush outchan);
 245   let logger tag =
 246     output_string outchan (HelmLogger.html_of_html_tag tag);
 247     flush outchan
 248   in
 249   action logger;
 250   output_string outchan "\n</body></html>";
 251   close_out outchan
 252
 253   (* thread action *)
 254
 255 let callback (req: Http_types.request) outchan =
 256   try
 257     debug_print ("Connection from " ^ req#clientAddr);
 258     debug_print ("Received request: " ^ req#path);
 259     (match req#path with
 260     | "/help" -> return_help outchan
 261     | "/getxml" ->
 262         let uri = req#param "uri" in
 263         Http_getter_cache.respond_xml ~url:(Http_getter.resolve uri) ~uri
 264           ~enc:(parse_enc req) ~patch:(parse_patch req) outchan
 265     | "/getxslt" ->
 266         Http_getter_cache.respond_xsl
 267           ~url:(Http_getter.resolve (req#param "uri"))
 268           ~patch:(parse_patch req) outchan
 269     | "/getdtd" ->
 270         Http_getter_cache.respond_dtd ~patch:(parse_patch req)
 271           ~url:(sprintf "%s/%s"
 272             (Helm_registry.get "getter.dtd_dir") (req#param "uri"))
 273           outchan
 274     | "/resolve" -> return_resolve (req#param "uri") outchan
 275     | "/register" ->
 276         Http_getter.register ~uri:(req#param "uri") ~url:(req#param "url");
 277         return_html_msg "Register done" outchan
 278     | "/clean_cache" ->
 279         Http_getter.clean_cache ();
 280         return_html_msg "Done." outchan
 281     | "/update" ->
 282         Http_getter_env.reload (); (* reload servers list from servers file *)
 283         send_log_to (fun logger -> Http_getter.update ~logger ()) outchan
 284     | "/list_servers" -> return_list_servers outchan
 285     | "/add_server" ->
 286         let name = req#param "url" in
 287         let position = parse_position req in
 288         let prepend =
 289           sprintf "Added server %s in position %d)<br />\n" name position
 290         in
 291         send_log_to ~prepend
 292           (fun logger -> Http_getter.add_server ~logger ~position name) outchan
 293     | "/remove_server" ->
 294         let position = parse_position req in
 295         if not (Http_getter.has_server position) then
 296           raise (Bad_request (sprintf "no server with position %d" position))
 297         else
 298           let prepend =
 299             sprintf "Removed server at position %d<br />\n" position
 300           in
 301           send_log_to ~prepend
 302             (fun logger -> Http_getter.remove_server ~logger position) outchan
 303     | "/getalluris" ->
 304        return_all_xml_uris (parse_output_format "getalluris" req) outchan
 305     | "/getallrdfuris" -> return_all_rdf_uris (parse_rdf_class req) outchan
 306     | "/ls" ->
 307        return_ls (parse_ls_uri req) (parse_output_format "ls" req) outchan
 308     | "/getempty" ->
 309         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
 310     | invalid_request ->
 311         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
 312     debug_print "Done!\n"
 313   with
 314   | Http_types.Param_not_found attr_name ->
 315       let msg = sprintf "Parameter '%s' is missing" attr_name in
 316       log_failure msg;
 317       return_400 msg outchan
 318   | Bad_request msg ->
 319       log_failure msg;
 320       return_html_error msg outchan
 321   | Internal_error msg ->
 322       log_failure msg;
 323       return_html_internal_error msg outchan
 324   | Shell.Subprocess_error l ->
 325       let msgs =
 326         List.map
 327           (fun (cmd, code) ->
 328             sprintf "Command '%s' returned %s" cmd (string_of_proc_status code))
 329           l
 330       in
 331       log_failure (String.concat ", " msgs);
 332       return_html_internal_error (String.concat "<br />\n" msgs) outchan
 333   | exc ->
 334       let msg = "Uncaught exception: " ^ (Printexc.to_string exc) in
 335       log_failure msg;
 336       return_html_error msg outchan
 337
 338     (* Main *)
 339
 340 let main () =
 341   Helm_registry.load_from configuration_file;
 342   Http_getter_env.reload ();
 343   print_string (Http_getter_env.env_to_string ());
 344   flush stdout;
 345   let batch_update =
 346     try Sys.argv.(1) = "-update" with Invalid_argument _ -> false
 347   in
 348   if batch_update then  (* batch mode: performs update and exit *)
 349     Http_getter.update ~logger:Http_getter.stdout_logger ()
 350   else begin            (* daemon mode: start http daemon *)
 351     at_exit Http_getter.close_maps;
 352     Sys.catch_break true;
 353     try
 354       Http_daemon.start' ~mode:`Thread
 355         ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
 356         callback
 357     with Sys.Break -> ()  (* 'close_maps' already registered with 'at_exit' *)
 358   end
 359
 360 let _ = main ()
 361