1
(* Copyright (c) 2006-2008 Janne Hellsten <jjhellst@gmail.com> *)
4
* This program is free software: you can redistribute it and/or
5
* modify it under the terms of the GNU General Public License as
6
* published by the Free Software Foundation, either version 2 of the
7
* License, or (at your option) any later version.
9
* This program is distributed in the hope that it will be useful, but
10
* WITHOUT ANY WARRANTY; without even the implied warranty of
11
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12
* General Public License for more details. You should have received
13
* a copy of the GNU General Public License along with this program.
14
* If not, see <http://www.gnu.org/licenses/>.
18
module Psql = Postgresql
26
type connection = Psql.connection
29
module ConnectionPool =
33
(* We have only one connection to pool from for now. This will
34
likely be extended for more connetcions in the future. There's
35
no need for it yet though. *)
37
let connection_mutex = Mutex.create ()
38
let connection : Postgresql.connection option ref = ref None
51
(* NOTE we may get a deadlock here if someone uses nested
52
with_conn calls. This should not happen unless there's a
53
programming error somewhere. This case should go away if there
54
are more than one DB connections available for with_conn.
55
Currently there's only one connection though. *)
56
let with_conn_priv (f : (Psql.connection -> 'a)) =
57
(* TODO the error handling here is not still very robust. *)
58
with_mutex connection_mutex
60
match !connection with
62
(* Re-use the old connection. *)
67
Ocsigen_messages.errlog "Database connection bad. Trying reset";
73
Ocsigen_messages.errlog "Database connection still bad. Bail out";
74
raise (Error (Psql.Connection_failure "bad connection")))
76
let host = Option.default "localhost" dbcfg.db_host in
77
let port = Option.default "" dbcfg.db_port in
78
let password = Option.default "" dbcfg.db_pass in
80
new Psql.connection ~host ~port ~password
81
~dbname:dbcfg.db_name ~user:dbcfg.db_user
84
(* Search tables from nurpawiki schema first: *)
91
(Psql.Error e) as ex ->
92
Ocsigen_messages.errlog (P.sprintf "psql failed : %s\n" (Psql.string_of_error e));
101
Lwt_preemptive.detach ConnectionPool.with_conn f
103
(* Escape a string for SQL query *)
105
let b = Buffer.create (String.length s) in
108
'\\' -> Buffer.add_string b "\\\\"
109
| '\'' -> Buffer.add_string b "''"
110
| '"' -> Buffer.add_string b "\""
111
| c -> Buffer.add_char b c) s;
114
let todos_user_login_join = "FROM nw.todos LEFT OUTER JOIN nw.users ON nw.todos.user_id = nw.users.id"
116
(* Use this tuple format when querying TODOs to be parsed by
118
let todo_tuple_format = "nw.todos.id,descr,completed,priority,activation_date,user_id,nw.users.login"
120
let todo_of_row row =
121
let id = int_of_string (List.nth row 0) in
122
let descr = List.nth row 1 in
123
let completed = (List.nth row 2) = "t" in
124
let owner_id = List.nth row 5 in
126
if owner_id = "" then
130
owner_id = int_of_string owner_id;
131
owner_login = List.nth row 6;
134
let pri = List.nth row 3 in
138
t_completed = completed;
139
t_priority = int_of_string pri;
140
t_activation_date = List.nth row 4;
144
let parse_todo_result res =
147
let id = int_of_string (List.nth row 0) in
148
IMap.add id (todo_of_row row) acc)
149
IMap.empty res#get_all_lst
151
let guarded_exec ~(conn : Psql.connection) query =
155
(Psql.Error e) as ex ->
157
Psql.Connection_failure msg ->
158
P.eprintf "psql failed : %s\n" msg;
161
P.eprintf "psql failed : %s\n" (Psql.string_of_error e);
164
let insert_todo_activity ~user_id todo_id ?(page_ids=None) activity =
165
let user_id_s = string_of_int user_id in
168
"INSERT INTO nw.activity_log(activity_id,user_id,todo_id) VALUES ("^
169
(string_of_int (int_of_activity_type activity))^", "^user_id_s^
175
"INSERT INTO nw.activity_in_pages(activity_log_id,page_id) "^
176
"VALUES (CURRVAL('nw.activity_log_id_seq'), "^string_of_int page_id^")")
178
let page_act_insert = String.concat "; " insert_pages in
179
"INSERT INTO nw.activity_log(activity_id,user_id,todo_id) VALUES ("^
180
(string_of_int (int_of_activity_type activity))^", "^
181
user_id_s^", "^todo_id^"); "^
184
let insert_save_page_activity ~conn ~user_id (page_id : int) =
186
INSERT INTO nw.activity_log(activity_id, user_id)
187
VALUES ("^(string_of_int (int_of_activity_type AT_edit_page))^
188
" ,"^(string_of_int user_id)^");
189
INSERT INTO nw.activity_in_pages(activity_log_id,page_id)
190
VALUES (CURRVAL('nw.activity_log_id_seq'), "^string_of_int page_id^");
192
ignore (guarded_exec ~conn sql)
194
let query_todos_by_ids ~conn todo_ids =
195
if todo_ids <> [] then
196
let ids = String.concat "," (List.map string_of_int todo_ids) in
199
("SELECT "^todo_tuple_format^" "^todos_user_login_join^" WHERE nw.todos.id IN ("^ids^")") in
200
List.map todo_of_row (r#get_all_lst)
204
let query_todo ~conn id =
205
match query_todos_by_ids ~conn [id] with
210
let todo_exists ~conn id =
211
match query_todo ~conn id with Some _ -> true | None -> false
214
let update_todo_activation_date ~conn todo_id new_date =
216
"UPDATE nw.todos SET activation_date = '"^new_date^"' WHERE id = "^
217
(string_of_int todo_id) in
218
ignore (guarded_exec ~conn sql)
221
let update_todo_descr ~conn todo_id new_descr =
223
"UPDATE nw.todos SET descr = '"^escape new_descr^"' WHERE id = "^
224
(string_of_int todo_id) in
225
ignore (guarded_exec ~conn sql)
228
let update_todo_owner_id ~conn todo_id owner_id =
231
Some id -> string_of_int id
234
"UPDATE nw.todos SET user_id = "^owner_id_s^" WHERE id = "^
235
(string_of_int todo_id) in
236
ignore (guarded_exec ~conn sql)
239
let select_current_user id =
243
" AND (user_id = "^string_of_int user_id^" OR user_id IS NULL) ")
245
(* Query TODOs and sort by priority & completeness *)
246
let query_all_active_todos ~conn ~current_user_id () =
247
let r = guarded_exec ~conn
248
("SELECT "^todo_tuple_format^" "^todos_user_login_join^" "^
249
"WHERE activation_date <= current_date AND completed = 'f' "^
250
select_current_user current_user_id^
251
"ORDER BY completed,priority,id") in
252
List.map todo_of_row r#get_all_lst
254
let query_upcoming_todos ~conn ~current_user_id date_criterion =
255
let date_comparison =
257
"'"^string_of_int d^" days'" in
258
match date_criterion with
260
"(activation_date > now()) AND (now()+interval "^dayify days^
261
" >= activation_date)"
262
| (Some d1,Some d2) ->
263
let sd1 = dayify d1 in
264
let sd2 = dayify d2 in
265
"(activation_date > now()+interval "^sd1^") AND (now()+interval "^sd2^
266
" >= activation_date)"
268
let sd1 = dayify d1 in
269
"(activation_date > now()+interval "^sd1^")"
271
"activation_date <= now()" in
272
let r = guarded_exec ~conn
273
("SELECT "^todo_tuple_format^" "^todos_user_login_join^" "^
274
"WHERE "^date_comparison^
275
select_current_user current_user_id^
276
" AND completed='f' ORDER BY activation_date,priority,id") in
277
List.map todo_of_row r#get_all_lst
279
let new_todo ~conn page_id user_id descr =
280
(* TODO: could wrap this into BEGIN .. COMMIT if I knew how to
281
return the data from the query! *)
283
"INSERT INTO nw.todos(user_id,descr) values('"^(string_of_int user_id)^"','"^escape descr^"');
284
INSERT INTO nw.todos_in_pages(todo_id,page_id) values(CURRVAL('nw.todos_id_seq'), "
285
^string_of_int page_id^");"^
286
(insert_todo_activity ~user_id
287
"(SELECT CURRVAL('nw.todos_id_seq'))" ~page_ids:(Some [page_id])
289
SELECT CURRVAL('nw.todos_id_seq')" in
290
let r = guarded_exec ~conn sql in
291
(* Get ID of the inserted item: *)
294
(* Mapping from a todo_id to page list *)
295
let todos_in_pages ~conn todo_ids =
296
(* Don't query if the list is empty: *)
297
if todo_ids = [] then
300
let ids = String.concat "," (List.map string_of_int todo_ids) in
302
"SELECT todo_id,page_id,page_descr "^
303
"FROM nw.todos_in_pages,nw.pages WHERE todo_id IN ("^ids^") AND page_id = nw.pages.id" in
304
let r = guarded_exec ~conn sql in
305
let rows = r#get_all_lst in
308
let todo_id = int_of_string (List.nth row 0) in
309
let page_id = int_of_string (List.nth row 1) in
310
let page_descr = List.nth row 2 in
311
let lst = try IMap.find todo_id acc with Not_found -> [] in
312
IMap.add todo_id ({ p_id = page_id; p_descr = page_descr }::lst) acc)
315
(* TODO must not query ALL activities. Later we only want to
316
currently visible activities => pages available. *)
317
let query_activity_in_pages ~conn ~min_id ~max_id =
319
"SELECT activity_log_id,page_id,page_descr
320
FROM nw.activity_in_pages,nw.pages
321
WHERE page_id = pages.id
322
AND (activity_log_id > "^string_of_int min_id^"
323
AND activity_log_id <= "^string_of_int max_id^")" in
324
let r = guarded_exec ~conn sql in
327
let act_id = int_of_string (List.nth row 0) in
328
let page_id = int_of_string (List.nth row 1) in
329
let page_descr = List.nth row 2 in
330
let lst = try IMap.find act_id acc with Not_found -> [] in
331
IMap.add act_id ({ p_id = page_id; p_descr = page_descr }::lst) acc)
332
IMap.empty (r#get_all_lst)
334
(* Note: This function should only be used in contexts where there
335
will be no concurrency issues. Automated sessions should be used for
336
real ID inserts. In its current form, this function is used to get
337
the highest activity log item ID in order to display history separated
338
into multiple web pages. *)
339
let query_highest_activity_id ~conn =
340
let sql = "SELECT last_value FROM nw.activity_log_id_seq" in
341
let r = guarded_exec ~conn sql in
342
int_of_string (r#get_tuple 0).(0)
345
(* Collect todos in the current page *)
346
let query_page_todos ~conn page_id =
347
let sql = "SELECT "^todo_tuple_format^" "^todos_user_login_join^" WHERE nw.todos.id in "^
348
"(SELECT todo_id FROM nw.todos_in_pages WHERE page_id = "^string_of_int page_id^")" in
349
let r = guarded_exec ~conn sql in
352
(* Make sure todos are assigned to correct pages and that pages
353
don't contain old todos moved to other pages or removed. *)
354
let update_page_todos ~conn page_id todos =
355
let page_id' = string_of_int page_id in
358
DELETE FROM nw.todos_in_pages WHERE page_id = "^page_id'^";"^
362
"INSERT INTO nw.todos_in_pages(todo_id,page_id)"^
363
" values("^(string_of_int todo_id)^", "^page_id'^");")
366
ignore (guarded_exec ~conn sql)
368
(* Mark task as complete and set completion date for today *)
369
let complete_task_generic ~conn ~user_id id op =
370
let (activity,task_complete_flag) =
372
`Complete_task -> (AT_complete_todo, "t")
373
| `Resurrect_task -> (AT_uncomplete_todo, "f") in
376
Some (List.map (fun p -> p.p_id) (IMap.find id (todos_in_pages ~conn [id])))
377
with Not_found -> None in
378
let ids = string_of_int id in
380
UPDATE nw.todos SET completed = '"^task_complete_flag^"' where id="^ids^";"^
381
(insert_todo_activity ~user_id ids ~page_ids activity)^"; COMMIT" in
382
ignore (guarded_exec ~conn sql)
384
(* Mark task as complete and set completion date for today *)
385
let complete_task ~conn ~user_id id =
386
complete_task_generic ~conn ~user_id id `Complete_task
388
let uncomplete_task ~conn ~user_id id =
389
complete_task_generic ~conn ~user_id id `Resurrect_task
391
let query_task_priority ~conn id =
392
let sql = "SELECT priority FROM nw.todos WHERE id = "^string_of_int id in
393
let r = guarded_exec ~conn sql in
394
int_of_string (r#get_tuple 0).(0)
396
(* TODO offset_task_priority can probably be written in one
397
query instead of two (i.e., first one SELECT and then UPDATE
399
let offset_task_priority ~conn id incr =
400
let pri = min (max (query_task_priority ~conn id + incr) 1) 3 in
402
"UPDATE nw.todos SET priority = '"^(string_of_int pri)^
403
"' where id="^string_of_int id in
404
ignore (guarded_exec ~conn sql)
406
let up_task_priority id =
407
offset_task_priority id (-1)
409
let down_task_priority id =
410
offset_task_priority id 1
412
let new_wiki_page ~conn ~user_id page =
414
"INSERT INTO nw.pages (page_descr) VALUES ('"^escape page^"');
415
INSERT INTO nw.wikitext (page_id,page_created_by_user_id,page_text)
416
VALUES ((SELECT CURRVAL('nw.pages_id_seq')),
417
"^string_of_int user_id^", ''); "^
418
"SELECT CURRVAL('nw.pages_id_seq')" in
419
let r = guarded_exec ~conn sql in
420
int_of_string ((r#get_tuple 0).(0))
422
(* See WikiPageVersioning on docs wiki for more details on the SQL
424
let save_wiki_page ~conn page_id ~user_id lines =
425
let page_id_s = string_of_int page_id in
426
let user_id_s = string_of_int user_id in
427
let escaped = escape (String.concat "\n" lines) in
428
(* Ensure no one else can update the head revision while we're
429
modifying it Selecting for UPDATE means no one else can SELECT FOR
430
UPDATE this row. If value (head_revision+1) is only computed and used
431
inside this row lock, we should be protected against two (or more)
432
users creating the same revision head. *)
435
SELECT * from nw.pages WHERE id = "^page_id_s^";
437
-- Set ID of next revision
438
UPDATE nw.pages SET head_revision = nw.pages.head_revision+1
439
WHERE id = "^page_id_s^";
441
-- Kill search vectors for previous version so that only
442
-- the latest version of the wikitext can be found using
445
-- NOTE tsearch2 indexing trigger is set to run index updates
446
-- only on INSERTs and not on UPDATEs. I wanted to be
447
-- more future proof and set it trigger on UPDATE as well,
448
-- but I don't know how to NOT have tsearch2 trigger
449
-- overwrite the below UPDATE with its own index.
450
UPDATE nw.wikitext SET page_searchv = NULL WHERE page_id = "^page_id_s^";
452
INSERT INTO nw.wikitext (page_id, page_created_by_user_id, page_revision, page_text)
453
VALUES ("^page_id_s^", "^user_id_s^",
454
(SELECT head_revision FROM nw.pages where id = "^page_id_s^"),
458
ignore (guarded_exec ~conn sql)
460
let find_page_id ~conn descr =
462
"SELECT id FROM nw.pages WHERE page_descr = '"^escape descr^"' LIMIT 1" in
463
let r = guarded_exec ~conn sql in
464
if r#ntuples = 0 then None else Some (int_of_string (r#get_tuple 0).(0))
466
let page_id_of_page_name ~conn descr =
467
Option.get (find_page_id ~conn descr)
469
let wiki_page_exists ~conn page_descr =
470
find_page_id ~conn page_descr <> None
472
let is_legal_page_revision ~conn page_id_s rev_id =
474
SELECT page_id FROM nw.wikitext
475
WHERE page_id="^page_id_s^" AND page_revision="^string_of_int rev_id in
476
let r = guarded_exec ~conn sql in
479
(* Load a certain revision of a wiki page. If the given revision is
480
not known, default to head revision. *)
481
let load_wiki_page ~conn ?(revision_id=None) page_id =
482
let page_id_s = string_of_int page_id in
483
let head_rev_select =
484
"(SELECT head_revision FROM nw.pages WHERE id = "^page_id_s^")" in
486
match revision_id with
487
None -> head_rev_select
489
if is_legal_page_revision ~conn page_id_s r then
494
SELECT page_text FROM nw.wikitext
495
WHERE page_id="^string_of_int page_id^" AND
496
page_revision="^revision_s^" LIMIT 1" in
497
let r = guarded_exec ~conn sql in
500
let query_page_revisions ~conn page_descr =
501
match find_page_id ~conn page_descr with
504
let option_of_empty s f =
505
if s = "" then None else Some (f s) in
507
SELECT page_revision,nw.users.id,nw.users.login,date_trunc('second', page_created) FROM nw.wikitext
508
LEFT OUTER JOIN nw.users on page_created_by_user_id = nw.users.id
509
WHERE page_id = "^string_of_int page_id^"
510
ORDER BY page_revision DESC" in
511
let r = guarded_exec ~conn sql in
515
pr_revision = int_of_string (List.nth r 0);
516
pr_owner_id = option_of_empty (List.nth r 1) int_of_string;
517
pr_owner_login = option_of_empty (List.nth r 2) Std.identity;
518
pr_created = List.nth r 3;
523
let query_past_activity ~conn ~min_id ~max_id =
525
"SELECT nw.activity_log.id,activity_id,activity_timestamp,nw.todos.descr,nw.users.login
527
LEFT OUTER JOIN nw.todos ON nw.activity_log.todo_id = nw.todos.id
528
LEFT OUTER JOIN nw.users ON nw.activity_log.user_id = nw.users.id
530
nw.activity_log.activity_timestamp < now()
531
AND (nw.activity_log.id > "^string_of_int min_id^"
532
AND nw.activity_log.id <= "^string_of_int max_id^")
533
ORDER BY activity_timestamp DESC" in
534
let r = guarded_exec ~conn sql in
538
let id = int_of_string (List.nth row 0) in
539
let act_id = List.nth row 1 in
540
let time = List.nth row 2 in
541
let descr = List.nth row 3 in
542
let user = List.nth row 4 in
544
a_activity = activity_type_of_int (int_of_string act_id);
546
a_todo_descr = if descr = "" then None else Some descr;
547
a_changed_by = if user = "" then None else Some user
550
(* Search features *)
551
let search_wikipage ~conn str =
552
let escaped_ss = escape str in
554
"SELECT page_id,headline,page_descr FROM nw.findwikipage('"^escaped_ss^"') "^
555
"LEFT OUTER JOIN nw.pages on page_id = nw.pages.id ORDER BY rank DESC" in
556
let r = guarded_exec ~conn sql in
560
let id = int_of_string (List.nth row 0) in
561
let hl = List.nth row 1 in
564
sr_page_descr = Some (List.nth row 2);
565
sr_result_type = SR_page })
568
let user_query_string =
569
"SELECT id,login,passwd,real_name,email FROM nw.users"
571
let user_of_sql_row row =
572
let id = int_of_string (List.nth row 0) in
575
user_login = (List.nth row 1);
576
user_passwd = (List.nth row 2);
577
user_real_name = (List.nth row 3);
578
user_email = (List.nth row 4);
581
let query_users ~conn =
582
let sql = user_query_string ^ " ORDER BY id" in
583
let r = guarded_exec ~conn sql in
584
r#get_all_lst >> List.map user_of_sql_row
587
let query_user ~conn username =
589
user_query_string ^" WHERE login = '"^escape username^"' LIMIT 1" in
590
let r = guarded_exec ~conn sql in
591
if r#ntuples = 0 then
594
Some (user_of_sql_row (r#get_tuple_lst 0))
596
let add_user ~conn ~login ~passwd ~real_name ~email =
598
"INSERT INTO nw.users (login,passwd,real_name,email) "^
599
"VALUES ("^(String.concat ","
600
(List.map (fun s -> "'"^escape s^"'")
601
[login; passwd; real_name; email]))^")" in
602
ignore (guarded_exec ~conn sql)
604
let update_user ~conn~user_id ~passwd ~real_name ~email =
606
"UPDATE nw.users SET "^
609
| Some passwd -> "passwd = '"^escape passwd^"',")^
610
"real_name = '"^escape real_name^"',
611
email = '"^escape email^"'
612
WHERE id = "^(string_of_int user_id) in
613
ignore (guarded_exec ~conn sql)
616
(* Highest upgrade schema below must match this version *)
617
let nurpawiki_schema_version = 3