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