- better handling of temp files wrt to failures. When a temp file has

  been created and an exception is raised, the exception will be
  catched, the tempfile deleted and the exception raised again

diff --git a/helm/ocaml/getter/http_getter_cache.ml b/helm/ocaml/getter/http_getter_cache.ml
index a3f91220eea13957d40b377ed0dead0f9925e13f..24056441340fb8845202091d1113d3f8481ed19d 100644 (file)
--- a/helm/ocaml/getter/http_getter_cache.ml
+++ b/helm/ocaml/getter/http_getter_cache.ml
@@ -46,13 +46,23 @@ class threadSafe =
     method virtual doReader : 'a. 'a lazy_t -> 'a
     method virtual doWriter : 'a. 'a lazy_t -> 'a
   end
-;;
-let threadSafe = new threadSafe ;;
+
+let threadSafe = new threadSafe
+
+let finally cleanup f =
+  try
+    let res = Lazy.force f in
+    cleanup ();
+    res
+  with e ->
+    cleanup ();
+    raise (Http_getter_types.Cache_failure (Printexc.to_string e))
 
 let resource_type_of_url = function
   | url when Pcre.pmatch ~pat:"\\.xml\\.gz$" url -> Enc_gzipped
   | url when Pcre.pmatch ~pat:"\\.xml$" url -> Enc_normal
   | url -> raise (Invalid_URL url)
+
 let extension_of_resource_type = function
   | Enc_normal -> "xml"
   | Enc_gzipped -> "xml.gz"
@@ -74,7 +84,8 @@ let respond_xml ?(enc = Enc_normal) ?(patch = true) ~url ~uri outchan =
         sprintf "%s%s.%s" (Lazy.force Http_getter_env.cic_dir) baseuri extension
     | Nuprl_uri baseuri ->
           (* assumption: baseuri starts with "/" *)
-        sprintf "%s%s.%s" (Lazy.force Http_getter_env.nuprl_dir) baseuri extension
+        sprintf "%s%s.%s" (Lazy.force Http_getter_env.nuprl_dir) baseuri
+          extension
     | Rdf_uri (prefix, ((Cic baseuri) as qbaseuri))
     | Rdf_uri (prefix, ((Theory baseuri) as qbaseuri)) ->
         let escaped_prefix =
@@ -110,24 +121,30 @@ let respond_xml ?(enc = Enc_normal) ?(patch = true) ~url ~uri outchan =
             None
         | Enc_normal, Enc_gzipped ->  (* resource normal, cache gzipped *)
             let tmp = tempfile () in
-            wget ~output:tmp url;
-            gzip ~output:(basename ^ ".gz") ~keep:true tmp; (* fill cache *)
-            if enc = Enc_normal then  (* user wants normal: don't delete it! *)
-              Some (tmp, enc)
-            else begin
-              Sys.remove tmp;
-              None
-            end
+            let (res, cleanup) =
+              if enc = Enc_normal then (* user wants normal: don't delete it! *)
+                (Some (tmp, enc), (fun () -> ()))
+              else
+                (None, (fun () -> Sys.remove tmp))
+            in
+            finally cleanup (lazy (
+              wget ~output:tmp url;
+              gzip ~output:(basename ^ ".gz") ~keep:true tmp; (* fill cache *)
+              res
+            ));
         | Enc_gzipped, Enc_normal ->  (* resource gzipped, cache normal *)
             let tmp = tempfile () in
-            wget ~output:tmp url;
-            gunzip ~output:basename ~keep:true tmp; (* fill cache *)
-            if enc = Enc_gzipped then (* user wants gzipped: don't delete it! *)
-              Some (tmp, enc)
-            else begin
-              Sys.remove tmp;
-              None
-            end
+            let (res, cleanup) =
+              if enc = Enc_gzipped then (* user wants .gz: don't delete it! *)
+                (Some (tmp, enc), (fun () -> ()))
+              else
+                (None, (fun () -> Sys.remove tmp))
+            in
+            finally cleanup (lazy (
+              wget ~output:tmp url;
+              gunzip ~output:basename ~keep:true tmp; (* fill cache *)
+              res
+            ));
       end else begin
         debug_print "Cache HIT :-)";
         None
@@ -154,31 +171,33 @@ let respond_xml ?(enc = Enc_normal) ?(patch = true) ~url ~uri outchan =
         | None -> (* no short circuit possible, use cache *)
           debug_print "No short circuit available, use cache";
           let tmp = tempfile () in
-          (match enc with
-          | Enc_normal ->
-            (* required format is normal, cached version is gzipped *)
-            gunzip  (* gunzip to tmp *)
-              ~output:tmp ~keep:true (basename ^ ".gz");
-            return_file ~fname:tmp ~contype ~patch_fun outchan;
-          | Enc_gzipped ->
-            (* required format is gzipped, cached version is normal *)
-            gzip ~output:tmp ~keep:true basename;  (* gzip to tmp *)
-            return_file
-              ~fname:tmp ~contype ~contenc:"x-gzip"
-              ~patch_fun ~gunzip:true
-              outchan);
-          Sys.remove tmp
+          finally (fun () -> Sys.remove tmp) (lazy (
+            (match enc with
+            | Enc_normal ->
+              (* required format is normal, cached version is gzipped *)
+              gunzip  (* gunzip to tmp *)
+                ~output:tmp ~keep:true (basename ^ ".gz");
+              return_file ~fname:tmp ~contype ~patch_fun outchan;
+            | Enc_gzipped ->
+              (* required format is gzipped, cached version is normal *)
+              gzip ~output:tmp ~keep:true basename;  (* gzip to tmp *)
+              return_file
+                ~fname:tmp ~contype ~contenc:"x-gzip"
+                ~patch_fun ~gunzip:true
+                outchan)
+          ))
         | Some (fname, Enc_normal) ->  (* short circuit available, use it! *)
             debug_print "Using short circuit (encoding = normal)";
-            return_file ~fname ~contype ~patch_fun outchan;
-            Sys.remove fname
+            finally (fun () -> Sys.remove fname) (lazy (
+              return_file ~fname ~contype ~patch_fun outchan
+            ))
         | Some (fname, Enc_gzipped) -> (* short circuit available, use it! *)
             debug_print "Using short circuit (encoding = gzipped)";
-            return_file
-              ~fname ~contype ~contenc:"x-gzip" ~patch_fun ~gunzip:true outchan;
-            Sys.remove fname)
+            finally (fun () -> Sys.remove fname) (lazy (
+              return_file ~fname ~contype ~contenc:"x-gzip" ~patch_fun
+                ~gunzip:true outchan
+            )))
   ))
-;;
 
   (* TODO enc is not yet supported *)
 let respond_xsl ?(enc = Enc_normal) ?(patch = true) ~url outchan =
@@ -186,10 +205,10 @@ let respond_xsl ?(enc = Enc_normal) ?(patch = true) ~url outchan =
     if patch then Http_getter_common.patch_xsl else (fun x -> x)
   in
   let fname = tempfile () in
-  wget ~output:fname url;
-  return_file ~fname ~contype:"text/xml" ~patch_fun outchan;
-  Sys.remove fname
-;;
+  finally (fun () -> Sys.remove fname) (lazy (
+    wget ~output:fname url;
+    return_file ~fname ~contype:"text/xml" ~patch_fun outchan
+  ))
 
   (* TODO enc is not yet supported *)
 let respond_dtd ?(enc = Enc_normal) ?(patch = true) ~url outchan =
@@ -201,11 +220,10 @@ let respond_dtd ?(enc = Enc_normal) ?(patch = true) ~url outchan =
     return_file ~fname:url ~contype:"text/plain" ~patch_fun outchan
   else
     return_html_error ("Can't find DTD: " ^ url) outchan
-;;
 
 let clean () =
  let module E = Http_getter_env in
   List.iter
    (function dir -> ignore (Unix.system ("rm -rf " ^ dir ^ "/*")))
    [ Lazy.force E.cic_dir; Lazy.force E.nuprl_dir; Lazy.force E.rdf_dir ]
-;;
+

diff --git a/helm/ocaml/getter/http_getter_cache.mli b/helm/ocaml/getter/http_getter_cache.mli
index 11211288aa8faaf5375ee2499a032541f0465bda..a026e72c09d278478129b0d7ff52d8d09fbf526e 100644 (file)
--- a/helm/ocaml/getter/http_getter_cache.mli
+++ b/helm/ocaml/getter/http_getter_cache.mli
@@ -28,6 +28,8 @@
 
 open Http_getter_types;;
 
+(** all these methods could raise Http_getter_types.Cache_failure *)
+
 val respond_xml:
   ?enc:encoding -> ?patch:bool -> url:string -> uri:string -> out_channel ->
     unit

diff --git a/helm/ocaml/getter/http_getter_common.ml b/helm/ocaml/getter/http_getter_common.ml
index 6ecc75f8155edcc952b4ff7725423ab0cf1bb833..1ee74c103b1e1948e309becc04d027f45d3a9347 100644 (file)
--- a/helm/ocaml/getter/http_getter_common.ml
+++ b/helm/ocaml/getter/http_getter_common.ml
@@ -118,17 +118,21 @@ let return_file
     let (tmp1, tmp2) =
       (Http_getter_misc.tempfile (), Http_getter_misc.tempfile ())
     in
-    Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname;  (* gunzip to tmp1 *)
-    let new_file = open_out tmp2 in
-    Http_getter_misc.iter_file  (* tmp2 = patch(tmp1) *)
-      (fun line -> output_string new_file (patch_fun line ^ "\n"))
-      tmp1;
-    close_out new_file;
-    Http_getter_misc.gzip ~output:tmp1 tmp2;  (* tmp1 = gzip(tmp2); rm tmp2 *)
-    Http_getter_misc.iter_file  (* send tmp1 to client as is*)
-      (fun line -> output_string outchan (line ^ "\n"))
-      tmp1;
-    Sys.remove tmp1       (* rm tmp1 *)
+    try
+      Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname;(* gunzip to tmp1 *)
+      let new_file = open_out tmp2 in
+      Http_getter_misc.iter_file  (* tmp2 = patch(tmp1) *)
+        (fun line -> output_string new_file (patch_fun line ^ "\n"))
+        tmp1;
+      close_out new_file;
+      Http_getter_misc.gzip ~output:tmp1 tmp2;  (* tmp1 = gzip(tmp2); rm tmp2 *)
+      Http_getter_misc.iter_file  (* send tmp1 to client as is*)
+        (fun line -> output_string outchan (line ^ "\n"))
+        tmp1;
+      Sys.remove tmp1       (* rm tmp1 *)
+    with e ->
+      Sys.remove tmp1;
+      raise e
   end else  (* no need to gunzip, apply patch_fun directly to file *)
     Http_getter_misc.iter_file
       (fun line -> output_string outchan (patch_fun line ^ "\n"))

diff --git a/helm/ocaml/getter/http_getter_types.ml b/helm/ocaml/getter/http_getter_types.ml
index ee13c6ec6944cb8c67bb6a10fe06f9be5bb09ac9..1d8f7fcb755e09dca3e011ba25848af6e01a9e43 100644 (file)
--- a/helm/ocaml/getter/http_getter_types.ml
+++ b/helm/ocaml/getter/http_getter_types.ml
@@ -32,6 +32,7 @@ exception Invalid_URI of string
 exception Invalid_URL of string
 exception Invalid_RDF_class of string
 exception Internal_error of string
+exception Cache_failure of string
 
 type encoding = Enc_normal | Enc_gzipped
 type answer_format = Fmt_text | Fmt_xml