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 -> Nothing
 102 ;;
 103
 104 let map result ~f =
 105   match result with
 106   | Mysql_rc rc -> HMysql.map rc ~f
 107   | Sqlite_rc rc -> HSqlite3.map rc ~f
 108   | Nothing -> []
 109 ;;
 110
 111 let iter result ~f =
 112   match result with
 113   | Mysql_rc rc -> HMysql.iter rc ~f
 114   | Sqlite_rc rc -> HSqlite3.iter rc ~f
 115   | Nothing -> ()
 116 ;;
 117
 118 let sqlite_err = function
 119  | HSqlite3.OK -> OK
 120  | HSqlite3.Table_exists_error -> Table_exists_error
 121  | HSqlite3.Dup_keyname -> Dup_keyname
 122  | HSqlite3.No_such_table -> No_such_table
 123  | HSqlite3.No_such_index -> No_such_index
 124  | HSqlite3.Bad_table_error -> Bad_table_error
 125  | HSqlite3.GENERIC_ERROR s -> GENERIC_ERROR s
 126 ;;
 127
 128 let mysql_err = function
 129  | HMysql.OK -> OK
 130  | HMysql.Table_exists_error -> Table_exists_error
 131  | HMysql.Dup_keyname -> Dup_keyname
 132  | HMysql.No_such_table -> No_such_table
 133  | HMysql.No_such_index -> No_such_index
 134  | HMysql.Bad_table_error -> Bad_table_error
 135  | HMysql.GENERIC_ERROR s -> GENERIC_ERROR s
 136 ;;
 137
 138 let errno dbtype dbd =
 139   wrap
 140     (fun d ->
 141     try
 142       match List.assoc dbtype d with
 143       | Mysql dbd -> mysql_err (HMysql.errno dbd)
 144       | Sqlite dbd -> sqlite_err (HSqlite3.errno dbd)
 145       | FakeMySql -> assert false
 146     with Not_found -> OK)
 147     dbd
 148 ;;
 149
 150 let escape dbtype dbd s =
 151   try
 152       match List.assoc dbtype dbd with
 153       | Mysql _ | FakeMySql -> wrap HMysql.escape s
 154       | Sqlite _ -> wrap HSqlite3.escape s
 155   with Not_found -> s
 156 ;;
 157
 158 let escape_string_for_like dbtype dbd =
 159   try
 160       match List.assoc dbtype dbd with
 161       | Mysql _ | FakeMySql -> HMysql.escape_string_for_like
 162       | Sqlite _ -> HSqlite3.escape_string_for_like
 163   with Not_found ->
 164     ("ESCAPE \"\\\"" : ('a,'b,'c,'a) format4)
 165 ;;
 166
 167 let isMysql dbtype dbd =
 168   wrap
 169     (fun d ->
 170        try
 171         match List.assoc dbtype d with Mysql _ -> true | _ -> false
 172        with Not_found -> false)
 173     dbd
 174 ;;
 175
 176 let fake_db_for_mysql dbtype =
 177   [dbtype, FakeMySql]
 178 ;;