helm/http_getter/http_getter_cache.ml

   1 (*
   2  * Copyright (C) 2003:
   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 possible race condition, e.g.:
  31     two clients require the same URI which is available in cache compressed, the
  32     getter need to uncompress it, send back to client, and delete the
  33     uncompressed file. Actually the uncompressed file name is the same, a temp
  34     file isn't used.  *)
  35 (* TODO possible race condition, e.g.:
  36     two clients require the same URI which is not available in cache, cache
  37     filling operation can collide *)
  38 (* TODO uwobo loop:
  39     if two large proof (already in cache) are requested at the same time by two
  40     clients, uwobo (java implementation, not yet tested with the OCaml one)
  41     starts looping sending output to one of the client *)
  42
  43 open Http_getter_common;;
  44 open Http_getter_misc;;
  45 open Http_getter_types;;
  46 open Printf;;
  47
  48 let resource_type_of_url = function
  49   | url when Pcre.pmatch ~pat:"\\.xml\\.gz$" url -> Enc_gzipped
  50   | url when Pcre.pmatch ~pat:"\\.xml$" url -> Enc_normal
  51   | url -> raise (Http_getter_invalid_URL url)
  52 let extension_of_resource_type = function
  53   | Enc_normal -> "xml"
  54   | Enc_gzipped -> "xml.gz"
  55
  56   (* basename = resource name without trailing ".gz", if any *)
  57 let is_in_cache basename =
  58   Sys.file_exists
  59     (match Http_getter_env.cache_mode with
  60     | Enc_normal -> basename
  61     | Enc_gzipped -> basename ^ ".gz")
  62
  63 let respond_xml ?(enc = Enc_normal) ?(patch = true) ~url ~uri outchan =
  64   let resource_type = resource_type_of_url url in
  65   let extension = extension_of_resource_type resource_type in
  66   let downloadname =
  67     match http_getter_uri_of_string uri with  (* parse uri *)
  68     | Cic_uri (Cic baseuri) | Cic_uri (Theory baseuri) ->
  69           (* assumption: baseuri starts with "/" *)
  70         sprintf "%s%s.%s" Http_getter_env.cic_dir baseuri extension
  71     | Nuprl_uri baseuri ->
  72           (* assumption: baseuri starts with "/" *)
  73         sprintf "%s%s.%s" Http_getter_env.nuprl_dir baseuri extension
  74     | Rdf_uri (prefix, ((Cic baseuri) as qbaseuri))
  75     | Rdf_uri (prefix, ((Theory baseuri) as qbaseuri)) ->
  76         let escaped_prefix =
  77           (Pcre.replace ~pat:"/" ~templ:"_"
  78             (Pcre.replace ~pat:"_" ~templ:"__"
  79               (prefix ^
  80               (match qbaseuri with
  81               | Cic _ -> "//cic:"
  82               | Theory _ -> "//theory:"))))
  83         in
  84         sprintf "%s/%s%s.%s"
  85           Http_getter_env.rdf_dir escaped_prefix baseuri extension
  86   in
  87   let patch_fun =
  88     if patch then Http_getter_common.patch_xml else (fun x -> x)
  89   in
  90   let basename = Pcre.replace ~pat:"\\.gz$" downloadname in
  91   if not (is_in_cache basename) then begin (* download and fill cache *)
  92     mkdir ~parents:true (Filename.dirname downloadname);
  93     wget ~output:downloadname url;
  94     match (resource_type, Http_getter_env.cache_mode) with
  95     | Enc_normal, Enc_normal ->
  96         (if enc = Enc_gzipped then gzip ~keep:true downloadname)
  97     | Enc_gzipped, Enc_gzipped ->
  98         (if enc = Enc_normal then gunzip ~keep:true downloadname)
  99     | Enc_normal, Enc_gzipped -> gzip ~keep:(enc = Enc_normal) downloadname
 100     | Enc_gzipped, Enc_normal -> gunzip ~keep:(enc = Enc_gzipped) downloadname
 101   end else begin  (* resource already in cache *)
 102     match (enc, Http_getter_env.cache_mode) with
 103     | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped -> ()
 104     | Enc_normal, Enc_gzipped -> gunzip ~keep:true (basename ^ ".gz")
 105     | Enc_gzipped, Enc_normal -> gzip ~keep:true basename
 106   end;  (* now resource is in cache *)
 107   (* invariant: file to be sent back to client is available on disk in the
 108   format the client likes *)
 109   (match enc with  (* send file to client *)
 110   | Enc_normal ->
 111       return_file ~fname:basename ~contype:"text/xml" ~patch_fun outchan
 112   | Enc_gzipped ->
 113       return_file
 114         ~fname:(basename ^ ".gz") ~contype:"text/xml"  ~contenc:"x-gzip"
 115         ~patch_fun outchan);
 116   match (enc, Http_getter_env.cache_mode) with  (* remove temp files *)
 117   | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped -> ()
 118   | Enc_normal, Enc_gzipped -> Sys.remove basename
 119   | Enc_gzipped, Enc_normal -> Sys.remove (basename ^ ".gz")
 120
 121   (* TODO enc is not yet supported *)
 122 let respond_xsl ?(enc = Enc_normal) ?(patch = true) ~url outchan =
 123   let patch_fun =
 124     if patch then Http_getter_common.patch_xsl else (fun x -> x)
 125   in
 126   let fname = tempfile () in
 127   wget ~output:fname url;
 128   return_file ~fname ~contype:"text/xml" ~patch_fun outchan;
 129   Sys.remove fname
 130
 131   (* TODO enc is not yet supported *)
 132 let respond_dtd ?(enc = Enc_normal) ?(patch = true) ~url outchan =
 133   let patch_fun =
 134     if patch then Http_getter_common.patch_dtd else (fun x -> x)
 135   in
 136   if Sys.file_exists url then
 137     (* TODO check this: old getter here used text/xml *)
 138     return_file ~fname:url ~contype:"text/plain" ~patch_fun outchan
 139   else
 140     return_html_error ("Can't find DTD: " ^ url) outchan
 141