- precompiled some regexps

- moved debug_print to Http_getter_debugger
- moved http_get in Http_getter_misc
- moved main in a 'main' function
- added 'at_exit' handler which saves maps

diff --git a/helm/http_getter/http_getter.ml b/helm/http_getter/http_getter.ml
index 7eb8deae4998047b59b6adb181a0488e143ed194..45d476047958e6e2a0a94e7bb8000f08e3705708 100644 (file)
--- a/helm/http_getter/http_getter.ml
+++ b/helm/http_getter/http_getter.ml
@@ -24,29 +24,15 @@
  *  http://cs.unibo.it/helm/.
  *)
 
-(* TODO optimization: precompile almost all regexp *)
+(* TODO optimization: precompile regexps *)
 
 open Http_getter_common;;
+open Http_getter_misc;;
 open Http_getter_types;;
+open Http_getter_debugger;;
 open Printf;;
 
- (* debugging settings *)
-let debug = true;;
-let debug_print s = if debug then prerr_endline ("[HTTP-Getter] " ^ s);;
-let http_debug = false;;
-Http_common.debug := http_debug;;
-
-let http_get url =
-(*   debug_print ("Downloading URL: " ^ url); *)
-  try
-    Some (Http_client.Convenience.http_get url)
-  with Http_client.Http_error (code, _) -> None
-(*
-    (debug_print
-      (sprintf "Failed to download %s, HTTP response was %d" url code);
-    None)
-*)
-;;
+  (* HTTP queries argument parsing *)
 
 let parse_enc (req: Http_types.request) =
   try
@@ -79,6 +65,8 @@ let parse_ls_uri (req: Http_types.request) =
   | _ -> raise (Http_getter_bad_request ("Invalid /ls baseuri: " ^ baseuri))
 ;;
 
+  (* global maps, shared by all threads *)
+
 let xml_map = new Http_getter_map.map Http_getter_env.xml_dbm in
 let rdf_map = new Http_getter_map.map Http_getter_env.rdf_dbm in
 let xsl_map = new Http_getter_map.map Http_getter_env.xsl_dbm in
@@ -223,6 +211,9 @@ let return_ls =
         Http_daemon.respond
           ~headers:["Content-Type", "text/xml"] ~body outchan
 in
+let (index_line_sep_RE, index_sep_RE) =
+  (Pcre.regexp "[ \t]+", Pcre.regexp "\n+")
+in
 let update_from_server logmsg server_url = (* use global maps *)
   debug_print ("Updating information from " ^ server_url);
   let xml_url_of_uri = function
@@ -255,13 +246,13 @@ let update_from_server logmsg server_url = (* use global maps *)
       List.iter
         (fun l ->
           try
-            (match Pcre.split ~pat:"[ \\t]+" l with
+            (match Pcre.split ~rex:index_line_sep_RE l with
             | [uri; "gz"] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml.gz")
             | [uri] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml")
             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
           with Http_getter_invalid_URI uri ->
             log := !log ^ "Ignoring invalid XML URI: " ^ uri ^ "<br />\n")
-        (Pcre.split ~pat:"\n+" xml_index)) (* xml_index lines *)
+        (Pcre.split ~rex:index_sep_RE xml_index)) (* xml_index lines *)
   | None -> ());
   (match rdf_index with
   | Some rdf_index ->
@@ -269,26 +260,28 @@ let update_from_server logmsg server_url = (* use global maps *)
       List.iter
         (fun l ->
           try
-            (match Pcre.split ~pat:"[ \\t]+" l with
+            (match Pcre.split ~rex:index_line_sep_RE l with
             | [uri; "gz"] -> rdf_map#add uri ((rdf_url_of_uri uri) ^ ".xml.gz")
             | [uri] -> rdf_map#add uri ((rdf_url_of_uri uri) ^ ".xml")
             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
           with Http_getter_invalid_URI uri ->
             log := !log ^ "Ignoring invalid RDF URI: " ^ uri ^ "<br />\n")
-        (Pcre.split ~pat:"\n+" rdf_index)) (* rdf_index lines *)
+        (Pcre.split ~rex:index_sep_RE rdf_index)) (* rdf_index lines *)
   | None -> ());
   (match xsl_index with
   | Some xsl_index ->
       (log := !log ^ "Updating XSLT db ...<br />\n";
       List.iter
         (fun l -> xsl_map#add l (server_url ^ "/" ^ l))
-        (Pcre.split ~pat:"\n+" xsl_index);
+        (Pcre.split ~rex:index_sep_RE xsl_index);
       log := !log ^ "All done!<br />\n")
   | None -> ());
+  debug_print "done with this server";
   !log
 in
 
   (* thread action *)
+
 let callback (req: Http_types.request) outchan =
   try
     debug_print ("Connection from " ^ req#clientAddr);
@@ -363,26 +356,39 @@ let callback (req: Http_types.request) outchan =
         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
     | invalid_request ->
         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
-    debug_print "Done!"
+    debug_print "Done!\n"
   with
   | Http_types.Param_not_found attr_name ->
       return_400 (sprintf "Parameter '%s' is missing" attr_name) outchan
   | Http_getter_bad_request msg -> return_html_error msg outchan
   | Http_getter_internal_error msg -> return_html_internal_error msg outchan
+  | Shell.Subprocess_error l ->
+      return_html_internal_error
+        (String.concat "<br />\n"
+          (List.map
+            (fun (cmd, code) ->
+              sprintf "Command '%s' returned %s"
+                cmd (string_of_proc_status code))
+            l))
+        outchan
   | exc ->
       return_html_error
         ("Uncaught exception: " ^ (Printexc.to_string exc))
         outchan
 in
 
-  (* daemon initialization *)
-Http_getter_env.dump_env ();
-flush stdout;
-Unix.putenv "http_proxy" "";
-Sys.catch_break true;
-try
-  Http_daemon.start'
-    ~timeout:None ~port:Http_getter_env.port ~mode:`Thread callback
-with Sys.Break ->
-  save_maps ()
+    (* daemon initialization *)
+
+let main () =
+  Http_getter_env.dump_env ();
+  Unix.putenv "http_proxy" "";
+  at_exit save_maps;
+  Sys.catch_break true;
+  try
+    Http_daemon.start'
+      ~timeout:(Some 600) ~port:Http_getter_env.port ~mode:`Thread callback
+  with Sys.Break -> ()  (* 'save_maps' already registered with 'at_exit' *)
+in
+
+main ()