helm/software/components/hmysql/hSql.ml

   1 (* Copyright (C) 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://cs.unibo.it/helm/.
  24  *)
  25
  26 type error_code =
  27  | OK
  28  | Table_exists_error
  29  | Dup_keyname
  30  | No_such_table
  31  | No_such_index
  32  | Bad_table_error
  33  | GENERIC_ERROR of string
  34
  35 exception Error of string
  36
  37 (* the exceptions raised are from the Mysql module *)
  38
  39 type dbtype = User | Library | Legacy
  40 type dbimplementation = Mysql of HMysql.dbd | Sqlite of HSqlite3.dbd | FakeMySql
  41 type result = Mysql_rc of HMysql.result | Sqlite_rc of HSqlite3.result | Nothing
  42
  43   (* host port dbname user password type *)
  44 type dbspec = (string * int option * string * string * string option * dbtype) list
  45 type dbd = (dbtype * dbimplementation) list
  46
  47 let debug = false;;
  48 let debug_print s = if debug then prerr_endline (Lazy.force s) else ();;
  49
  50 let pp_dbtype = function
  51   | User -> "User"
  52   | Library -> "Library"
  53   | Legacy -> "Legacy"
  54 ;;
  55
  56 let mk_dbspec l = l;;
  57
  58 let quick_connect dbspec =
  59   HExtlib.filter_map
  60     (fun (host, port, database, user, password, kind) ->
  61       if Pcre.pmatch ~pat:"^file://" host then
  62         Some (kind, (Sqlite (HSqlite3.quick_connect (kind = Library)
  63           ~host:(Pcre.replace ~pat:"^file://" host)
  64           ?port ~user ~database ?password ())))
  65       else if Pcre.pmatch ~pat:"^mysql://" host then
  66         Some (kind, (Mysql (HMysql.quick_connect
  67           ~host:(Pcre.replace ~pat:"^mysql://" host)
  68           ?port ~user ~database ?password ())))
  69       else
  70         None)
  71     dbspec
  72 ;;
  73
  74 let mk f1 f2 = function
  75   | (Sqlite dbd) -> Sqlite_rc (f1 dbd)
  76   | (Mysql dbd) -> Mysql_rc (f2 dbd)
  77   | FakeMySql -> assert false
  78 ;;
  79
  80 let mk_u f1 f2 = function
  81   | (_, (Sqlite dbd)) -> f1 dbd
  82   | (_, (Mysql dbd)) -> f2 dbd
  83   | (_, FakeMySql) -> assert false
  84 ;;
  85
  86 let wrap f x =
  87   try f x with
  88   | HMysql.Error s | HSqlite3.Error s -> raise (Error s)
  89   | Not_found -> raise (Error "Not_found")
  90 ;;
  91
  92 let disconnect dbd =
  93   wrap (List.iter (mk_u HSqlite3.disconnect HMysql.disconnect)) dbd
  94 ;;
  95
  96 let exec (dbtype : dbtype) (dbd : dbd) (query : string) =
  97   try
  98     debug_print (lazy ("EXEC: " ^ pp_dbtype dbtype ^ "|" ^ query));
  99     let dbd = List.assoc dbtype dbd in
 100     wrap (mk (HSqlite3.exec query) (HMysql.exec query)) dbd
 101   with Not_found ->
 102     if dbtype = Legacy then Nothing else raise (Error "No ro or writable db")
 103 ;;
 104
 105 let map result ~f =
 106   match result with
 107   | Mysql_rc rc -> HMysql.map rc ~f
 108   | Sqlite_rc rc -> HSqlite3.map rc ~f
 109   | Nothing -> []
 110 ;;
 111
 112 let iter result ~f =
 113   match result with
 114   | Mysql_rc rc -> HMysql.iter rc ~f
 115   | Sqlite_rc rc -> HSqlite3.iter rc ~f
 116   | Nothing -> ()
 117 ;;
 118
 119 let sqlite_err = function
 120  | HSqlite3.OK -> OK
 121  | HSqlite3.Table_exists_error -> Table_exists_error
 122  | HSqlite3.Dup_keyname -> Dup_keyname
 123  | HSqlite3.No_such_table -> No_such_table
 124  | HSqlite3.No_such_index -> No_such_index
 125  | HSqlite3.Bad_table_error -> Bad_table_error
 126  | HSqlite3.GENERIC_ERROR s -> GENERIC_ERROR s
 127 ;;
 128
 129 let mysql_err = function
 130  | HMysql.OK -> OK
 131  | HMysql.Table_exists_error -> Table_exists_error
 132  | HMysql.Dup_keyname -> Dup_keyname
 133  | HMysql.No_such_table -> No_such_table
 134  | HMysql.No_such_index -> No_such_index
 135  | HMysql.Bad_table_error -> Bad_table_error
 136  | HMysql.GENERIC_ERROR s -> GENERIC_ERROR s
 137 ;;
 138
 139 let errno dbtype dbd =
 140   wrap
 141     (fun d -> match List.assoc dbtype d with
 142     | Mysql dbd -> mysql_err (HMysql.errno dbd)
 143     | Sqlite dbd -> sqlite_err (HSqlite3.errno dbd)
 144     | FakeMySql -> assert false)
 145     dbd
 146 ;;
 147
 148 let escape dbtype dbd s =
 149   try
 150       match List.assoc dbtype dbd with
 151       | Mysql _ | FakeMySql -> wrap HMysql.escape s
 152       | Sqlite _ -> wrap HSqlite3.escape s
 153   with Not_found ->
 154     if dbtype = Legacy then s else raise (Error "No ro or writable db")
 155 ;;
 156
 157 let escape_string_for_like dbtype dbd =
 158   try
 159       match List.assoc dbtype dbd with
 160       | Mysql _ | FakeMySql -> HMysql.escape_string_for_like
 161       | Sqlite _ -> HSqlite3.escape_string_for_like
 162   with Not_found ->
 163     if dbtype = Legacy then ("ESCAPE \"\\\"" : ('a,'b,'c,'a) format4)
 164     else raise (Error "No ro or writable db")
 165 ;;
 166
 167 let isMysql dbtype dbd =
 168   wrap
 169     (fun d -> match List.assoc dbtype d with Mysql _ -> true | _ -> false)
 170     dbd
 171 ;;
 172
 173 let fake_db_for_mysql dbtype =
 174   [dbtype, FakeMySql]
 175 ;;