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