helm/http_getter/http_getter_env.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 open Printf
  30 open Pxp_document
  31 open Pxp_types
  32 open Pxp_yacc
  33
  34 open Http_getter_types
  35
  36 let version = Http_getter_const.version
  37
  38 type setting_src =
  39   | Environment (* read setting from environment variables *)
  40   | Conffile    (* read setting from configuration file *)
  41   | Both        (* read setting from both; environment override config file *)
  42
  43 let conf_file_tree = ref None
  44
  45 let (conf_file, conf_dir) =
  46   try
  47     let conf_dir =
  48       Pcre.replace ~pat:"/$" (Sys.getenv "HELM_CONFIGURATION_DIR")
  49     in
  50     (conf_dir ^ "/" ^ Http_getter_const.conffile, conf_dir)
  51   with Not_found -> failwith "HELM_CONFIGURATION_DIR undefined"
  52
  53 let safe_getenv ?(from = Both) var =
  54   (let rec read_from_file () =
  55     (match !conf_file_tree with
  56     | None ->
  57         conf_file_tree :=
  58           Some
  59             (parse_wfcontent_entity
  60               default_config (from_file conf_file) default_spec);
  61         read_from_file ()
  62     | Some t ->
  63         (try
  64           Some (find_element (String.lowercase var) t)#data
  65         with Not_found -> None))
  66   in
  67   let read_from_env () = try Some (Sys.getenv var) with Not_found -> None in
  68   let return_value name = function
  69     | Some v -> v
  70     | None -> failwith ("Setting " ^ name ^ " is not defined")
  71   in
  72   (match from with
  73   | Environment -> return_value var (read_from_env ())
  74   | Conffile -> return_value var (read_from_file ())
  75   | Both ->
  76       (match read_from_env () with
  77       | None -> return_value var (read_from_file ())
  78       | v -> return_value var v)))
  79
  80 let servers_file = safe_getenv "HTTP_GETTER_SERVERS_FILE"
  81
  82 let load_servers () =
  83   let pos = ref (-1) in
  84   List.rev (Http_getter_misc.fold_file
  85     (fun line servers ->
  86       if Http_getter_misc.is_blank_line line then
  87         servers
  88       else
  89         (incr pos; (!pos, line) :: servers))
  90     []
  91     servers_file)
  92
  93 let _servers = ref (load_servers ())
  94 let servers () = !_servers
  95
  96 let save_servers () =
  97   let oc = open_out servers_file in
  98   List.iter (fun (_,server) -> output_string oc (server ^ "\n")) (servers ());
  99   close_out oc
 100 let reload_servers () = _servers := load_servers ()
 101
 102 let cic_dbm = safe_getenv "HTTP_GETTER_CIC_DBM"
 103 let nuprl_dbm = safe_getenv "HTTP_GETTER_NUPRL_DBM"
 104 let rdf_dbm = safe_getenv "HTTP_GETTER_RDF_DBM"
 105 let xsl_dbm = safe_getenv "HTTP_GETTER_XSL_DBM"
 106 let xml_index = safe_getenv "HTTP_GETTER_XML_INDEXNAME"
 107 let rdf_index = safe_getenv "HTTP_GETTER_RDF_INDEXNAME"
 108 let xsl_index = safe_getenv "HTTP_GETTER_XSL_INDEXNAME"
 109 let cic_dir = safe_getenv "HTTP_GETTER_CIC_DIR"
 110 let nuprl_dir = safe_getenv "HTTP_GETTER_NUPRL_DIR"
 111 let rdf_dir = safe_getenv "HTTP_GETTER_RDF_DIR"
 112 let dtd_dir = safe_getenv "HTTP_GETTER_DTD_DIR"
 113
 114 let port =
 115   let port = safe_getenv "HTTP_GETTER_PORT" in
 116   try
 117     int_of_string port
 118   with Failure "int_of_string" ->
 119     failwith ("Invalid port value: " ^ port)
 120 let host =
 121   let buf = Buffer.create 20 in
 122   Shell.call ~stdout:(Shell.to_buffer buf) [Shell.cmd "hostname" ["-f"]];
 123   Pcre.replace ~pat:"\n+$" (Buffer.contents buf)
 124 let my_own_url =
 125   sprintf
 126     "http://%s%s" (* without trailing '/' *)
 127     host
 128     (if port = 80 then "" else (sprintf ":%d" port))
 129 let dtd_base_url = safe_getenv "HTTP_GETTER_DTD_BASE_URL"
 130
 131 let cache_mode =
 132   match String.lowercase (safe_getenv "HTTP_GETTER_CACHE_MODE") with
 133   | "normal" -> Enc_normal
 134   | "gz" -> Enc_gzipped
 135   | mode -> failwith ("Invalid cache mode: " ^ mode)
 136
 137 let reload () = reload_servers ()
 138
 139 let env_to_string () =
 140   sprintf
 141 "HTTP Getter %s (the OCaml one!)
 142
 143 cic_dbm:\t%s
 144 nuprl_dbm:\t%s
 145 rdf_dbm:\t%s
 146 xsl_dbm:\t%s
 147 xml_index:\t%s
 148 rdf_index:\t%s
 149 xsl_index:\t%s
 150 cic_dir:\t%s
 151 nuprl_dir:\t%s
 152 rdf_dir:\t%s
 153 dtd_dir:\t%s
 154 servers_file:\t%s
 155 host:\t\t%s
 156 port:\t\t%d
 157 my_own_url:\t%s
 158 dtd_base_url:\t%s
 159 cache_mode:\t%s
 160 conf_file:\t%s
 161 conf_dir:\t%s
 162 servers:
 163 \t%s
 164 "
 165     version cic_dbm nuprl_dbm rdf_dbm xsl_dbm xml_index rdf_index xsl_index
 166     cic_dir nuprl_dir rdf_dir dtd_dir servers_file host port my_own_url
 167     dtd_base_url
 168     (match cache_mode with Enc_normal -> "Normal" | Enc_gzipped -> "GZipped")
 169     conf_file conf_dir
 170     (String.concat "\n\t" (* (position * server) list *)
 171       (List.map (fun (pos, server) -> sprintf "%3d: %s" pos server)
 172         (servers ())))
 173
 174 let add_server ?position url =
 175   (match position with
 176   | None ->
 177       _servers := !_servers @ [-1, url];
 178   | Some p when p > 0 ->
 179       let rec add_after pos = function
 180         | [] -> [-1, url]
 181         | hd :: tl when p = 1 -> hd :: (-1, url) :: tl
 182         | hd :: tl (* when p > 1 *) -> hd :: (add_after (pos - 1) tl)
 183       in
 184       _servers := add_after p !_servers
 185   | Some _ -> assert false);
 186   save_servers ();
 187   reload_servers ()
 188
 189 let remove_server position =
 190   _servers := List.remove_assoc position !_servers;
 191   save_servers ();
 192   reload_servers ()
 193