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 -> `Gzipped
  63   | url when Pcre.pmatch ~pat:"\\.xml$" url -> `Normal
  64   | url -> raise (Invalid_URL url)
  65
  66 let extension_of_resource_type = function
  67   | `Normal -> "xml"
  68   | `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     | `Normal -> basename
  75     | `Gzipped -> basename ^ ".gz")
  76
  77 let respond_xml
  78   ?(via_http = true) ?(enc = `Normal) ?(patch = true) ~url ~uri outchan
  79   =
  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     if patch then Http_getter_common.patch_xml ~via_http () else (fun x -> x)
 106   in
 107   let basename = Pcre.replace ~pat:"\\.gz$" downloadname in
 108   let contype = "text/xml" in
 109     (* Fill cache if needed and return a short circuit file.
 110       Short circuit is needed in situations like:
 111         resource type = normal, cache type = gzipped, required encoding = normal
 112       we would like to avoid normal -> gzipped -> normal conversions. To avoid
 113       this tmp_short_circuit is used to remember the name of the intermediate
 114       file name *)
 115   let fill_cache () =
 116     threadSafe#doWriter (lazy(
 117       if not (is_in_cache basename) then begin  (* cache MISS *)
 118         debug_print "Cache MISS :-(";
 119         mkdir ~parents:true (Filename.dirname downloadname);
 120         match (resource_type, Lazy.force Http_getter_env.cache_mode) with
 121         | `Normal, `Normal | `Gzipped, `Gzipped ->
 122             wget ~output:downloadname url;
 123             None
 124         | `Normal, `Gzipped ->  (* resource normal, cache gzipped *)
 125             let tmp = tempfile () in
 126             let (res, cleanup) =
 127               if enc = `Normal then (* user wants normal: don't delete it! *)
 128                 (Some (tmp, enc), (fun () -> ()))
 129               else
 130                 (None, (fun () -> Sys.remove tmp))
 131             in
 132             finally cleanup (lazy (
 133               wget ~output:tmp url;
 134               gzip ~output:(basename ^ ".gz") ~keep:true tmp; (* fill cache *)
 135               res
 136             ));
 137         | `Gzipped, `Normal ->  (* resource gzipped, cache normal *)
 138             let tmp = tempfile () in
 139             let (res, cleanup) =
 140               if enc = `Gzipped then (* user wants .gz: 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               gunzip ~output:basename ~keep:true tmp; (* fill cache *)
 148               res
 149             ));
 150       end else begin
 151         debug_print "Cache HIT :-)";
 152         None
 153       end
 154     )) in
 155   let tmp_short_circuit = fill_cache () in
 156   threadSafe#doReader (lazy(
 157     assert (is_in_cache basename);
 158     match (enc, Lazy.force Http_getter_env.cache_mode) with
 159     | `Normal, `Normal | `Gzipped, `Gzipped ->
 160         (* resource in cache is already in the required format *)
 161         (match enc with
 162         | `Normal ->
 163             debug_print "No format mangling required (encoding = normal)";
 164             return_file ~via_http ~fname:basename ~contype ~patch_fun outchan
 165         | `Gzipped ->
 166             debug_print "No format mangling required (encoding = gzipped)";
 167             return_file
 168               ~via_http ~fname:(basename ^ ".gz") ~contype ~contenc:"x-gzip"
 169               ~patch_fun ~gunzip:true
 170               outchan)
 171     | `Normal, `Gzipped | `Gzipped, `Normal ->
 172         (match tmp_short_circuit with
 173         | None -> (* no short circuit possible, use cache *)
 174           debug_print "No short circuit available, use cache";
 175           let tmp = tempfile () in
 176           finally (fun () -> Sys.remove tmp) (lazy (
 177             (match enc with
 178             | `Normal ->
 179               (* required format is normal, cached version is gzipped *)
 180               gunzip  (* gunzip to tmp *)
 181                 ~output:tmp ~keep:true (basename ^ ".gz");
 182               return_file ~via_http ~fname:tmp ~contype ~patch_fun outchan;
 183             | `Gzipped ->
 184               (* required format is gzipped, cached version is normal *)
 185               gzip ~output:tmp ~keep:true basename;  (* gzip to tmp *)
 186               return_file
 187                 ~via_http ~fname:tmp ~contype ~contenc:"x-gzip"
 188                 ~patch_fun ~gunzip:true
 189                 outchan)
 190           ))
 191         | Some (fname, `Normal) ->  (* short circuit available, use it! *)
 192             debug_print "Using short circuit (encoding = normal)";
 193             finally (fun () -> Sys.remove fname) (lazy (
 194               return_file ~via_http ~fname ~contype ~patch_fun outchan
 195             ))
 196         | Some (fname, `Gzipped) -> (* short circuit available, use it! *)
 197             debug_print "Using short circuit (encoding = gzipped)";
 198             finally (fun () -> Sys.remove fname) (lazy (
 199               return_file ~via_http ~fname ~contype ~contenc:"x-gzip" ~patch_fun
 200                 ~gunzip:true outchan
 201             )))
 202   ))
 203
 204   (* TODO enc is not yet supported *)
 205 let respond_xsl
 206   ?(via_http = true) ?(enc = `Normal) ?(patch = true) ~url outchan
 207   =
 208   let patch_fun =
 209     if patch then Http_getter_common.patch_xsl ~via_http () else (fun x -> x)
 210   in
 211   let fname = tempfile () in
 212   finally (fun () -> Sys.remove fname) (lazy (
 213     wget ~output:fname url;
 214     return_file ~via_http ~fname ~contype:"text/xml" ~patch_fun outchan
 215   ))
 216
 217   (* TODO enc is not yet supported *)
 218 let respond_dtd
 219   ?(via_http = true) ?(enc = `Normal) ?(patch = true) ~url outchan
 220   =
 221   let patch_fun =
 222     if patch then Http_getter_common.patch_dtd ~via_http () else (fun x -> x)
 223   in
 224   if Sys.file_exists url then
 225     (* TODO check this: old getter here used text/xml *)
 226     return_file ~via_http ~fname:url ~contype:"text/plain" ~patch_fun outchan
 227   else
 228     raise (Dtd_not_found url)
 229
 230 let clean () =
 231  let module E = Http_getter_env in
 232   List.iter
 233    (function dir -> ignore (Unix.system ("rm -rf " ^ dir ^ "/*")))
 234    [ Lazy.force E.cic_dir; Lazy.force E.nuprl_dir; Lazy.force E.rdf_dir ]
 235