helm/ocaml/getter/http_getter_cache.ml

   1 (*
   2  * Copyright (C) 2003-2004:
   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 (* TODO cache expires control!!! *)
  30 (* TODO uwobo loop:
  31     if two large proof (already in cache) are requested at the same time by two
  32     clients, uwobo (java implementation, not yet tested with the OCaml one)
  33     starts looping sending output to one of the client *)
  34
  35 open Http_getter_common;;
  36 open Http_getter_debugger;;
  37 open Http_getter_misc;;
  38 open Http_getter_types;;
  39 open Printf;;
  40
  41   (* expose ThreadSafe.threadSafe methods *)
  42 class threadSafe =
  43   object
  44     inherit ThreadSafe.threadSafe
  45     method virtual doCritical : 'a. 'a lazy_t -> 'a
  46     method virtual doReader : 'a. 'a lazy_t -> 'a
  47     method virtual doWriter : 'a. 'a lazy_t -> 'a
  48   end
  49
  50 let threadSafe = new threadSafe
  51
  52 let finally cleanup f =
  53   try
  54     let res = Lazy.force f in
  55     cleanup ();
  56     res
  57   with e ->
  58     cleanup ();
  59     raise (Http_getter_types.Cache_failure (Printexc.to_string e))
  60
  61 let resource_type_of_url = function
  62   | url when Pcre.pmatch ~pat:"\\.xml\\.gz$" url -> Enc_gzipped
  63   | url when Pcre.pmatch ~pat:"\\.xml$" url -> Enc_normal
  64   | url -> raise (Invalid_URL url)
  65
  66 let extension_of_resource_type = function
  67   | Enc_normal -> "xml"
  68   | Enc_gzipped -> "xml.gz"
  69
  70   (* basename = resource name without trailing ".gz", if any *)
  71 let is_in_cache basename =
  72   Sys.file_exists
  73     (match Lazy.force Http_getter_env.cache_mode with
  74     | Enc_normal -> basename
  75     | Enc_gzipped -> basename ^ ".gz")
  76
  77 let respond_xml ?(enc = Enc_normal) ?(patch = true) ~url ~uri outchan =
  78   let resource_type = resource_type_of_url url in
  79   let extension = extension_of_resource_type resource_type in
  80   let downloadname =
  81     match uri_of_string uri with  (* parse uri *)
  82     | Cic_uri (Cic baseuri) | Cic_uri (Theory baseuri) ->
  83           (* assumption: baseuri starts with "/" *)
  84         sprintf "%s%s.%s" (Lazy.force Http_getter_env.cic_dir) baseuri extension
  85     | Nuprl_uri baseuri ->
  86           (* assumption: baseuri starts with "/" *)
  87         sprintf "%s%s.%s" (Lazy.force Http_getter_env.nuprl_dir) baseuri
  88           extension
  89     | Rdf_uri (prefix, ((Cic baseuri) as qbaseuri))
  90     | Rdf_uri (prefix, ((Theory baseuri) as qbaseuri)) ->
  91         let escaped_prefix =
  92           (Pcre.replace ~pat:"/" ~templ:"_"
  93             (Pcre.replace ~pat:"_" ~templ:"__"
  94               (prefix ^
  95               (match qbaseuri with
  96               | Cic _ -> "//cic:"
  97               | Theory _ -> "//theory:"))))
  98         in
  99         sprintf "%s/%s%s.%s"
 100           (Lazy.force Http_getter_env.rdf_dir) escaped_prefix baseuri extension
 101   in
 102   let patch_fun =
 103     if patch then Http_getter_common.patch_xml else (fun x -> x)
 104   in
 105   let basename = Pcre.replace ~pat:"\\.gz$" downloadname in
 106   let contype = "text/xml" in
 107     (* Fill cache if needed and return a short circuit file.
 108       Short circuit is needed in situations like:
 109         resource type = normal, cache type = gzipped, required encoding = normal
 110       we would like to avoid normal -> gzipped -> normal conversions. To avoid
 111       this tmp_short_circuit is used to remember the name of the intermediate
 112       file name *)
 113   let fill_cache () =
 114     threadSafe#doWriter (lazy(
 115       if not (is_in_cache basename) then begin  (* cache MISS *)
 116         debug_print "Cache MISS :-(";
 117         mkdir ~parents:true (Filename.dirname downloadname);
 118         match (resource_type, Lazy.force Http_getter_env.cache_mode) with
 119         | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped ->
 120             wget ~output:downloadname url;
 121             None
 122         | Enc_normal, Enc_gzipped ->  (* resource normal, cache gzipped *)
 123             let tmp = tempfile () in
 124             let (res, cleanup) =
 125               if enc = Enc_normal then (* user wants normal: don't delete it! *)
 126                 (Some (tmp, enc), (fun () -> ()))
 127               else
 128                 (None, (fun () -> Sys.remove tmp))
 129             in
 130             finally cleanup (lazy (
 131               wget ~output:tmp url;
 132               gzip ~output:(basename ^ ".gz") ~keep:true tmp; (* fill cache *)
 133               res
 134             ));
 135         | Enc_gzipped, Enc_normal ->  (* resource gzipped, cache normal *)
 136             let tmp = tempfile () in
 137             let (res, cleanup) =
 138               if enc = Enc_gzipped then (* user wants .gz: don't delete it! *)
 139                 (Some (tmp, enc), (fun () -> ()))
 140               else
 141                 (None, (fun () -> Sys.remove tmp))
 142             in
 143             finally cleanup (lazy (
 144               wget ~output:tmp url;
 145               gunzip ~output:basename ~keep:true tmp; (* fill cache *)
 146               res
 147             ));
 148       end else begin
 149         debug_print "Cache HIT :-)";
 150         None
 151       end
 152     )) in
 153   let tmp_short_circuit = fill_cache () in
 154   threadSafe#doReader (lazy(
 155     assert (is_in_cache basename);
 156     match (enc, Lazy.force Http_getter_env.cache_mode) with
 157     | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped ->
 158         (* resource in cache is already in the required format *)
 159         (match enc with
 160         | Enc_normal ->
 161             debug_print "No format mangling required (encoding = normal)";
 162             return_file ~fname:basename ~contype ~patch_fun outchan
 163         | Enc_gzipped ->
 164             debug_print "No format mangling required (encoding = gzipped)";
 165             return_file
 166               ~fname:(basename ^ ".gz") ~contype ~contenc:"x-gzip"
 167               ~patch_fun ~gunzip:true
 168               outchan)
 169     | Enc_normal, Enc_gzipped | Enc_gzipped, Enc_normal ->
 170         (match tmp_short_circuit with
 171         | None -> (* no short circuit possible, use cache *)
 172           debug_print "No short circuit available, use cache";
 173           let tmp = tempfile () in
 174           finally (fun () -> Sys.remove tmp) (lazy (
 175             (match enc with
 176             | Enc_normal ->
 177               (* required format is normal, cached version is gzipped *)
 178               gunzip  (* gunzip to tmp *)
 179                 ~output:tmp ~keep:true (basename ^ ".gz");
 180               return_file ~fname:tmp ~contype ~patch_fun outchan;
 181             | Enc_gzipped ->
 182               (* required format is gzipped, cached version is normal *)
 183               gzip ~output:tmp ~keep:true basename;  (* gzip to tmp *)
 184               return_file
 185                 ~fname:tmp ~contype ~contenc:"x-gzip"
 186                 ~patch_fun ~gunzip:true
 187                 outchan)
 188           ))
 189         | Some (fname, Enc_normal) ->  (* short circuit available, use it! *)
 190             debug_print "Using short circuit (encoding = normal)";
 191             finally (fun () -> Sys.remove fname) (lazy (
 192               return_file ~fname ~contype ~patch_fun outchan
 193             ))
 194         | Some (fname, Enc_gzipped) -> (* short circuit available, use it! *)
 195             debug_print "Using short circuit (encoding = gzipped)";
 196             finally (fun () -> Sys.remove fname) (lazy (
 197               return_file ~fname ~contype ~contenc:"x-gzip" ~patch_fun
 198                 ~gunzip:true outchan
 199             )))
 200   ))
 201
 202   (* TODO enc is not yet supported *)
 203 let respond_xsl ?(enc = Enc_normal) ?(patch = true) ~url outchan =
 204   let patch_fun =
 205     if patch then Http_getter_common.patch_xsl else (fun x -> x)
 206   in
 207   let fname = tempfile () in
 208   finally (fun () -> Sys.remove fname) (lazy (
 209     wget ~output:fname url;
 210     return_file ~fname ~contype:"text/xml" ~patch_fun outchan
 211   ))
 212
 213   (* TODO enc is not yet supported *)
 214 let respond_dtd ?(enc = Enc_normal) ?(patch = true) ~url outchan =
 215   let patch_fun =
 216     if patch then Http_getter_common.patch_dtd else (fun x -> x)
 217   in
 218   if Sys.file_exists url then
 219     (* TODO check this: old getter here used text/xml *)
 220     return_file ~fname:url ~contype:"text/plain" ~patch_fun outchan
 221   else
 222     return_html_error ("Can't find DTD: " ^ url) outchan
 223
 224 let clean () =
 225  let module E = Http_getter_env in
 226   List.iter
 227    (function dir -> ignore (Unix.system ("rm -rf " ^ dir ^ "/*")))
 228    [ Lazy.force E.cic_dir; Lazy.force E.nuprl_dir; Lazy.force E.rdf_dir ]
 229