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