prima implementazione di demodulate, superposition_left e superposition_right

[helm.git] / helm / http_getter / main.ml
diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml

index 1763836158eb1afd6c851bc0bea1789f1743361b..5f7e8cd93582e94a90dd9bf27619266031451ab8 100644 (file)
--- a/helm/http_getter/main.ml
+++ b/helm/http_getter/main.ml
@@ -90,13 +90,16 @@ let parse_rdf_class (req: Http_types.request) =
    | "backward" -> `Backward
    | c -> raise (Bad_request ("Invalid RDF class: " ^ c))
  
+let xml_escape = Netencoding.Html.encode ~in_enc:`Enc_utf8 ()
+
  let html_tag ?exn () =
    let xml_decl = "<?xml version=\"1.0\"?>\n" in
    match exn with
-  | Some (exn, value) ->
+  | Some (exn, arg) ->
+      let (exn, arg) = (xml_escape exn, xml_escape arg) in
        sprintf
          "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\"\nhelm:exception_arg=\"%s\">\n"
-        xml_decl xhtml_ns helm_ns exn value
+        xml_decl xhtml_ns helm_ns exn arg
    | None ->
        sprintf "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\">\n"
          xml_decl xhtml_ns helm_ns
@@ -344,25 +347,33 @@ let callback (req: Http_types.request) outchan =
            log_failure msg;
            return_html_error ("uncaught_exception", msg) msg outchan)
  
-    (* Main *)
+let batch_update = ref false      
  
+let args = [
+    ("-update", 
+        Arg.Unit (fun () -> batch_update := true),
+        "\tupdate maps and exit");
+]
+      
+    (* Main *)
  let main () =
+  Arg.parse args (fun _->()) "http_getter honors the following options:\n";
    Helm_registry.load_from configuration_file;
    Http_getter.init ();
    print_string (Http_getter_env.env_to_string ());
    flush stdout;
-  let batch_update =
-    try Sys.argv.(1) = "-update" with Invalid_argument _ -> false
-  in
-  if batch_update then  (* batch mode: performs update and exit *)
+  if !batch_update then  (* batch mode: performs update and exit *)
      Http_getter.update ~logger:Http_getter.stdout_logger ()
    else begin            (* daemon mode: start http daemon *)
      at_exit Http_getter.close_maps;
      Sys.catch_break true;
+    let d_spec = Http_daemon.daemon_spec
+       ~mode:`Thread ~timeout:(Some 600) 
+       ~port:(Lazy.force Http_getter_env.port)
+       ~callback:callback ()
+    in
      try
-      Http_daemon.start' ~mode:`Thread
-        ~timeout:(Some 600) ~port:(Lazy.force Http_getter_env.port)
-        callback
+      Http_daemon.main d_spec
      with Sys.Break -> ()  (* 'close_maps' already registered with 'at_exit' *)
    end