helm/interface/getter.ml

   1 (* Copyright (C) 2000, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 (******************************************************************************)
  27 (*                                                                            *)
  28 (*                               PROJECT HELM                                 *)
  29 (*                                                                            *)
  30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
  31 (*                                 24/01/2000                                 *)
  32 (*                                                                            *)
  33 (******************************************************************************)
  34
  35 exception ErrorGetting of string;;
  36
  37 module OrderedStrings =
  38  struct
  39   type t = string
  40   let compare (s1 : t) (s2 : t) = compare s1 s2
  41  end
  42 ;;
  43
  44 module MapOfStrings = Map.Make(OrderedStrings);;
  45
  46 let read_index url =
  47  let module C = Configuration in
  48   if Sys.command ("helm_wget " ^ C.tmpdir ^ " " ^ url ^ "/\"" ^
  49    C.indexname ^ "\"") <> 0
  50   then
  51    raise (ErrorGetting url) ;
  52   let tmpfilename = C.tmpdir ^ "/" ^ C.indexname in
  53    let fd = open_in tmpfilename in
  54    let uris = ref [] in
  55     try
  56      while true do
  57       uris := (input_line fd) :: !uris
  58      done ;
  59      [] (* only to make the compiler happy *)
  60     with
  61      End_of_file ->
  62       Sys.remove tmpfilename ;
  63       !uris
  64 ;;
  65
  66 (* mk_urls_of_uris list_of_servers_base_urls *)
  67 let rec mk_urls_of_uris =
  68  function
  69     [] -> MapOfStrings.empty
  70   | he::tl ->
  71      let map = mk_urls_of_uris tl in
  72       let uris = read_index he in
  73        let url_of_uri uri =
  74         let url = uri  ^ ".xml" in
  75          let url' = Str.replace_first (Str.regexp "cic:") he url in
  76          let url'' = Str.replace_first (Str.regexp "theory:") he url' in
  77           url''
  78        in
  79         List.fold_right
  80          (fun uri m -> MapOfStrings.add uri (url_of_uri uri) m)
  81          uris map
  82 ;;
  83
  84 exception PerlGetterNotResponding;;
  85
  86 let update () =
  87  let module C = Configuration in
  88   let fd = open_in C.servers_file in
  89   let servers = ref [] in
  90    try
  91     while true do
  92      servers := (input_line fd) :: !servers
  93     done
  94    with
  95     End_of_file ->
  96      let urls_of_uris = mk_urls_of_uris (List.rev !servers) in
  97       (try Sys.remove (C.uris_dbm ^ ".db") with _ -> ()) ;
  98       let dbm =
  99        Dbm.opendbm C.uris_dbm [Dbm.Dbm_wronly ; Dbm.Dbm_create] 0o660
 100       in
 101        MapOfStrings.iter (fun uri url -> Dbm.add dbm uri url) urls_of_uris ;
 102        Dbm.close dbm ;
 103        (* Inform also the Perl-getter *)
 104        if Sys.command ("wget -O /dev/null http://localhost:8081/update") <> 0
 105        then
 106         raise PerlGetterNotResponding ;
 107 ;;
 108
 109 (* url_of_uri : uri -> url *)
 110 let url_of_uri uri =
 111  let dbm = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0o660 in
 112   let url = Dbm.find dbm (UriManager.string_of_uri uri) in
 113    Dbm.close dbm ;
 114    url
 115 ;;
 116
 117 let filedir_of_uri uri =
 118  let fn = UriManager.buri_of_uri uri in
 119   let fn' = Str.replace_first (Str.regexp ".*:") Configuration.dest fn in
 120    fn'
 121 ;;
 122
 123 let name_and_ext_of_uri uri =
 124  let str = UriManager.string_of_uri uri in
 125   Str.replace_first (Str.regexp ".*/") "" str
 126 ;;
 127
 128 (* get_file : uri -> filename *)
 129 let get_file uri =
 130  let dir = filedir_of_uri uri in
 131   let fn = dir ^ "/" ^ name_and_ext_of_uri uri ^ ".xml" in
 132    if not (Sys.file_exists fn) then
 133     begin
 134      let url = url_of_uri uri in
 135       (*CSC: use -q for quiet mode *)
 136       if Sys.command ("helm_wget " ^ dir ^ " \"" ^ url ^"\"") <> 0
 137       then
 138        raise (ErrorGetting url) ;
 139     end ;
 140    fn
 141 ;;
 142
 143 (* get : uri -> filename *)
 144 (* If uri is the URI of an annotation, the annotated object is processed *)
 145 let get uri =
 146  let module U = UriManager in
 147   get_file
 148    (U.uri_of_string
 149     (Str.replace_first (Str.regexp "\.types$") ""
 150      (Str.replace_first (Str.regexp "\.ann$") "" (U.string_of_uri uri))))
 151 ;;
 152
 153 (* get_ann : uri -> filename *)
 154 (* If uri is the URI of an annotation, the annotation file is processed *)
 155 let get_ann = get_file;;
 156
 157 (* get_ann_file_name_and_uri : uri -> filename * annuri *)
 158 (* If given an URI, it returns the name of the corresponding *)
 159 (* annotation file and the annotation uri                    *)
 160 let get_ann_file_name_and_uri uri =
 161  let module U = UriManager in
 162   let uri = U.string_of_uri uri in
 163    let annuri =
 164     U.uri_of_string (
 165      if Str.string_match (Str.regexp ".*\.ann$") uri 0 then
 166       uri
 167      else
 168       uri ^ ".ann"
 169     )
 170    in
 171     let dir = filedir_of_uri annuri in
 172      let fn = dir ^ "/" ^ name_and_ext_of_uri annuri ^ ".xml" in
 173       (fn, annuri)
 174 ;;