* added TODO file

[helm.git] / helm / http_getter / main.ml

diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml
index e6b9f6e02abbcc24caee56cbb83c564f5a522055..eafbc06e6e571c44c75650668dc7d58c9c0fcd04 100644 (file)
--- a/helm/http_getter/main.ml
+++ b/helm/http_getter/main.ml
@@ -35,6 +35,8 @@ open Http_getter_debugger
 
   (* constants *)
 
+let configuration_file = "/projects/helm/etc/http_getter.conf.xml"
+
 let common_headers = [
   "Cache-Control", "no-cache";
   "Pragma", "no-cache";
@@ -62,11 +64,11 @@ let parse_patch (req: Http_types.request) =
   with Http_types.Param_not_found _ -> true
 
   (* parse output format ("format" parameter), no default value *)
-let parse_output_format (req: Http_types.request) =
+let parse_output_format meth (req: Http_types.request) =
   match req#param "format" with
   | s when String.lowercase s = "txt" -> Fmt_text
   | s when String.lowercase s = "xml" -> Fmt_xml
-  | s -> raise (Bad_request ("Invalid /ls format: " ^ s))
+  | s -> raise (Bad_request ("Invalid /" ^ meth ^ " format: " ^ s))
 
   (* parse "baseuri" format for /ls method, no default value *)
 let parse_ls_uri =
@@ -122,7 +124,7 @@ let return_all_foo_uris doctype uris outchan =
 <%s>
 "
       doctype
-      Http_getter_env.my_own_url
+      (Lazy.force Http_getter_env.my_own_url)
       doctype
       doctype);
   List.iter
@@ -130,8 +132,19 @@ let return_all_foo_uris doctype uris outchan =
     uris;
   output_string outchan (sprintf "</%s>\n" doctype)
 
-let return_all_xml_uris outchan =
-  return_all_foo_uris "alluris" (Http_getter.getalluris ()) outchan
+let return_all_xml_uris fmt outchan =
+ let uris = Http_getter.getalluris () in
+  match fmt with
+   | Fmt_text ->
+      let buf = Buffer.create 10240 in
+       List.iter (bprintf buf "%s\n") uris ;
+       let body = Buffer.contents buf in
+       Http_daemon.respond
+         ~headers:(("Content-Type", "text/plain") :: common_headers)
+         ~body outchan
+   | Fmt_xml ->
+      return_all_foo_uris "alluris" uris outchan
+  
 let return_all_rdf_uris classs outchan =
   return_all_foo_uris "allrdfuris" (Http_getter.getallrdfuris classs) outchan
 
@@ -153,7 +166,7 @@ let return_ls xmluri fmt outchan =
   | Fmt_xml ->
       Buffer.add_string buf "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
       bprintf buf "<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">\n"
-        Http_getter_env.my_own_url;
+        (Lazy.force Http_getter_env.my_own_url);
       Buffer.add_string buf "<ls>\n";
       List.iter
         (function
@@ -216,7 +229,9 @@ let callback (req: Http_types.request) outchan =
           ~patch:(parse_patch req) outchan
     | "/getdtd" ->
         Http_getter_cache.respond_dtd ~patch:(parse_patch req)
-          ~url:(Http_getter_env.dtd_dir ^ "/" ^ (req#param "uri")) outchan
+          ~url:(sprintf "%s/%s"
+            (Helm_registry.get "getter.dtd_dir") (req#param "uri"))
+          outchan
     | "/resolve" -> return_resolve (req#param "uri") outchan
     | "/register" ->
         Http_getter.register ~uri:(req#param "uri") ~url:(req#param "url");
@@ -227,7 +242,7 @@ let callback (req: Http_types.request) outchan =
     | "/update" ->
         Http_getter_env.reload (); (* reload servers list from servers file *)
         let log = Http_getter.update () in
-        return_html_msg (Ui_logger.html_of_html_msg log) outchan
+        return_html_msg (HelmLogger.html_of_html_msg log) outchan
     | "/list_servers" -> return_list_servers outchan
     | "/add_server" ->
         let name = req#param "url" in
@@ -235,7 +250,7 @@ let callback (req: Http_types.request) outchan =
         let log = Http_getter.add_server ~position name in
         return_html_msg
           (sprintf "Added server %s in position %d)<br />\n%s"
-            name position (Ui_logger.html_of_html_msg log))
+            name position (HelmLogger.html_of_html_msg log))
           outchan
     | "/remove_server" ->
         let position = parse_position req in
@@ -247,11 +262,13 @@ let callback (req: Http_types.request) outchan =
         in
         return_html_msg
           (sprintf "Removed server at position %d<br />\n%s"
-            position (Ui_logger.html_of_html_msg log))
+            position (HelmLogger.html_of_html_msg log))
           outchan
-    | "/getalluris" -> return_all_xml_uris outchan
+    | "/getalluris" ->
+       return_all_xml_uris (parse_output_format "getalluris" req) outchan
     | "/getallrdfuris" -> return_all_rdf_uris (parse_rdf_class req) outchan
-    | "/ls" -> return_ls (parse_ls_uri req) (parse_output_format req) outchan
+    | "/ls" ->
+       return_ls (parse_ls_uri req) (parse_output_format "ls" req) outchan
     | "/getempty" ->
         Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
     | invalid_request ->
@@ -279,13 +296,16 @@ let callback (req: Http_types.request) outchan =
     (* Main *)
 
 let main () =
+  Helm_registry.load_from configuration_file;
+  Http_getter_env.reload ();
   print_string (Http_getter_env.env_to_string ());
   flush stdout;
   at_exit Http_getter.close_maps;
   Sys.catch_break true;
   try
-    Http_daemon.start'
-      ~timeout:(Some 600) ~port:Http_getter_env.port ~mode:`Thread callback
+    Http_daemon.start' ~mode:`Thread
+      ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
+      callback
   with Sys.Break -> ()  (* 'close_maps' already registered with 'at_exit' *)
 
 let _ = main ()