~ubuntu-branches/ubuntu/lucid/nurpawiki/lucid : revision 8

1

2

3

(*

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.

8

*

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/>.

15

*)

16

17

open Types

18

module Psql = Postgresql

19

module P = Printf

20

open XHTML.M

21

22

open Eliom_sessions

23

24

open Config

25

26

type connection = Psql.connection

27

let (>>) f g = g f

28

29

module ConnectionPool =

30

struct

31

open Psql

32

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. *)

36

37

let connection_mutex = Mutex.create ()

38

let connection : Postgresql.connection option ref = ref None

39

40

let with_mutex m f =

41

Mutex.lock m;

42

try

43

let r = f () in

44

Mutex.unlock m;

45

r

46

with

47

x ->

48

Mutex.unlock m;

49

raise x

50

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

59

(fun () ->

60

match !connection with

61

Some c ->

62

(* Re-use the old connection. *)

63

(match c#status with

64

Ok ->

65

f c

66

| Bad ->

67

Ocsigen_messages.errlog "Database connection bad. Trying reset";

68

c#reset;

69

match c#status with

70

Ok ->

71

f c

72

| Bad ->

73

Ocsigen_messages.errlog "Database connection still bad. Bail out";

74

raise (Error (Psql.Connection_failure "bad connection")))

75

| None ->

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

79

let c =

80

new Psql.connection ~host ~port ~password

81

~dbname:dbcfg.db_name ~user:dbcfg.db_user

82

() in

83

connection := Some c;

84

(* Search tables from nurpawiki schema first: *)

85

f c)

86

87

let with_conn f =

88

try

89

with_conn_priv f

90

with

91

(Psql.Error e) as ex ->

92

Ocsigen_messages.errlog (P.sprintf "psql failed : %s\n" (Psql.string_of_error e));

93

raise ex

94

| x ->

95

raise x

96

97

98

end

99

100

let with_conn f =

101

Lwt_preemptive.detach ConnectionPool.with_conn f

102

103

(* Escape a string for SQL query *)

104

let escape s =

105

let b = Buffer.create (String.length s) in

106

String.iter

107

(function

108

'\\' -> Buffer.add_string b "\\\\"

109

| '\'' -> Buffer.add_string b "''"

110

| '"' -> Buffer.add_string b "\""

111

| c -> Buffer.add_char b c) s;

112

Buffer.contents b

113

114

let todos_user_login_join = "FROM nw.todos LEFT OUTER JOIN nw.users ON nw.todos.user_id = nw.users.id"

115

116

(* Use this tuple format when querying TODOs to be parsed by

117

parse_todo_result *)

118

let todo_tuple_format = "nw.todos.id,descr,completed,priority,activation_date,user_id,nw.users.login"

119

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

125

let owner =

126

if owner_id = "" then

127

None

128

else

129

Some {

130

owner_id = int_of_string owner_id;

131

owner_login = List.nth row 6;

132

} in

133

134

let pri = List.nth row 3 in

135

{

136

t_id = id;

137

t_descr = descr;

138

t_completed = completed;

139

t_priority = int_of_string pri;

140

t_activation_date = List.nth row 4;

141

t_owner = owner;

142

}

143

144

let parse_todo_result res =

145

List.fold_left

146

(fun acc row ->

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

150

151

let guarded_exec ~(conn : Psql.connection) query =

152

try

153

conn#exec query

154

with

155

(Psql.Error e) as ex ->

156

(match e with

157

Psql.Connection_failure msg ->

158

P.eprintf "psql failed : %s\n" msg;

159

raise ex

160

| _ ->

161

P.eprintf "psql failed : %s\n" (Psql.string_of_error e);

162

raise ex)

163

164

let insert_todo_activity ~user_id todo_id ?(page_ids=None) activity =

165

let user_id_s = string_of_int user_id in

166

match page_ids with

167

None ->

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^

170

", "^todo_id^")"

171

| Some pages ->

172

let insert_pages =

173

List.map

174

(fun page_id ->

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^")")

177

pages in

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^"); "^

182

page_act_insert

183

184

let insert_save_page_activity ~conn ~user_id (page_id : int) =

185

let sql = "BEGIN;

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^");

191

COMMIT" in

192

ignore (guarded_exec ~conn sql)

193

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

197

let r =

198

guarded_exec ~conn

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)

201

else

202

[]

203

204

let query_todo ~conn id =

205

match query_todos_by_ids ~conn [id] with

206

[task] -> Some task

207

| [] -> None

208

| _ -> None

209

210

let todo_exists ~conn id =

211

match query_todo ~conn id with Some _ -> true | None -> false

212

213

214

let update_todo_activation_date ~conn todo_id new_date =

215

let sql =

216

"UPDATE nw.todos SET activation_date = '"^new_date^"' WHERE id = "^

217

(string_of_int todo_id) in

218

ignore (guarded_exec ~conn sql)

219

220

221

let update_todo_descr ~conn todo_id new_descr =

222

let sql =

223

"UPDATE nw.todos SET descr = '"^escape new_descr^"' WHERE id = "^

224

(string_of_int todo_id) in

225

ignore (guarded_exec ~conn sql)

226

227

228

let update_todo_owner_id ~conn todo_id owner_id =

229

let owner_id_s =

230

match owner_id with

231

Some id -> string_of_int id

232

| None -> "NULL" in

233

let sql =

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)

237

238

239

let select_current_user id =

240

(match id with

241

None -> ""

242

| Some user_id ->

243

" AND (user_id = "^string_of_int user_id^" OR user_id IS NULL) ")

244

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

253

254

let query_upcoming_todos ~conn ~current_user_id date_criterion =

255

let date_comparison =

256

let dayify d =

257

"'"^string_of_int d^" days'" in

258

match date_criterion with

259

(None,Some days) ->

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)"

267

| (Some d1,None) ->

268

let sd1 = dayify d1 in

269

"(activation_date > now()+interval "^sd1^")"

270

| (None,None) ->

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

278

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! *)

282

let sql =

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])

288

AT_create_todo)^";

289

SELECT CURRVAL('nw.todos_id_seq')" in

290

let r = guarded_exec ~conn sql in

291

(* Get ID of the inserted item: *)

292

(r#get_tuple 0).(0)

293

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

298

IMap.empty

299

else

300

let ids = String.concat "," (List.map string_of_int todo_ids) in

301

let sql =

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

306

List.fold_left

307

(fun acc row ->

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)

313

IMap.empty rows

314

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 =

318

let sql =

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

325

List.fold_left

326

(fun acc row ->

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)

333

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)

343

344

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

350

parse_todo_result r

351

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

356

let sql =

357

"BEGIN;

358

DELETE FROM nw.todos_in_pages WHERE page_id = "^page_id'^";"^

359

(String.concat ""

360

(List.map

361

(fun todo_id ->

362

"INSERT INTO nw.todos_in_pages(todo_id,page_id)"^

363

" values("^(string_of_int todo_id)^", "^page_id'^");")

364

todos)) ^

365

"COMMIT" in

366

ignore (guarded_exec ~conn sql)

367

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) =

371

match op with

372

`Complete_task -> (AT_complete_todo, "t")

373

| `Resurrect_task -> (AT_uncomplete_todo, "f") in

374

let page_ids =

375

try

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

379

let sql = "BEGIN;

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)

383

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

387

388

let uncomplete_task ~conn ~user_id id =

389

complete_task_generic ~conn ~user_id id `Resurrect_task

390

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)

395

396

(* TODO offset_task_priority can probably be written in one

397

query instead of two (i.e., first one SELECT and then UPDATE

398

based on that. *)

399

let offset_task_priority ~conn id incr =

400

let pri = min (max (query_task_priority ~conn id + incr) 1) 3 in

401

let sql =

402

"UPDATE nw.todos SET priority = '"^(string_of_int pri)^

403

"' where id="^string_of_int id in

404

ignore (guarded_exec ~conn sql)

405

406

let up_task_priority id =

407

offset_task_priority id (-1)

408

409

let down_task_priority id =

410

offset_task_priority id 1

411

412

let new_wiki_page ~conn ~user_id page =

413

let sql =

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))

421

422

(* See WikiPageVersioning on docs wiki for more details on the SQL

423

queries. *)

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. *)

433

let sql = "

434

BEGIN;

435

SELECT * from nw.pages WHERE id = "^page_id_s^";

436

437

-- Set ID of next revision

438

UPDATE nw.pages SET head_revision = nw.pages.head_revision+1

439

WHERE id = "^page_id_s^";

440

441

-- Kill search vectors for previous version so that only

442

-- the latest version of the wikitext can be found using

443

-- full text search.

444

--

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^";

451

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^"),

455

E'"^escaped^"');

456

457

COMMIT" in

458

ignore (guarded_exec ~conn sql)

459

460

let find_page_id ~conn descr =

461

let sql =

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))

465

466

let page_id_of_page_name ~conn descr =

467

Option.get (find_page_id ~conn descr)

468

469

let wiki_page_exists ~conn page_descr =

470

find_page_id ~conn page_descr <> None

471

472

let is_legal_page_revision ~conn page_id_s rev_id =

473

let sql = "

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

477

r#ntuples <> 0

478

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

485

let revision_s =

486

match revision_id with

487

None -> head_rev_select

488

| Some r ->

489

if is_legal_page_revision ~conn page_id_s r then

490

string_of_int r

491

else

492

head_rev_select in

493

let sql = "

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

498

(r#get_tuple 0).(0)

499

500

let query_page_revisions ~conn page_descr =

501

match find_page_id ~conn page_descr with

502

None -> []

503

| Some page_id ->

504

let option_of_empty s f =

505

if s = "" then None else Some (f s) in

506

let sql = "

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

512

List.map

513

(fun r ->

514

{

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;

519

})

520

(r#get_all_lst)

521

522

523

let query_past_activity ~conn ~min_id ~max_id =

524

let sql =

525

"SELECT nw.activity_log.id,activity_id,activity_timestamp,nw.todos.descr,nw.users.login

526

FROM nw.activity_log

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

529

WHERE

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

535

r#get_all_lst >>

536

List.map

537

(fun row ->

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

543

{ a_id = id;

544

a_activity = activity_type_of_int (int_of_string act_id);

545

a_date = time;

546

a_todo_descr = if descr = "" then None else Some descr;

547

a_changed_by = if user = "" then None else Some user

548

})

549

550

(* Search features *)

551

let search_wikipage ~conn str =

552

let escaped_ss = escape str in

553

let sql =

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

557

r#get_all_lst >>

558

List.map

559

(fun row ->

560

let id = int_of_string (List.nth row 0) in

561

let hl = List.nth row 1 in

562

{ sr_id = id;

563

sr_headline = hl;

564

sr_page_descr = Some (List.nth row 2);

565

sr_result_type = SR_page })

566

567

568

let user_query_string =

569

"SELECT id,login,passwd,real_name,email FROM nw.users"

570

571

let user_of_sql_row row =

572

let id = int_of_string (List.nth row 0) in

573

{

574

user_id = id;

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);

579

}

580

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

585

586

587

let query_user ~conn username =

588

let sql =

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

592

None

593

else

594

Some (user_of_sql_row (r#get_tuple_lst 0))

595

596

let add_user ~conn ~login ~passwd ~real_name ~email =

597

let sql =

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)

603

604

let update_user ~conn~user_id ~passwd ~real_name ~email =

605

let sql =

606

"UPDATE nw.users SET "^

607

(match passwd with

608

None -> ""

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)

614

615

616

(* Highest upgrade schema below must match this version *)

617

let nurpawiki_schema_version = 3

618