helm/http_getter/http_getter.ml

   1 (*
   2  * Copyright (C) 2003:
   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 Http_getter_common;;
  30 open Http_getter_misc;;
  31 open Http_getter_types;;
  32 open Http_getter_debugger;;
  33 open Printf;;
  34
  35   (* constants *)
  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 Enc_normal *)
  46 let parse_enc (req: Http_types.request) =
  47   try
  48     (match req#param "format" with
  49     | "normal" -> Enc_normal
  50     | "gz" -> Enc_gzipped
  51     | s -> raise (Http_getter_bad_request ("Invalid format: " ^ s)))
  52   with Http_types.Param_not_found _ -> Enc_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 (Http_getter_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 (req: Http_types.request) =
  65   match req#param "format" with
  66   | s when String.lowercase s = "txt" -> Fmt_text
  67   | s when String.lowercase s = "xml" -> Fmt_xml
  68   | s -> raise (Http_getter_bad_request ("Invalid /ls format: " ^ s))
  69 ;;
  70   (* parse "baseuri" format for /ls method, no default value *)
  71 let parse_ls_uri =
  72   let parse_ls_RE = Pcre.regexp "^(\\w+):(.*)$" in
  73   let trailing_slash_RE = Pcre.regexp "/+$" in
  74   let wrong_uri uri =
  75     raise (Http_getter_bad_request ("Invalid /ls baseuri: " ^ uri))
  76   in
  77   fun (req: Http_types.request) ->
  78     let baseuri = req#param "baseuri" in
  79     try
  80       let subs =
  81         Pcre.extract ~rex:parse_ls_RE
  82           (Pcre.replace ~rex:trailing_slash_RE  baseuri)
  83       in
  84       (match (subs.(1), subs.(2)) with
  85       | "cic", uri -> Cic uri
  86       | "theory", uri -> Theory uri
  87       | _ -> wrong_uri baseuri)
  88     with Not_found -> wrong_uri baseuri
  89 ;;
  90
  91   (* global maps, shared by all threads *)
  92
  93 let cic_map = new Http_getter_map.map Http_getter_env.cic_dbm in
  94 let nuprl_map = new Http_getter_map.map Http_getter_env.nuprl_dbm in
  95 let rdf_map = new Http_getter_map.map Http_getter_env.rdf_dbm in
  96 let xsl_map = new Http_getter_map.map Http_getter_env.xsl_dbm in
  97
  98 let save_maps () =
  99  cic_map#close; nuprl_map#close; rdf_map#close; xsl_map#close in
 100 let map_of_uri = function
 101   | uri when is_cic_uri uri -> cic_map
 102   | uri when is_nuprl_uri uri -> nuprl_map
 103   | uri when is_rdf_uri uri -> rdf_map
 104   | uri when is_xsl_uri uri -> xsl_map
 105   | uri -> raise (Http_getter_unresolvable_URI uri)
 106 in
 107 let resolve uri =
 108   try
 109     (map_of_uri uri)#resolve uri
 110   with Http_getter_map.Key_not_found _ ->
 111     raise (Http_getter_unresolvable_URI uri)
 112 in
 113 let register uri =
 114   (* Warning: this fail if uri is already registered *)
 115   (map_of_uri uri)#add uri
 116 in
 117 let return_all_foo_uris map doctype filter outchan =
 118   (** return all URIs contained in 'map' which satisfy predicate 'filter'; URIs
 119   are written in an XMLish format ('doctype' is the XML doctype) onto 'outchan'
 120   *)
 121   Http_daemon.send_basic_headers ~code:200 outchan;
 122   Http_daemon.send_header "Content-Type" "text/xml" outchan;
 123   Http_daemon.send_headers common_headers outchan;
 124   Http_daemon.send_CRLF outchan;
 125   output_string
 126     outchan
 127     (sprintf
 128 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 129 <!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">
 130
 131 <%s>
 132 "
 133       doctype
 134       Http_getter_env.my_own_url
 135       doctype
 136       doctype);
 137   map#iter
 138     (fun uri _ ->
 139       if filter uri then
 140         output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri));
 141   output_string outchan (sprintf "</%s>\n" doctype)
 142 in
 143 let return_all_xml_uris = return_all_foo_uris cic_map "alluris" in
 144 let return_all_rdf_uris = return_all_foo_uris rdf_map "allrdfuris" in
 145 let return_ls =
 146   let (++) (oldann, oldtypes, oldbody, oldtree)
 147            (newann, newtypes, newbody, newtree) =
 148     ((if newann   > oldann    then newann   else oldann),
 149      (if newtypes > oldtypes  then newtypes else oldtypes),
 150      (if newbody  > oldbody   then newbody  else oldbody),
 151      (if newtree  > oldtree   then newtree  else oldtree))
 152   in
 153   let basepart_RE =
 154     Pcre.regexp
 155       "^([^.]*\\.[^.]*)((\\.body)|(\\.proof_tree)|(\\.types))?(\\.ann)?"
 156   in
 157   let (types_RE, types_ann_RE, body_RE, body_ann_RE,
 158        proof_tree_RE, proof_tree_ann_RE) =
 159     (Pcre.regexp "\\.types", Pcre.regexp "\\.types\\.ann",
 160      Pcre.regexp "\\.body", Pcre.regexp "\\.body.ann",
 161      Pcre.regexp "\\.proof_tree", Pcre.regexp "\\.proof_tree\\.ann")
 162   in
 163   let (slash_RE, til_slash_RE, no_slashes_RE) =
 164     (Pcre.regexp "/", Pcre.regexp "^.*/", Pcre.regexp "^[^/]*$")
 165   in
 166   fun lsuri fmt outchan ->
 167     let pat =
 168       "^" ^
 169       (match lsuri with Cic p -> ("cic:" ^ p) | Theory p -> ("theory:" ^ p))
 170     in
 171     let (dir_RE, obj_RE) =
 172       (Pcre.regexp (pat ^ "/"), Pcre.regexp (pat ^ "(\\.|$)"))
 173     in
 174     let dirs = ref StringSet.empty in
 175     let objs = Hashtbl.create 17 in
 176     let store_dir d =
 177       dirs := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !dirs
 178     in
 179     let store_obj o =
 180       let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
 181       let no_flags = false, No, No, No in
 182       let oldflags =
 183         try
 184           Hashtbl.find objs basepart
 185         with Not_found -> (* no ann, no types, no body, no proof tree *)
 186           no_flags
 187       in
 188       let newflags =
 189         match o with
 190         | s when Pcre.pmatch ~rex:types_RE s          -> (false, Yes, No, No)
 191         | s when Pcre.pmatch ~rex:types_ann_RE s      -> (true,  Ann, No, No)
 192         | s when Pcre.pmatch ~rex:body_RE s           -> (false, No, Yes, No)
 193         | s when Pcre.pmatch ~rex:body_ann_RE s       -> (true,  No, Ann, No)
 194         | s when Pcre.pmatch ~rex:proof_tree_RE s     -> (false, No, No, Yes)
 195         | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true,  No, No, Ann)
 196         | s -> no_flags
 197       in
 198       Hashtbl.replace objs basepart (oldflags ++ newflags)
 199     in
 200     cic_map#iter  (* BLEARGH Dbm module lacks support for fold-like functions *)
 201       (fun key _ ->
 202         match key with
 203         | uri when Pcre.pmatch ~rex:dir_RE uri ->  (* directory hit *)
 204             let localpart = Pcre.replace ~rex:dir_RE uri in
 205             if Pcre.pmatch ~rex:no_slashes_RE localpart then
 206               store_obj localpart
 207             else
 208               store_dir localpart
 209         | uri when Pcre.pmatch ~rex:obj_RE  uri ->  (* file hit *)
 210             store_obj (Pcre.replace ~rex:til_slash_RE uri)
 211         | uri -> () (* miss *));
 212     match fmt with
 213     | Fmt_text ->
 214         let body =
 215           (List.fold_left
 216             (fun s d -> sprintf "%sdir, %s\n" s d) ""
 217             (StringSet.elements !dirs)) ^
 218           (Http_getter_misc.hashtbl_sorted_fold
 219             (fun uri (annflag, typesflag, bodyflag, treeflag) cont ->
 220               sprintf "%sobject, %s, <%s,%s,%s,%s>\n"
 221                 cont uri (if annflag then "YES" else "NO")
 222                 (string_of_ls_flag typesflag)
 223                 (string_of_ls_flag bodyflag)
 224                 (string_of_ls_flag treeflag))
 225             objs "")
 226         in
 227         Http_daemon.respond
 228           ~headers:(("Content-Type", "text/plain") :: common_headers)
 229           ~body outchan
 230     | Fmt_xml ->
 231         let body =
 232           sprintf
 233 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
 234 <!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">
 235
 236 <ls>
 237 %s
 238 </ls>
 239 "
 240             Http_getter_env.my_own_url
 241             ("\n" ^
 242             (String.concat
 243               "\n"
 244               (List.map
 245                 (fun d -> "<section>" ^ d ^ "</section>")
 246                 (StringSet.elements !dirs))) ^ "\n" ^
 247             (Http_getter_misc.hashtbl_sorted_fold
 248               (fun uri (annflag, typesflag, bodyflag, treeflag) cont ->
 249                 sprintf
 250 "%s<object name=\"%s\">
 251 \t<ann value=\"%s\" />
 252 \t<types value=\"%s\" />
 253 \t<body value=\"%s\" />
 254 \t<proof_tree value=\"%s\" />
 255 </object>
 256 "
 257                   cont uri (if annflag then "YES" else "NO")
 258                   (string_of_ls_flag typesflag)
 259                   (string_of_ls_flag bodyflag)
 260                   (string_of_ls_flag treeflag))
 261               objs ""))
 262         in
 263         Http_daemon.respond
 264           ~headers:(("Content-Type", "text/xml") :: common_headers)
 265           ~body outchan
 266 in
 267 let (index_line_sep_RE, index_sep_RE, trailing_types_RE,
 268     heading_cic_RE, heading_theory_RE, heading_nuprl_RE,
 269     heading_rdf_cic_RE, heading_rdf_theory_RE) =
 270   (Pcre.regexp "[ \t]+", Pcre.regexp "\r\n|\r|\n",
 271   Pcre.regexp "\\.types$",
 272   Pcre.regexp "^cic:", Pcre.regexp "^theory:", Pcre.regexp "^nuprl:",
 273   Pcre.regexp "^helm:rdf.*//cic:", Pcre.regexp "^helm:rdf.*//theory:")
 274 in
 275 let update_from_server logmsg server_url = (* use global maps *)
 276   debug_print ("Updating information from " ^ server_url);
 277   let xml_url_of_uri = function
 278       (* TODO missing sanity checks on server_url, e.g. it can contains $1 *)
 279     | uri when (Pcre.pmatch ~rex:heading_cic_RE uri) ->
 280         Pcre.replace ~rex:heading_cic_RE ~templ:server_url uri
 281     | uri when (Pcre.pmatch ~rex:heading_theory_RE uri) ->
 282         Pcre.replace ~rex:heading_theory_RE ~templ:server_url uri
 283     | uri when (Pcre.pmatch ~rex:heading_nuprl_RE uri) ->
 284         Pcre.replace ~rex:heading_nuprl_RE ~templ:server_url uri
 285     | uri -> raise (Http_getter_invalid_URI uri)
 286   in
 287   let rdf_url_of_uri = function (* TODO as above *)
 288     | uri when (Pcre.pmatch ~rex:heading_rdf_cic_RE uri) ->
 289         Pcre.replace ~rex:heading_rdf_cic_RE ~templ:server_url uri
 290     | uri when (Pcre.pmatch ~rex:heading_rdf_theory_RE uri) ->
 291         Pcre.replace ~rex:heading_rdf_theory_RE ~templ:server_url uri
 292     | uri -> raise (Http_getter_invalid_URI uri)
 293   in
 294   let log = ref (logmsg ^ "Processing server: " ^ server_url ^ "<br />\n") in
 295   let (xml_index, rdf_index, xsl_index) =
 296     (* TODO keeps index in memory, is better to keep them on temp files? *)
 297     (http_get (server_url ^ "/" ^ Http_getter_env.xml_index),
 298      http_get (server_url ^ "/" ^ Http_getter_env.rdf_index),
 299      http_get (server_url ^ "/" ^ Http_getter_env.xsl_index))
 300   in
 301   if (xml_index = None && rdf_index = None && xsl_index = None) then
 302     debug_print (sprintf "Warning: useless server %s" server_url);
 303   (match xml_index with
 304   | Some xml_index ->
 305       (log := !log ^ "Updating XML db ...<br />\n";
 306       List.iter
 307         (function
 308           | l when is_blank_line l -> ()  (* skip blank and commented lines *)
 309           | l ->
 310               try
 311                 (match Pcre.split ~rex:index_line_sep_RE l with
 312                 | [uri; "gz"] ->
 313                    assert (is_cic_uri uri || is_nuprl_uri uri) ;
 314                    (map_of_uri uri)#replace
 315                     uri ((xml_url_of_uri uri) ^ ".xml.gz")
 316                 | [uri] ->
 317                    assert (is_cic_uri uri || is_nuprl_uri uri) ;
 318                    (map_of_uri uri)#replace
 319                     uri ((xml_url_of_uri uri) ^ ".xml")
 320                 | _ ->
 321                     log := !log ^ "Ignoring invalid line: '" ^ l ^ "'<br />\n")
 322               with Http_getter_invalid_URI uri ->
 323                 log := !log ^ "Ignoring invalid XML URI: '" ^ uri ^ "'<br />\n")
 324             (Pcre.split ~rex:index_sep_RE xml_index)) (* xml_index lines *)
 325   | None -> ());
 326   (match rdf_index with
 327   | Some rdf_index ->
 328       (log := !log ^ "Updating RDF db ...<br />\n";
 329       List.iter
 330         (fun l ->
 331           try
 332             (match Pcre.split ~rex:index_line_sep_RE l with
 333             | [uri; "gz"] ->
 334                 rdf_map#replace uri ((rdf_url_of_uri uri) ^ ".xml.gz")
 335             | [uri] -> rdf_map#replace uri ((rdf_url_of_uri uri) ^ ".xml")
 336             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
 337           with Http_getter_invalid_URI uri ->
 338             log := !log ^ "Ignoring invalid RDF URI: " ^ uri ^ "<br />\n")
 339         (Pcre.split ~rex:index_sep_RE rdf_index)) (* rdf_index lines *)
 340   | None -> ());
 341   (match xsl_index with
 342   | Some xsl_index ->
 343       (log := !log ^ "Updating XSLT db ...<br />\n";
 344       List.iter
 345         (fun l -> xsl_map#replace l (server_url ^ "/" ^ l))
 346         (Pcre.split ~rex:index_sep_RE xsl_index);
 347       log := !log ^ "All done!<br />\n")
 348   | None -> ());
 349   debug_print "done with this server";
 350   !log
 351 in
 352 let update_from_all_servers () =  (* use global maps *)
 353   cic_map#clear; nuprl_map#clear; rdf_map#clear; xsl_map#clear;
 354   let log =
 355     List.fold_left
 356       update_from_server
 357       ""  (* initial logmsg: empty *)
 358         (* reverse order: 1st server is the most important one *)
 359       (List.rev !Http_getter_env.servers)
 360   in
 361   cic_map#sync; nuprl_map#sync; rdf_map#sync; xsl_map#sync;
 362   log
 363 in
 364
 365   (* thread action *)
 366
 367 let callback (req: Http_types.request) outchan =
 368   try
 369     debug_print ("Connection from " ^ req#clientAddr);
 370     debug_print ("Received request: " ^ req#path);
 371     (match req#path with
 372     | "/help" ->
 373         return_html_raw
 374           (Http_getter_const.usage_string (Http_getter_env.env_to_string ()))
 375           outchan
 376     | "/getxml" | "/getxslt" | "/getdtd" | "/resolve" | "/register" ->
 377         (let uri = req#param "uri" in  (* common parameter *)
 378         match req#path with
 379         | "/getxml" ->
 380             let enc = parse_enc req in
 381             let patch = parse_patch req in
 382             Http_getter_cache.respond_xml
 383               ~url:(resolve uri) ~uri ~enc ~patch outchan
 384         | "/getxslt" ->
 385             let patch = parse_patch req in
 386             Http_getter_cache.respond_xsl ~url:(resolve uri) ~patch outchan
 387         | "/getdtd" ->
 388             let patch = parse_patch req in
 389             Http_getter_cache.respond_dtd
 390               ~patch ~url:(Http_getter_env.dtd_dir ^ "/" ^ uri) outchan
 391         | "/resolve" ->
 392             (try
 393               return_xml_raw
 394                 (sprintf "<url value=\"%s\" />\n" (resolve uri))
 395                 outchan
 396             with Http_getter_unresolvable_URI uri ->
 397               return_xml_raw "<unresolved />\n" outchan)
 398         | "/register" ->
 399             let url = req#param "url" in
 400             register uri url;
 401             return_html_msg "Register done" outchan
 402         | _ -> assert false)
 403     | "/clean_cache" ->
 404         Http_getter_cache.clean ();
 405         return_html_msg "Done." outchan
 406     | "/update" ->
 407         Http_getter_env.reload (); (* reload servers list from servers file *)
 408         let log = update_from_all_servers () in
 409         return_html_msg log outchan
 410     | "/list_servers" ->
 411         return_html_raw
 412           (sprintf "<html><body><table>\n%s\n</table></body></html>"
 413             (String.concat "\n"
 414               (List.map
 415                 (let i = ref ~-1 in
 416                 fun s -> incr i; sprintf "<tr><td>%d</td><td>%s</td></tr>" !i s)
 417                 !Http_getter_env.servers)))
 418           outchan
 419     | "/add_server" ->
 420         let name = req#param "url" in
 421         (try
 422           let position =
 423             try
 424               let res = int_of_string (req#param "position") in
 425               if res < 0 then
 426                 raise (Failure "int_of_string");
 427               res
 428             with Failure "int_of_string" ->
 429               raise (Http_getter_bad_request
 430                 (sprintf "position must be a non negative integer (%s given)"
 431                   (req#param "position")))
 432           in
 433           if position = 0 then  (* fallback to default value *)
 434             raise (Http_types.Param_not_found "foo")
 435           else if position > 0 then begin (* add server and update all *)
 436             Http_getter_env.add_server ~position name;
 437             let log = update_from_all_servers () in
 438             return_html_msg
 439               (sprintf "Added server %s in position %d)<br />\n%s"
 440                 name position log)
 441               outchan
 442           end else (* position < 0 *) (* error! *)
 443             assert false (* already checked above *)
 444         with Http_types.Param_not_found _ ->  (* add as 1st server by default *)
 445           Http_getter_env.add_server ~position:0 name;
 446           let log = update_from_server  (* quick update (new server only) *)
 447             (sprintf "Added server %s in head position<br />\n" name) name
 448           in
 449           return_html_msg log outchan)
 450     | "/remove_server" ->
 451         let position =
 452           try
 453             let res = int_of_string (req#param "position") in
 454             if res < 0 then
 455               raise (Failure "int_of_string");
 456             res
 457           with Failure "int_of_string" ->
 458             raise (Http_getter_bad_request
 459               (sprintf "position must be a non negative integer (%s given)"
 460                 (req#param "position")))
 461         in
 462         let server_name =
 463           try
 464             List.nth !Http_getter_env.servers position
 465           with Failure "nth" ->
 466             raise (Http_getter_bad_request
 467               (sprintf "no server with position %d" position))
 468         in
 469         Http_getter_env.remove_server position;
 470         let log = update_from_all_servers () in
 471         return_html_msg
 472           (sprintf "Removed server %s (position %d)<br />\n%s"
 473             server_name position log)
 474           outchan
 475     | "/getalluris" ->
 476         return_all_xml_uris
 477           (fun uri ->
 478             (Pcre.pmatch ~rex:heading_cic_RE uri) &&
 479             not (Pcre.pmatch ~rex:trailing_types_RE uri))
 480           outchan
 481     | "/getallrdfuris" ->
 482         (let classs = req#param "class" in
 483         try
 484           let filter =
 485             let base = "^helm:rdf:www\\.cs\\.unibo\\.it/helm/rdf/" in
 486             match classs with
 487             | ("forward" as c) | ("backward" as c) ->
 488                 (fun uri -> Pcre.pmatch ~pat:(base ^ c) uri)
 489             | c -> raise (Http_getter_invalid_RDF_class c)
 490           in
 491           return_all_rdf_uris filter outchan
 492         with Http_getter_invalid_RDF_class c ->
 493           raise (Http_getter_bad_request ("Invalid RDF class: " ^ c)))
 494     | "/ls" -> return_ls (parse_ls_uri req) (parse_output_format req) outchan
 495     | "/getempty" ->
 496         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
 497     | invalid_request ->
 498         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
 499     debug_print "Done!\n"
 500   with
 501   | Http_types.Param_not_found attr_name ->
 502       return_400 (sprintf "Parameter '%s' is missing" attr_name) outchan
 503   | Http_getter_bad_request msg -> return_html_error msg outchan
 504   | Http_getter_internal_error msg -> return_html_internal_error msg outchan
 505   | Shell.Subprocess_error l ->
 506       return_html_internal_error
 507         (String.concat "<br />\n"
 508           (List.map
 509             (fun (cmd, code) ->
 510               sprintf "Command '%s' returned %s"
 511                 cmd (string_of_proc_status code))
 512             l))
 513         outchan
 514   | exc ->
 515       return_html_error
 516         ("Uncaught exception: " ^ (Printexc.to_string exc))
 517         outchan
 518 in
 519
 520     (* daemon initialization *)
 521
 522 let main () =
 523   print_string (Http_getter_env.env_to_string ());
 524   flush stdout;
 525   Unix.putenv "http_proxy" "";
 526   at_exit save_maps;
 527   Sys.catch_break true;
 528   try
 529     Http_daemon.start'
 530       ~timeout:(Some 600) ~port:Http_getter_env.port ~mode:`Thread callback
 531   with Sys.Break -> ()  (* 'save_maps' already registered with 'at_exit' *)
 532 in
 533
 534 main ()
 535