helm/http_getter/http_getter_cache.ml

   1 (*
   2  *  Copyright (C) 2000, HELM Team.
   3  *
   4  *  This file is part of HELM, an Hypertextual, Electronic
   5  *  Library of Mathematics, developed at the Computer Science
   6  *  Department, University of Bologna, Italy.
   7  *
   8  *  HELM is free software; you can redistribute it and/or
   9  *  modify it under the terms of the GNU General Public License
  10  *  as published by the Free Software Foundation; either version 2
  11  *  of the License, or (at your option) any later version.
  12  *
  13  *  HELM is distributed in the hope that it will be useful,
  14  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  *  GNU General Public License for more details.
  17  *
  18  *  You should have received a copy of the GNU General Public License
  19  *  along with HELM; if not, write to the Free Software
  20  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  *  MA  02111-1307, USA.
  22  *
  23  *  For details, see the HELM World-Wide-Web page,
  24  *  http://cs.unibo.it/helm/.
  25  *)
  26
  27 open Http_getter_common;;
  28 open Http_getter_types;;
  29 open Printf;;
  30
  31 let resource_type_of_url = function
  32   | url when Pcre.pmatch ~pat:"\\.xml\\.gz$" url -> Enc_gzipped
  33   | url when Pcre.pmatch ~pat:"\\.xml$" url -> Enc_normal
  34   | url -> raise (Http_getter_invalid_URL url)
  35 let extension_of_resource_type = function
  36   | Enc_normal -> "xml"
  37   | Enc_gzipped -> "xml.gz"
  38
  39   (* basename = resource name without trailing ".gz", if any *)
  40 let is_in_cache basename =
  41   Sys.file_exists
  42     (match Http_getter_env.cache_mode with
  43     | Enc_normal -> basename
  44     | Enc_gzipped -> basename ^ ".gz")
  45
  46 let respond_xml ?(enc = Enc_normal) ?(patch_dtd = true) ~url ~uri outchan =
  47   let resource_type = resource_type_of_url url in
  48   let extension = extension_of_resource_type resource_type in
  49   let downloadname =
  50     match http_getter_uri_of_string uri with
  51     | Xml_uri (Cic baseuri) | Xml_uri (Theory baseuri) ->
  52           (* assumption: baseuri starts with "/" *)
  53         sprintf "%s%s.%s" Http_getter_env.xml_dir baseuri extension
  54     | Rdf_uri (prefix, ((Cic baseuri) as qbaseuri))
  55     | Rdf_uri (prefix, ((Theory baseuri) as qbaseuri)) ->
  56         let escaped_prefix =
  57           (Pcre.replace ~pat:"/" ~templ:"_"
  58             (Pcre.replace ~pat:"_" ~templ:"__"
  59               (prefix ^
  60               (match qbaseuri with
  61               | Cic _ -> "//cic:"
  62               | Theory _ -> "//theory:"))))
  63         in
  64         sprintf "%s/%s%s.%s"
  65           Http_getter_env.rdf_dir escaped_prefix baseuri extension
  66   in
  67   let patch_fun =
  68     if patch_dtd then Http_getter_common.patch_xml else (fun x -> x)
  69   in
  70   let basename = Pcre.replace ~pat:"\\.gz$" downloadname in
  71   if not (is_in_cache basename) then begin (* download and fill cache *)
  72     wget ~output:downloadname url;
  73     match (resource_type, Http_getter_env.cache_mode) with
  74     | Enc_normal, Enc_normal ->
  75         (if enc = Enc_gzipped then gzip ~keep:true downloadname)
  76     | Enc_gzipped, Enc_gzipped ->
  77         (if enc = Enc_normal then gunzip ~keep:true downloadname)
  78     | Enc_normal, Enc_gzipped -> gzip ~keep:(enc = Enc_normal) downloadname
  79     | Enc_gzipped, Enc_normal -> gunzip ~keep:(enc = Enc_gzipped) downloadname
  80   end else begin  (* resource already in cache *)
  81     match (enc, Http_getter_env.cache_mode) with
  82     | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped -> ()
  83     | Enc_normal, Enc_gzipped -> gunzip ~keep:true (basename ^ ".gz")
  84     | Enc_gzipped, Enc_normal -> gzip ~keep:true basename
  85   end;  (* now resource is in cache *)
  86   (* invariant: file to be sent back to client is available on disk in the
  87   format the client likes *)
  88   (match enc with  (* send file to client *)
  89   | Enc_normal ->
  90       return_file ~fname:basename ~contype:"text/xml" ~patch_fun outchan
  91   | Enc_gzipped ->
  92       return_file
  93         ~fname:(basename ^ ".gz") ~contype:"text/xml"  ~contenc:"x-gzip"
  94         ~patch_fun outchan);
  95   match (enc, Http_getter_env.cache_mode) with  (* remove temp files *)
  96   | Enc_normal, Enc_normal | Enc_gzipped, Enc_gzipped -> ()
  97   | Enc_normal, Enc_gzipped -> Sys.remove basename
  98   | Enc_gzipped, Enc_normal -> Sys.remove (basename ^ ".gz")
  99
 100   (* TODO enc is not yet supported *)
 101 let respond_xsl ?(enc = Enc_normal) ?(patch_dtd = true) ~url outchan =
 102   let patch_fun =
 103     if patch_dtd then Http_getter_common.patch_xsl else (fun x -> x)
 104   in
 105   let fname = tempfile () in
 106   wget ~output:fname url;
 107   return_file ~fname ~contype:"text/xml" ~patch_fun outchan;
 108   Sys.remove fname
 109
 110   (* TODO patch_dtd and format are fooish, implement them! *)
 111 let respond_dtd ?(enc = Enc_normal) ?(patch_dtd = true) ~url outchan =
 112     if Sys.file_exists url then
 113       return_file
 114         ~fname:url ~contype:"text/xml" ~patch_fun:Http_getter_common.patch_dtd
 115         outchan
 116     else
 117       return_html_error ("Can't find DTD: " ^ url) outchan
 118