Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 351 lines (326 sloc) 13.054 kb
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
1 (* autogenerated by sql_orm *)
2 module Sql_access = struct
3 (*
4 * Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
5 *
6 * Permission to use, copy, modify, and distribute this software for any
7 * purpose with or without fee is hereby granted, provided that the above
8 * copyright notice and this permission notice appear in all copies.
9 *
10 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17 *)
18
19 open Sqlite3
20 open Printf
21
22 type transaction_mode = [
23 |`Deferred
24 |`Immediate
25 |`Exclusive
26 ]
27
28 type state = {
29 db : db;
30 mutable in_transaction: int;
31 busyfn: db -> unit;
32 mode: transaction_mode;
33 }
34
35 let default_busyfn (db:Sqlite3.db) =
36 print_endline "WARNING: busy";
37 Thread.delay (Random.float 1.)
38
39 let raise_sql_error x =
40 raise (Sqlite3.Error (Rc.to_string x))
41
42 let try_finally fn finalfn =
43 try
44 let r = fn () in
45 finalfn ();
46 r
47 with e -> begin
48 print_endline (sprintf "WARNING: exception: %s" (Printexc.to_string e));
49 finalfn ();
50 raise e
51 end
52
53 (* retry until a non-BUSY error code is returned *)
54 let rec db_busy_retry db fn =
55 match fn () with
56 |Rc.BUSY ->
57 db.busyfn db.db;
58 db_busy_retry db fn;
59 |x -> x
60
61 (* make sure an OK is returned from the database *)
62 let db_must_ok db fn =
63 match db_busy_retry db fn with
64 |Rc.OK -> ()
65 |x -> raise_sql_error x
66
67 (* make sure a DONE is returned from the database *)
68 let db_must_done db fn =
69 match db_busy_retry db fn with
70 |Rc.DONE -> ()
71 |x -> raise_sql_error x
72
73 (* request a transaction *)
74 let transaction db fn =
75 let m = match db.mode with
76 |`Deferred -> "DEFERRED" |`Immediate -> "IMMEDIATE" |`Exclusive -> "EXCLUSIVE" in
77 try_finally (fun () ->
78 if db.in_transaction = 0 then (
79 db_must_ok db (fun () -> exec db.db (sprintf "BEGIN %s TRANSACTION" m));
80 );
81 db.in_transaction <- db.in_transaction + 1;
82 fn ();
83 ) (fun () ->
84 if db.in_transaction = 1 then (
85 db_must_ok db (fun () -> exec db.db "END TRANSACTION");
86 );
87 db.in_transaction <- db.in_transaction - 1
88 )
89
90 (* iterate over a result set *)
91 let step_fold db stmt iterfn =
92 let stepfn () = Sqlite3.step stmt in
93 let rec fn a = match db_busy_retry db stepfn with
94 |Sqlite3.Rc.ROW -> fn (iterfn stmt :: a)
95 |Sqlite3.Rc.DONE -> a
96 |x -> raise_sql_error x
97 in
98 fn []
99 end
100
101
102 open Sql_access
103 module Passwd = struct
104 type t = <
105 id : int64 option;
106 set_id : int64 option -> unit;
107 service : string;
108 set_service : string -> unit;
109 ctime : float;
110 set_ctime : float -> unit;
111 username : string;
112 set_username : string -> unit;
113 encpasswd : string;
114 set_encpasswd : string -> unit;
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
115 comment : string;
116 set_comment : string -> unit;
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
117 save: int64; delete: unit
118 >
119
120 let init db =
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
121 let sql = "create table if not exists passwd (id integer primary key autoincrement,service text,ctime real,username text,encpasswd text,comment text);" in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
122 db_must_ok db (fun () -> Sqlite3.exec db.db sql);
123 let sql = "CREATE UNIQUE INDEX IF NOT EXISTS passwd_grp_service__username_idx ON passwd (service,username) " in
124 db_must_ok db (fun () -> Sqlite3.exec db.db sql);
125 ()
126
127 (* object definition *)
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
128 let t ?(id=None) ~service ~ctime ~username ~encpasswd ~comment db : t = object
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
129 (* get functions *)
130 val mutable _id = id
131 method id : int64 option = _id
132 val mutable _service = service
133 method service : string = _service
134 val mutable _ctime = ctime
135 method ctime : float = _ctime
136 val mutable _username = username
137 method username : string = _username
138 val mutable _encpasswd = encpasswd
139 method encpasswd : string = _encpasswd
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
140 val mutable _comment = comment
141 method comment : string = _comment
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
142
143 (* set functions *)
144 method set_id v =
145 _id <- v
146 method set_service v =
147 _service <- v
148 method set_ctime v =
149 _ctime <- v
150 method set_username v =
151 _username <- v
152 method set_encpasswd v =
153 _encpasswd <- v
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
154 method set_comment v =
155 _comment <- v
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
156
157 (* admin functions *)
158 method delete =
159 match _id with
160 |None -> ()
161 |Some id ->
162 let sql = "DELETE FROM passwd WHERE id=?" in
163 let stmt = Sqlite3.prepare db.db sql in
164 db_must_ok db (fun () -> Sqlite3.bind stmt 1 (Sqlite3.Data.INT id));
165 ignore(step_fold db stmt (fun _ -> ()));
166 _id <- None
167
168 method save = transaction db (fun () ->
169 (* insert any foreign-one fields into their table and get id *)
170 let _curobj_id = match _id with
171 |None -> (* insert new record *)
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
172 let sql = "INSERT INTO passwd VALUES(NULL,?,?,?,?,?)" in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
173 let stmt = Sqlite3.prepare db.db sql in
174 db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _service in Sqlite3.Data.TEXT v));
175 db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _ctime in Sqlite3.Data.FLOAT v));
176 db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _username in Sqlite3.Data.TEXT v));
177 db_must_ok db (fun () -> Sqlite3.bind stmt 4 (let v = _encpasswd in Sqlite3.Data.TEXT v));
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
178 db_must_ok db (fun () -> Sqlite3.bind stmt 5 (let v = _comment in Sqlite3.Data.TEXT v));
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
179 db_must_done db (fun () -> Sqlite3.step stmt);
180 let __id = Sqlite3.last_insert_rowid db.db in
181 _id <- Some __id;
182 __id
183 |Some id -> (* update *)
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
184 let sql = "UPDATE passwd SET service=?,ctime=?,username=?,encpasswd=?,comment=? WHERE id=?" in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
185 let stmt = Sqlite3.prepare db.db sql in
186 db_must_ok db (fun () -> Sqlite3.bind stmt 1 (let v = _service in Sqlite3.Data.TEXT v));
187 db_must_ok db (fun () -> Sqlite3.bind stmt 2 (let v = _ctime in Sqlite3.Data.FLOAT v));
188 db_must_ok db (fun () -> Sqlite3.bind stmt 3 (let v = _username in Sqlite3.Data.TEXT v));
189 db_must_ok db (fun () -> Sqlite3.bind stmt 4 (let v = _encpasswd in Sqlite3.Data.TEXT v));
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
190 db_must_ok db (fun () -> Sqlite3.bind stmt 5 (let v = _comment in Sqlite3.Data.TEXT v));
191 db_must_ok db (fun () -> Sqlite3.bind stmt 6 (Sqlite3.Data.INT id));
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
192 db_must_done db (fun () -> Sqlite3.step stmt);
193 id
194 in
195 _curobj_id
196 )
197 end
198
199 (* General get function for any of the columns *)
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
200 let get ?(id=None) ?(service=None) ?(ctime=None) ?(username=None) ?(encpasswd=None) ?(comment=None) ?(custom_where=("",[])) db =
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
201 (* assemble the SQL query string *)
202 let q = "" in
203 let _first = ref true in
204 let f () = match !_first with |true -> _first := false; " WHERE " |false -> " AND " in
205 let q = match id with |None -> q |Some b -> q ^ (f()) ^ "passwd.id=?" in
206 let q = match service with |None -> q |Some b -> q ^ (f()) ^ "passwd.service=?" in
207 let q = match ctime with |None -> q |Some b -> q ^ (f()) ^ "passwd.ctime=?" in
208 let q = match username with |None -> q |Some b -> q ^ (f()) ^ "passwd.username=?" in
209 let q = match encpasswd with |None -> q |Some b -> q ^ (f()) ^ "passwd.encpasswd=?" in
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
210 let q = match comment with |None -> q |Some b -> q ^ (f()) ^ "passwd.comment=?" in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
211 let q = match custom_where with |"",_ -> q |w,_ -> q ^ (f()) ^ "(" ^ w ^ ")" in
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
212 let sql="SELECT passwd.id, passwd.service, passwd.ctime, passwd.username, passwd.encpasswd, passwd.comment FROM passwd " ^ q in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
213 let stmt=Sqlite3.prepare db.db sql in
214 (* bind the position variables to the statement *)
215 let bindpos = ref 1 in
216 ignore(match id with |None -> () |Some v ->
217 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.INT v));
218 incr bindpos
219 );
220 ignore(match service with |None -> () |Some v ->
221 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
222 incr bindpos
223 );
224 ignore(match ctime with |None -> () |Some v ->
225 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.FLOAT v));
226 incr bindpos
227 );
228 ignore(match username with |None -> () |Some v ->
229 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
230 incr bindpos
231 );
232 ignore(match encpasswd with |None -> () |Some v ->
233 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
234 incr bindpos
235 );
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
236 ignore(match comment with |None -> () |Some v ->
237 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos (Sqlite3.Data.TEXT v));
238 incr bindpos
239 );
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
240 ignore(match custom_where with |_,[] -> () |_,eb ->
241 List.iter (fun b ->
242 db_must_ok db (fun () -> Sqlite3.bind stmt !bindpos b);
243 incr bindpos
244 ) eb);
245 (* convert statement into an ocaml object *)
246 let of_stmt stmt =
247 t
248 (* native fields *)
249 ~id:(
250 (match Sqlite3.column stmt 0 with
251 |Sqlite3.Data.NULL -> None
252 |x -> Some (match x with |Sqlite3.Data.INT i -> i |x -> (try Int64.of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: passwd id")))
253 )
254 ~service:(
255 (match Sqlite3.column stmt 1 with
256 |Sqlite3.Data.NULL -> failwith "null of_stmt"
257 |x -> Sqlite3.Data.to_string x)
258 )
259 ~ctime:(
260 (match Sqlite3.column stmt 2 with
261 |Sqlite3.Data.NULL -> failwith "null of_stmt"
262 |x -> match x with |Sqlite3.Data.FLOAT i -> i|x -> (try float_of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: passwd ctime"))
263 )
264 ~username:(
265 (match Sqlite3.column stmt 3 with
266 |Sqlite3.Data.NULL -> failwith "null of_stmt"
267 |x -> Sqlite3.Data.to_string x)
268 )
269 ~encpasswd:(
270 (match Sqlite3.column stmt 4 with
271 |Sqlite3.Data.NULL -> failwith "null of_stmt"
272 |x -> Sqlite3.Data.to_string x)
273 )
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
274 ~comment:(
275 (match Sqlite3.column stmt 5 with
276 |Sqlite3.Data.NULL -> failwith "null of_stmt"
277 |x -> Sqlite3.Data.to_string x)
278 )
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
279 (* foreign fields *)
280 db
281 in
282 (* execute the SQL query *)
283 step_fold db stmt of_stmt
284
285 let get_by_service_username ~service ~username ?(custom_where=("",[])) db =
286 let q = "WHERE passwd.service=? AND passwd.username=?" in
287 let q = match custom_where with |"",_ -> q |w,_ -> q ^ " AND (" ^ w ^ ")" in
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
288 let sql="SELECT passwd.id, passwd.service, passwd.ctime, passwd.username, passwd.encpasswd, passwd.comment FROM passwd " ^ q in
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
289 let stmt=Sqlite3.prepare db.db sql in
290 db_must_ok db (fun () -> let v = service in Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT v));
291 db_must_ok db (fun () -> let v = username in Sqlite3.bind stmt 2 (Sqlite3.Data.TEXT v));
292 ignore(match custom_where with |_,[] -> () |_,eb ->
293 let pos = ref 3 in
294 List.iter (fun b ->
295 db_must_ok db (fun () -> Sqlite3.bind stmt !pos b);
296 incr pos;
297 ) eb);
298 (* convert statement into an ocaml object *)
299 let of_stmt stmt =
300 t
301 (* native fields *)
302 ~id:(
303 (match Sqlite3.column stmt 0 with
304 |Sqlite3.Data.NULL -> None
305 |x -> Some (match x with |Sqlite3.Data.INT i -> i |x -> (try Int64.of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: passwd id")))
306 )
307 ~service:(
308 (match Sqlite3.column stmt 1 with
309 |Sqlite3.Data.NULL -> failwith "null of_stmt"
310 |x -> Sqlite3.Data.to_string x)
311 )
312 ~ctime:(
313 (match Sqlite3.column stmt 2 with
314 |Sqlite3.Data.NULL -> failwith "null of_stmt"
315 |x -> match x with |Sqlite3.Data.FLOAT i -> i|x -> (try float_of_string (Sqlite3.Data.to_string x) with _ -> failwith "error: passwd ctime"))
316 )
317 ~username:(
318 (match Sqlite3.column stmt 3 with
319 |Sqlite3.Data.NULL -> failwith "null of_stmt"
320 |x -> Sqlite3.Data.to_string x)
321 )
322 ~encpasswd:(
323 (match Sqlite3.column stmt 4 with
324 |Sqlite3.Data.NULL -> failwith "null of_stmt"
325 |x -> Sqlite3.Data.to_string x)
326 )
6201e57 convert the passwd storing interface to be more RESTful
Anil Madhavapeddy authored
327 ~comment:(
328 (match Sqlite3.column stmt 5 with
329 |Sqlite3.Data.NULL -> failwith "null of_stmt"
330 |x -> Sqlite3.Data.to_string x)
331 )
0812007 @avsm add in the keychain autogen files, and remove the now unused sql_access ...
authored
332 (* foreign fields *)
333 db
334 in
335 (* execute the SQL query *)
336 step_fold db stmt of_stmt
337
338 end
339
340 module Init = struct
341 type t = state
342 type transaction_mode = [`Exclusive |`Deferred |`Immediate ]
343 let t ?(busyfn=default_busyfn) ?(mode=`Immediate) db_name =
344 let db = {db=Sqlite3.db_open db_name; in_transaction=0; mode=mode; busyfn=busyfn } in
345 Passwd.init db;
346 db
347
348 let db handle = handle.db
349 end
350
Something went wrong with that request. Please try again.