components/library/libraryDb.ml

   1 (* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/
  24  *)
  25
  26 (* $Id$ *)
  27
  28 open Printf ;;
  29
  30 let parse_dbd_conf _ =
  31   let metadata = Helm_registry.get_list Helm_registry.string "db.metadata" in
  32   List.map
  33     (fun s ->
  34       match Pcre.split ~pat:"\\s+" s with
  35       | [path;db;user;pwd;dbtype] ->
  36            let dbtype =
  37              if dbtype = "library" then HSql.Library
  38              else if dbtype = "user" then HSql.User
  39              else if dbtype = "legacy" then HSql.Legacy
  40              else raise (HSql.Error "HSql: wrong config file format")
  41            in
  42            let pwd = if pwd = "none" then None else Some pwd in
  43            (* TODO parse port *)
  44            path, None, db, user, pwd, dbtype
  45       | _ -> raise (HSql.Error "HSql: Bad format in config file"))
  46     metadata
  47 ;;
  48
  49 let parse_dbd_conf _ =
  50    HSql.mk_dbspec (parse_dbd_conf ())
  51 ;;
  52
  53 let instance =
  54   let dbd = lazy (
  55     let dbconf = parse_dbd_conf () in
  56     HSql.quick_connect dbconf)
  57   in
  58   fun () -> Lazy.force dbd
  59 ;;
  60
  61 let xpointer_RE = Pcre.regexp "#.*$"
  62 let file_scheme_RE = Pcre.regexp "^file://"
  63
  64 let clean_owner_environment () =
  65   let dbd = instance () in
  66   let obj_tbl = MetadataTypes.obj_tbl () in
  67   let sort_tbl = MetadataTypes.sort_tbl () in
  68   let rel_tbl = MetadataTypes.rel_tbl () in
  69   let name_tbl =  MetadataTypes.name_tbl () in
  70   let count_tbl = MetadataTypes.count_tbl () in
  71   let tbls = [
  72     (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
  73     (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
  74   in
  75   let dbtype =
  76     if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
  77   in
  78   let statements =
  79     (SqlStatements.drop_tables tbls) @
  80     (SqlStatements.drop_indexes tbls dbtype dbd)
  81   in
  82   let owned_uris =
  83     try
  84       MetadataDb.clean ~dbd
  85     with (HSql.Error _) as exn ->
  86       match HSql.errno dbtype dbd with
  87       | HSql.No_such_table -> []
  88       | _ -> raise exn
  89   in
  90   List.iter
  91     (fun uri ->
  92       let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in
  93       List.iter
  94         (fun suffix ->
  95           try
  96            HExtlib.safe_remove
  97              (Http_getter.resolve ~local:true ~writable:true (uri ^ suffix))
  98           with Http_getter_types.Key_not_found _ -> ())
  99         [""; ".body"; ".types"])
 100     owned_uris;
 101   List.iter (fun statement ->
 102     try
 103       ignore (HSql.exec dbtype dbd statement)
 104     with (HSql.Error _) as exn ->
 105       match HSql.errno dbtype dbd with
 106       | HSql.No_such_table
 107       | HSql.Bad_table_error
 108       | HSql.No_such_index -> prerr_endline statement; ()
 109       | _ -> raise exn
 110     ) statements;
 111 ;;
 112
 113 let create_owner_environment () =
 114   let dbd = instance () in
 115   let obj_tbl = MetadataTypes.obj_tbl () in
 116   let sort_tbl = MetadataTypes.sort_tbl () in
 117   let rel_tbl = MetadataTypes.rel_tbl () in
 118   let name_tbl =  MetadataTypes.name_tbl () in
 119   let count_tbl = MetadataTypes.count_tbl () in
 120   let l_obj_tbl = MetadataTypes.library_obj_tbl  in
 121   let l_sort_tbl = MetadataTypes.library_sort_tbl  in
 122   let l_rel_tbl = MetadataTypes.library_rel_tbl  in
 123   let l_name_tbl =  MetadataTypes.library_name_tbl  in
 124   let l_count_tbl = MetadataTypes.library_count_tbl  in
 125   let tbls = [
 126     (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
 127     (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
 128   in
 129   let system_tbls = [
 130     (l_obj_tbl,`RefObj) ; (l_sort_tbl,`RefSort) ; (l_rel_tbl,`RefRel) ;
 131     (l_name_tbl,`ObjectName) ; (l_count_tbl,`Count) ]
 132   in
 133   let tag tag l = List.map (fun x -> tag, x) l in
 134   let statements =
 135     (tag HSql.Library (SqlStatements.create_tables system_tbls)) @
 136     (tag HSql.User (SqlStatements.create_tables tbls)) @
 137     (tag HSql.Library (SqlStatements.create_indexes system_tbls)) @
 138     (tag HSql.User (SqlStatements.create_indexes tbls))
 139   in
 140   List.iter
 141     (fun (dbtype, statement) ->
 142       try
 143         ignore (HSql.exec dbtype dbd statement)
 144       with
 145         (HSql.Error _) as exc ->
 146           let status = HSql.errno dbtype dbd in
 147           match status with
 148           | HSql.Table_exists_error -> ()
 149           | HSql.Dup_keyname -> ()
 150           | HSql.GENERIC_ERROR _ ->
 151               prerr_endline statement;
 152               raise exc
 153           | _ -> ())
 154   statements
 155 ;;
 156
 157 (* removes uri from the ownerized tables, and returns the list of other objects
 158  * (theyr uris) that ref the one removed.
 159  * AFAIK there is no need to return it, since the MatitaTypes.staus should
 160  * contain all defined objects. but to double check we do not garbage the
 161  * metadata...
 162  *)
 163 let remove_uri uri =
 164   let obj_tbl = MetadataTypes.obj_tbl () in
 165   let sort_tbl = MetadataTypes.sort_tbl () in
 166   let rel_tbl = MetadataTypes.rel_tbl () in
 167   let name_tbl =  MetadataTypes.name_tbl () in
 168   (*let conclno_tbl = MetadataTypes.conclno_tbl () in
 169   let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in*)
 170   let count_tbl = MetadataTypes.count_tbl () in
 171
 172   let dbd = instance () in
 173   let suri = UriManager.string_of_uri uri in
 174   let dbtype =
 175     if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
 176   in
 177   let query table suri =
 178     if HSql.isMysql dbtype dbd then
 179       sprintf "DELETE QUICK LOW_PRIORITY FROM %s WHERE source='%s'" table
 180         (HSql.escape dbtype dbd suri)
 181     else
 182       sprintf "DELETE FROM %s WHERE source='%s'" table
 183         (HSql.escape dbtype dbd suri)
 184   in
 185   List.iter (fun t ->
 186     try
 187       ignore (HSql.exec dbtype dbd (query t suri))
 188     with
 189       exn -> raise exn (* no errors should be accepted *)
 190     )
 191   [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl];
 192 ;;
 193
 194 let xpointers_of_ind uri =
 195   let dbd = instance () in
 196   let name_tbl =  MetadataTypes.name_tbl () in
 197   let dbtype =
 198     if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
 199   in
 200   let escape s =
 201     Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_"
 202       (HSql.escape dbtype dbd s)
 203   in
 204   let query = sprintf
 205     ("SELECT source FROM %s WHERE source LIKE '%s#xpointer%%' "
 206      ^^ HSql.escape_string_for_like dbtype dbd)
 207     name_tbl (escape (UriManager.string_of_uri uri))
 208   in
 209   let rc = HSql.exec dbtype dbd query in
 210   let l = ref [] in
 211   HSql.iter rc (fun a ->  match a.(0) with None ->()|Some a -> l := a:: !l);
 212   List.map UriManager.uri_of_string !l
 213