helm/http_getter/http_getter.ml

   1 (*
   2  *  Copyright (C) 2000, HELM Team.
   3  *
   4  *  This file is part of HELM, an Hypertextual, Electronic
   5  *  Library of Mathematics, developed at the Computer Science
   6  *  Department, University of Bologna, Italy.
   7  *
   8  *  HELM is free software; you can redistribute it and/or
   9  *  modify it under the terms of the GNU General Public License
  10  *  as published by the Free Software Foundation; either version 2
  11  *  of the License, or (at your option) any later version.
  12  *
  13  *  HELM is distributed in the hope that it will be useful,
  14  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  *  GNU General Public License for more details.
  17  *
  18  *  You should have received a copy of the GNU General Public License
  19  *  along with HELM; if not, write to the Free Software
  20  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  *  MA  02111-1307, USA.
  22  *
  23  *  For details, see the HELM World-Wide-Web page,
  24  *  http://cs.unibo.it/helm/.
  25  *)
  26
  27 (* TODO optimization: precompile almost all regexp *)
  28
  29 open Http_getter_common;;
  30 open Http_getter_types;;
  31 open Printf;;
  32
  33  (* debugging settings *)
  34 let debug = true;;
  35 let debug_print s = if debug then prerr_endline ("[HTTP-Getter] " ^ s);;
  36 let http_debug = false;;
  37 Http_common.debug := http_debug;;
  38
  39 let http_get url =
  40   debug_print ("Downloading URL: " ^ url);
  41   try
  42     Some (Http_client.Convenience.http_get url)
  43   with Http_client.Http_error (code, _) ->
  44     (debug_print
  45       (sprintf "Failed to download %s, HTTP response was %d" url code);
  46     None)
  47 ;;
  48
  49 let parse_format (req: Http_types.request) =
  50   try
  51     (match req#param "format" with
  52     | "normal" -> Enc_normal
  53     | "gz" -> Enc_gzipped
  54     | s -> raise (Http_getter_bad_request ("Invalid format: " ^ s)))
  55   with Http_types.Param_not_found _ -> Enc_normal
  56 ;;
  57 let parse_patch_dtd (req: Http_types.request) =
  58   try
  59     (match req#param "patch_dtd" with
  60     | s when String.lowercase s = "yes" -> true
  61     | s when String.lowercase s = "no" -> false
  62     | s -> raise (Http_getter_bad_request ("Invalid patch_dtd value: " ^ s)))
  63   with Http_types.Param_not_found _ -> true
  64 ;;
  65 let parse_ls_format (req: Http_types.request) =
  66   match req#param "format" with
  67   | s when String.lowercase s = "txt" -> Fmt_text
  68   | s when String.lowercase s = "xml" -> Fmt_xml
  69   | s -> raise (Http_getter_bad_request ("Invalid /ls format: " ^ s))
  70 ;;
  71 let parse_ls_uri (req: Http_types.request) =
  72   let baseuri = req#param "baseuri" in
  73   let subs =
  74     Pcre.extract ~pat:"^(\\w+):(.*)$" (Pcre.replace ~pat:"/+$"  baseuri)
  75   in
  76   match (subs.(1), subs.(2)) with
  77   | "cic", uri -> Cic uri
  78   | "theory", uri -> Theory uri
  79   | _ -> raise (Http_getter_bad_request ("Invalid /ls baseuri: " ^ baseuri))
  80 ;;
  81
  82 let xml_map = new Http_getter_map.map Http_getter_env.xml_dbm in
  83 let rdf_map = new Http_getter_map.map Http_getter_env.rdf_dbm in
  84 let xsl_map = new Http_getter_map.map Http_getter_env.xsl_dbm in
  85
  86 let resolve uri = (* use global maps *)
  87   let map =
  88     match uri with
  89     | uri when is_xml_uri uri -> xml_map
  90     | uri when is_rdf_uri uri -> rdf_map
  91     | uri when is_xsl_uri uri -> xsl_map
  92     | uri -> raise (Http_getter_unresolvable_URI uri)
  93   in
  94   map#resolve uri
  95 in
  96 let return_all_foo_uris map doctype filter outchan =
  97   Http_daemon.send_basic_headers outchan;
  98   Http_daemon.send_header "Content-Type" "text/xml" outchan;
  99   Http_daemon.send_CRLF outchan;
 100   output_string
 101     outchan
 102     (sprintf
 103 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 104 <!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">;
 105
 106 <%s>
 107 "
 108       doctype
 109       Http_getter_env.my_own_url
 110       doctype
 111       doctype);
 112   map#iter
 113     (fun uri _ ->
 114       if filter uri then
 115         output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri));
 116   output_string outchan (sprintf "</%s>\n" doctype)
 117 in
 118 let return_all_uris = return_all_foo_uris xml_map "alluris" in
 119 let return_all_rdf_uris = return_all_foo_uris rdf_map "allrdfuris" in
 120 let return_ls =
 121   let (++) (oldann, oldtypes, oldbody) (newann, newtypes, newbody) =
 122     ((if newann   > oldann    then newann   else oldann),
 123      (if newtypes > oldtypes  then newtypes else oldtypes),
 124      (if newbody > oldbody    then newbody  else oldbody))
 125    in
 126   let basepartRE =
 127     Pcre.regexp "^([^.]*\\.[^.]*)((\\.body)|(\\.types))?(\\.ann)?"
 128   in
 129   fun lsuri format outchan ->
 130   let pat =
 131     "^" ^ (match lsuri with Cic p -> ("cic:" ^ p) | Theory p -> ("theory:" ^ p))
 132   in
 133   let dirs = ref [] in
 134   let objs = Hashtbl.create 17 in
 135   xml_map#iter  (* BLEARGH Dbm module lacks support for fold-like functions *)
 136     (fun _ -> function
 137       | uri when Pcre.pmatch ~pat:(pat ^ "/") uri ->  (* directory hit *)
 138           let dir =
 139             List.hd (Pcre.split ~pat:"/" (Pcre.replace ~pat:(pat ^ "/") uri))
 140           in
 141           dirs := dir :: !dirs
 142       | uri when Pcre.pmatch ~pat:(pat ^ "(\\.|$)") uri ->  (* object hit *)
 143           let localpart = Pcre.replace ~pat:"^.*/" uri in
 144           let basepart = Pcre.replace ~rex:basepartRE ~templ:"$1" localpart in
 145           let oldflags =
 146             try
 147               Hashtbl.find objs basepart
 148             with Not_found -> (false, No, No) (* no ann, no types no body *)
 149           in
 150           let newflags =
 151             match localpart with
 152             | s when Pcre.pmatch ~pat:"\\.types" s     -> (false, Yes, No)
 153             | s when Pcre.pmatch ~pat:"\\.types.ann" s -> (true,  Ann, No)
 154             | s when Pcre.pmatch ~pat:"\\.body" s      -> (false, No,  Yes)
 155             | s when Pcre.pmatch ~pat:"\\.body.ann" s  -> (true,  No,  Ann)
 156             | s ->
 157                 raise
 158                   (Http_getter_internal_error ("Invalid /ls localpart: " ^ s))
 159           in
 160           Hashtbl.replace objs basepart (oldflags ++ newflags)
 161       | _ -> () (* miss *));
 162   match format with
 163   | Fmt_text ->
 164       let body =
 165         "dir, " ^ (String.concat "\ndir, " (List.sort compare !dirs)) ^ "\n" ^
 166         (Http_getter_misc.hashtbl_sorted_fold
 167           (fun uri (annflag, typesflag, bodyflag) cont ->
 168             sprintf
 169               "%sobject, %s, <%s,%s,%s>\n"
 170               cont uri (if annflag then "YES" else "NO")
 171               (string_of_ls_flag typesflag) (string_of_ls_flag bodyflag))
 172           objs "")
 173       in Http_daemon.respond ~headers:["Content-Type", "text/txt"] ~body outchan
 174   | Fmt_xml ->
 175       let body =
 176         sprintf
 177 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 178 <!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\"
 179
 180 <ls>
 181 %s
 182 </ls>
 183 "
 184           Http_getter_env.my_own_url
 185           ("\n" ^
 186           (String.concat
 187             "\n"
 188             (List.map
 189               (fun d -> "<section>" ^ d ^ "</section>")
 190               (List.sort compare !dirs))) ^ "\n" ^
 191           (Http_getter_misc.hashtbl_sorted_fold
 192             (fun uri (annflag, typesflag, bodyflag) cont ->
 193               sprintf
 194 "%s<object name=\"%s\">
 195 \t<ann value=\"%s\">
 196 \t<types value=\"%s\">
 197 \t<body value=\"%s\">
 198 </object>
 199 "
 200                 cont uri (if annflag then "YES" else "NO")
 201                 (string_of_ls_flag typesflag)
 202                 (string_of_ls_flag bodyflag))
 203             objs ""))
 204       in Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
 205 in
 206 let update_from_server logmsg server_url = (* use global maps *)
 207   let xml_url_of_uri = function
 208       (* TODO missing sanity checks on server_url, e.g. it can contains $1 *)
 209     | uri when (Pcre.pmatch ~pat:"^cic://" uri) ->
 210         Pcre.replace ~pat:"^cic://" ~templ:server_url uri
 211     | uri when (Pcre.pmatch ~pat:"^theory://" uri) ->
 212         Pcre.replace ~pat:"^theory://" ~templ:server_url uri
 213     | uri -> raise (Http_getter_invalid_URI uri)
 214   in
 215   let rdf_url_of_uri = function (* TODO as above *)
 216     | uri when (Pcre.pmatch ~pat:"^helm:rdf.*//cic:" uri) ->
 217         Pcre.replace ~pat:"^helm:rdf.*//cic:" ~templ:server_url uri
 218     | uri when (Pcre.pmatch ~pat:"^helm:rdf.*//theory:" uri) ->
 219         Pcre.replace ~pat:"^helm:rdf.*//theory:" ~templ:server_url uri
 220     | uri -> raise (Http_getter_invalid_URI uri)
 221   in
 222   let log = ref ("Processing server: " ^ server_url ^ "<br />\n") in
 223   let (xml_index, rdf_index, xsl_index) =
 224     (* TODO keeps index in memory, is better to keep them on temp files? *)
 225     (http_get (server_url ^ "/" ^ Http_getter_env.xml_index),
 226      http_get (server_url ^ "/" ^ Http_getter_env.rdf_index),
 227      http_get (server_url ^ "/" ^ Http_getter_env.xsl_index))
 228   in
 229   if (xml_index = None && rdf_index = None && xsl_index = None) then
 230     debug_print (sprintf "Warning: useless server %s" server_url);
 231   (match xml_index with
 232   | Some xml_index ->
 233       (log := !log ^ "Updating XML db ...<br />\n";
 234       List.iter
 235         (fun l ->
 236           try
 237             (match Pcre.split ~pat:"[ \\t]+" l with
 238             | [uri; "gz"] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml.gz")
 239             | [uri] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml")
 240             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
 241           with Http_getter_invalid_URI uri ->
 242             log := !log ^ "Ignoring invalid XML URI: " ^ uri)
 243         (Pcre.split ~pat:"\n+" xml_index)) (* xml_index lines *)
 244   | None -> ());
 245   (match rdf_index with
 246   | Some rdf_index ->
 247       (log := !log ^ "Updating RDF db ...<br />\n";
 248       List.iter
 249         (fun l ->
 250           try
 251             (match Pcre.split ~pat:"[ \\t]+" l with
 252             | [uri; "gz"] -> rdf_map#add uri ((rdf_url_of_uri uri) ^ ".xml.gz")
 253             | [uri] -> rdf_map#add uri ((rdf_url_of_uri uri) ^ ".xml")
 254             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
 255           with Http_getter_invalid_URI uri ->
 256             log := !log ^ "Ignoring invalid RDF URI: " ^ uri)
 257         (Pcre.split ~pat:"\n+" rdf_index)) (* rdf_index lines *)
 258   | None -> ());
 259   (match xsl_index with
 260   | Some xsl_index ->
 261       (log := !log ^ "Updating XSLT db ...<br />\n";
 262       List.iter
 263         (fun l -> xsl_map#add l (server_url ^ "/" ^ l))
 264         (Pcre.split ~pat:"\n+" xsl_index);
 265       log := !log ^ "All done!<br />\n")
 266   | None -> ());
 267   !log
 268 in
 269
 270   (* thread action *)
 271 let callback (req: Http_types.request) outchan =
 272   try
 273     debug_print ("Connection from " ^ req#clientAddr);
 274     debug_print ("Received request: " ^ req#path);
 275     (match req#path with
 276     | "/help" -> return_html_msg Http_getter_const.usage_string outchan
 277     | "/getxml" | "/getxslt" | "/getdtd" | "/resolve" | "/register" ->
 278         (let uri = req#param "uri" in  (* common parameter *)
 279         match req#path with
 280         | "/getxml" ->
 281             let enc = parse_format req in
 282             let patch_dtd = parse_patch_dtd req in
 283             Http_getter_cache.respond_xml
 284               ~url:(resolve uri) ~uri ~enc ~patch_dtd outchan
 285         | "/getxslt" ->
 286 (*             let patch_dtd = parse_patch_dtd req in *)
 287             (* TODO add support and default value for patch_dtd *)
 288             Http_getter_cache.respond_xsl ~url:(resolve uri) outchan
 289         | "/getdtd" ->
 290             let patch_dtd = parse_patch_dtd req in
 291             Http_getter_cache.respond_dtd
 292               ~patch_dtd ~url:(Http_getter_env.dtd_dir ^ "/" ^ uri) outchan
 293         | "/resolve" ->
 294             (try
 295               return_xml_msg
 296                 (sprintf "<url value=\"%s\" />\n" (resolve uri))
 297                 outchan
 298             with Http_getter_unresolvable_URI uri ->
 299               return_xml_msg "<unresolved />\n" outchan)
 300         | "/register" ->
 301             let url = req#param "url" in
 302             xml_map#add uri url;
 303             return_html_msg "Register done" outchan
 304         | _ -> assert false)
 305     | "/update" ->
 306         (xml_map#clear; rdf_map#clear; xsl_map#clear;
 307         let log =
 308           List.fold_left
 309             update_from_server
 310             ""  (* initial logmsg: empty *)
 311               (* reverse order: 1st server is the most important one *)
 312             (List.rev Http_getter_env.servers)
 313         in
 314         return_html_msg log outchan)
 315     | "/getalluris" ->
 316         return_all_uris
 317           (fun uri ->
 318             (Pcre.pmatch ~pat:"^cic:" uri) &&
 319             not (Pcre.pmatch ~pat:"\\.types$" uri))
 320           outchan
 321     | "/getallrdfuris" ->
 322         (let classs = req#param "class" in
 323         try
 324           let filter =
 325             let base = "^helm:rdf:www\\.cs\\.unibo\\.it/helm/rdf/" in
 326             match classs with
 327             | ("forward" as c) | ("backward" as c) ->
 328                 (fun uri -> Pcre.pmatch ~pat:(base ^ c) uri)
 329             | c -> raise (Http_getter_invalid_RDF_class c)
 330           in
 331           return_all_rdf_uris filter outchan
 332         with Http_getter_invalid_RDF_class c ->
 333           raise (Http_getter_bad_request ("Invalid RDF class: " ^ c)))
 334     | "/ls" -> return_ls (parse_ls_uri req) (parse_ls_format req) outchan
 335     | "/getempty" ->
 336         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
 337     | invalid_request ->
 338         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 339   with
 340   | Http_types.Param_not_found attr_name ->
 341       return_400 (sprintf "Parameter '%s' is missing" attr_name) outchan
 342   | Http_getter_bad_request msg -> return_html_error msg outchan
 343   | Http_getter_internal_error msg -> return_html_internal_error msg outchan
 344   | exc ->
 345       return_html_error
 346         ("Uncaught exception: " ^ (Printexc.to_string exc))
 347         outchan
 348 in
 349
 350   (* daemon initialization *)
 351 Http_getter_env.dump_env ();
 352 flush stdout;
 353 Unix.putenv "http_proxy" "";
 354 Http_daemon.start'
 355   ~timeout:None ~port:Http_getter_env.port ~mode:`Thread callback
 356