1 (* COCANWIKI - a wiki written in Objective CAML.
2 * Written by Richard W.M. Jones <rich@merjis.com>.
3 * Copyright (C) 2004 Merjis Ltd.
4 * $Id: edit.ml,v 1.15 2004/10/07 11:36:46 rich Exp $
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
16 * You should have received a copy of the GNU General Public License
17 * along with this program; see the file COPYING. If not, write to
18 * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 * Boston, MA 02111-1307, USA.
30 open Cocanwiki_template
32 open Cocanwiki_emailnotify
34 open Cocanwiki_strings
36 (* We keep an "internal model" of the page - see build_internal_model ()
40 id : int; (* Original page ID. *)
41 description : string; (* Description. *)
42 redirect : string; (* Redirect to ("" = none). *)
43 contents : (string * string * string) list;
44 (* (sectionname, divname, content)
45 * for each section. *)
48 let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
49 let template = get_template dbh hostid "edit.html" in
50 let template_conflict = get_template dbh hostid "edit_conflict.html" in
51 let template_email = get_template dbh hostid "edit_page_email.txt" in
53 (* Workaround bugs in IE, specifically lack of support for <button>
58 let ua = Table.get (Request.headers_in r) "User-Agent" in
59 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
62 Not_found | String.Invalid_string -> false in
63 template#conditional "msie" msie;
65 (* Build the internal model from the parameters passed to the script. *)
66 let build_internal_model () =
67 let id = int_of_string (q#param "id") in
68 let description = q#param "description" in
69 let redirect = q#param "redirect" in
71 let contents = ref [] in
73 while q#param_exists ("content_" ^ string_of_int !i) do
74 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
75 let content = q#param ("content_" ^ string_of_int !i) in
76 let divname = q#param ("divname_" ^ string_of_int !i) in
77 contents := (sectionname, divname, content) :: !contents;
80 let contents = List.rev !contents in
83 description = description;
85 contents = contents; }
88 (* Check for errors in the model. *)
89 let check_for_errors model =
90 let errors = ref [] in
91 let add_error msg = errors := msg :: !errors in
92 let get_errors () = List.rev !errors in
94 if model.redirect = "" then (
96 if model.contents = [] then
97 add_error ("This page is empty. Use 'Insert new section here' " ^
98 "to write something!");
100 (* Description field? *)
101 if model.description = "" then
102 add_error ("The description field is very important! This field is " ^
103 "used by search engines and directories to describe " ^
104 "what's on this page.");
106 else (* it's a redirect *) (
107 (* Redirect points to a real page? *)
108 let sth = dbh#prepare_cached "select 1 from pages
113 and redirect is null" in
114 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
116 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
118 add_error ("Redirect must point to an ordinary page " ^
119 "(ie. not to a page which is itself a redirect).")
122 (* All sections after the first one have sectionnames? The first
123 * section ONLY is allowed to have an empty title.
125 if model.contents <> [] then
126 List.iter (function (sectionnames, _, _)
127 when string_is_whitespace sectionnames ->
129 ("Every section except the first must have a title.");
131 (List.tl model.contents);
136 (* Various "actions" that can be performed on the model. *)
137 let action_insert model posn item =
138 (* posn = 0 means insert before the first element of the current list. *)
143 | n, x :: xs -> x :: (loop (n-1, xs))
145 let contents = loop (posn, model.contents) in
146 { model with contents = contents }
148 let action_moveup model posn =
149 (* posn = 1 means move up the first element, ie. do nothing
150 * posn = 2 means move up the second element to the first position
158 | 2, x :: y :: xs -> y :: x :: xs
159 | n, x :: xs -> x :: (loop (n-1, xs))
161 let contents = loop (posn, model.contents) in
162 { model with contents = contents }
164 let action_movedn model posn =
165 (* posn = 1 means move down the first element to the second position
172 | 1, x :: y :: xs -> y :: x :: xs
173 | n, x :: xs -> x :: (loop (n-1, xs))
175 let contents = loop (posn, model.contents) in
176 { model with contents = contents }
178 let action_delete model posn =
179 (* posn = 1 means delete the first element *)
185 | n, x :: xs -> x :: (loop (n-1, xs))
187 let contents = loop (posn, model.contents) in
188 { model with contents = contents }
191 (* Convert model to template. *)
192 let model_to_template model template =
193 template#set "id" (string_of_int model.id);
194 template#set "description" model.description;
196 (* Redirects table. *)
197 let sth = dbh#prepare_cached "select url, title from pages
198 where url is not null
200 and hostid = ? and id <> ?
202 sth#execute [`Int hostid; `Int model.id];
203 let table = sth#map (function [`String url; `String title] ->
204 let selected = model.redirect = url in
205 [ "url", Template.VarString url;
206 "title", Template.VarString title;
207 "selected", Template.VarConditional selected ]
208 | _ -> assert false) in
209 template#table "redirects" table;
211 (* Need to go to the database to get the title of the page ... *)
212 let sth = dbh#prepare_cached "select title from pages
213 where hostid = ? and id = ?" in
214 sth#execute [`Int hostid; `Int model.id];
215 let title = sth#fetch1string () in
216 template#set "title" title;
218 let ordering = ref 0 in
221 (fun (sectionname, divname, content) ->
222 incr ordering; let ordering = !ordering in
223 [ "ordering", Template.VarString (string_of_int ordering);
224 "sectionname", Template.VarString sectionname;
225 "divname", Template.VarString divname;
226 "content", Template.VarString content ]) model.contents in
227 template#table "contents" table;
229 (* Check for errors and put those into the template. *)
230 let errors = check_for_errors model in
231 let errors = List.map (fun msg ->
232 [ "error", Template.VarString msg ]) errors in
233 template#table "errors" errors;
234 template#conditional "has_errors" (errors <> [])
237 (* Begin editing a page, pulling the page out of the database and building
240 let begin_editing page =
241 (* Pull out the page itself from the database. *)
242 let sth = dbh#prepare_cached "select id, title, description,
243 coalesce (redirect, '')
245 where hostid = ? and url = ?" in
246 sth#execute [`Int hostid; `String page];
248 let pageid, title, description, redirect =
249 match sth#fetch1 () with
250 [`Int pageid; `String title; `String description; `String redirect]->
251 pageid, title, description, redirect
252 | _ -> assert false in
254 (* Get the sections. *)
255 let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
257 coalesce (divname, '')
260 order by ordering" in
261 sth#execute [`Int pageid];
265 | [`String sectionname; `String content; `String divname] ->
266 sectionname, divname, content
267 | _ -> assert false) in
269 let model = { id = pageid;
270 description = description;
272 contents = contents; } in
274 model_to_template model template
277 let continue_editing () =
278 let model = ref (build_internal_model ()) in
280 (* An "action" parameter? *)
281 let is_action, get_action =
282 let actions = q#params in
283 (* Don't actually care about the value fields ... *)
284 let actions = List.map (fun (str, _) -> str) actions in
285 (* Some of our actions are imagemaps, so parameters like name.x, name.y
286 * need to be changed to name and have resulting duplicates removed.
289 List.filter (fun str ->
290 String.length str > 7 &&
291 String.sub str 0 7 = "action_" &&
292 not (String.ends_with str ".y")) actions in
295 if String.ends_with str ".x" then (
296 let str = String.sub str 0 (String.length str - 2) in
302 let action_type = String.sub str 7 6 in
304 String.sub str 14 (String.length str - 14) in
305 let action_value = int_of_string action_value in
306 action_type, action_value) actions in
308 let is_action typ = List.mem_assoc typ actions in
309 let get_value typ = List.assoc typ actions in
314 if is_action "insert" then (
315 let posn = get_action "insert" in
316 let item = "New section - change this", "", "Write some content here." in
317 model := action_insert !model posn item
318 ) else if is_action "moveup" then (
319 let posn = get_action "moveup" in
320 model := action_moveup !model posn
321 ) else if is_action "movedn" then (
322 let posn = get_action "movedn" in
323 model := action_movedn !model posn
324 ) else if is_action "delete" then (
325 let posn = get_action "delete" in
326 model := action_delete !model posn
329 model_to_template !model template
332 (* Try to save the page. Returns a boolean indicating if the
333 * page was saved successfully.
336 let model = build_internal_model () in
337 let no_errors = [] = check_for_errors model in
339 (* No errors, so we can save the page ... *)
341 (* Pull out fields from the database. *)
342 let sth = dbh#prepare_cached "select creation_date,
343 coalesce (url, url_deleted),
346 where hostid = ? and id = ?" in
347 sth#execute [`Int hostid; `Int model.id];
349 let creation_date, url, title, css =
350 match sth#fetch1 () with
351 [ creation_date; `String url; `String title; css ] ->
352 creation_date, url, title, css
353 | _ -> assert false in
355 (* Has someone else edited this page in the meantime? *)
356 let sth = dbh#prepare_cached "select max(id) from pages
357 where hostid = ? and url = ?" in
358 sth#execute [`Int hostid; `String url];
360 let max_id = sth#fetch1int () in
361 let edited = max_id <> model.id in
364 (* Edited by someone else ... Get the other's changes. *)
366 get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
368 (* Synthesize our own changes. *)
369 let old_page = get_version_for_diff dbh model.id in
371 let css = match css with
372 `Null -> "" | `String css -> css
373 | _ -> assert false in
374 page_for_diff css (List.map (fun (sectionname, _, content) ->
375 sectionname, content) model.contents) in
376 let our_diff = diff_cmd old_page new_page in
378 (* Fill out the conflict template. *)
379 template_conflict#set "other_diff" other_diff;
380 template_conflict#set "our_diff" our_diff;
381 template_conflict#set "old_version" (string_of_int model.id);
382 template_conflict#set "new_version" (string_of_int max_id);
383 template_conflict#set "url" url;
385 q#template template_conflict;
389 (* Defer the pages_redirect_cn constraint because that would
390 * temporarily fail on the next UPDATE.
394 "set constraints pages_redirect_cn, sitemenu_url_cn,
395 page_emails_url_cn, links_from_cn deferred" in
398 (* Mark the old page as deleted. NB. There is a small race
399 * condition here because PostgreSQL doesn't do isolation
400 * properly. If a user tries to visit this page between the
401 * delete and the creation of the new page, then they'll get
402 * a page not found error. (XXX)
404 let sth = dbh#prepare_cached "update pages set url_deleted = url,
406 where hostid = ? and id = ?" in
407 sth#execute [`Int hostid; `Int model.id];
409 (* Get the IP address of the user, if available. *)
411 try `String (Connection.remote_ip (Request.connection r))
412 with Not_found -> `Null in
416 | User (id, _, _) -> `Int id
420 let redirect = if model.redirect = "" then `Null
421 else `String model.redirect in
423 (* Create the new page. *)
424 let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
425 description, creation_date, logged_ip,
426 logged_user, redirect, css)
427 values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
428 sth#execute [`Int hostid; `String url; `String title;
429 `String model.description; creation_date; logged_ip;
430 logged_user; redirect; css];
432 (* New page ID <> old page ID model.id. *)
433 let pageid = sth#serial "pages_id_seq" in
435 (* Create the page contents. *)
436 let sth = dbh#prepare_cached "insert into contents (pageid,
437 ordering, sectionname, divname, content)
438 values (?, ?, ?, ?, ?)" in
439 let ordering = ref 0 in (* Creating new ordering. *)
440 List.iter (fun (sectionname, divname, content) ->
442 if string_is_whitespace divname then `Null
443 else `String divname in
445 if string_is_whitespace sectionname then `Null
446 else `String sectionname in
447 incr ordering; let ordering = !ordering in
448 sth#execute [`Int pageid; `Int ordering;
449 sectionname; divname;
453 (* Keep the links table in synch. *)
454 Cocanwiki_links.update_links_for_page dbh hostid url;
456 (* Commit changes to the database. *)
459 (* Email notification, if anyone is listed for this host. *)
460 let subject = "Page " ^ url ^ " has been edited" in
463 (* Prepare the diff between this version and the previous version. *)
464 let diff, _ = get_diff dbh hostid url ~version:pageid () in
465 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
468 email_notify ~body ~subject dbh hostid;
470 (* General email notification of page edits. Send an email to
471 * anyone in the page_emails table who has a confirmed address
472 * and who hasn't received an email already today.
474 let sth = dbh#prepare_cached "select email, opt_out from page_emails
475 where hostid = ? and url = ?
477 and last_sent < current_date" in
478 sth#execute [`Int hostid; `String url];
480 let addrs = sth#map (function [`String email; `String opt_out] ->
482 | _ -> assert false) in
484 if addrs <> [] then (
485 (* Construct the email. *)
486 template_email#set "hostname" hostname;
487 template_email#set "page" url;
490 "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
492 (* Send each email individually (they all have different opt out
495 List.iter (fun (to_addr, opt_out) ->
496 template_email#set "opt_out" opt_out;
497 let body = template_email#to_string in
498 Sendmail.send_mail ~subject ~to_addr:[to_addr] ~body ())
502 (* Update the database to record when these emails were sent. *)
503 let sth = dbh#prepare_cached "update page_emails
504 set last_sent = current_date
505 where hostid = ? and url = ?
506 and pending is null" in
507 sth#execute [`Int hostid; `String url];
511 let buttons = [ ok_button ("/" ^ url) ] in
512 ok ~title:"Saved" ~buttons
513 q "The page was saved."
520 let sth = dbh#prepare_cached "select url from pages
521 where hostid = ? and id = ?" in
522 sth#execute [`Int hostid; `Int id];
523 let url = sth#fetch1string () in
525 q#redirect ("http://" ^ hostname ^ "/" ^ url)
528 (* This codes decides where we are in the current editing cycle.
531 * id - if set, then we are in the midst of editing a page.
532 * save - if set, then we want to save the page.
533 * cancel - if set, abandon changes and go back to viewing the page.
534 * action_* - one of the action buttons was set, eg. move up/down.
535 * page - the page URL opened newly for editing.
538 let id = int_of_string (q#param "id") in
539 if q#param_true "cancel" then (
543 if q#param_true "save" then (
544 let ok = try_save () in
545 if ok then return () (* ... else fall through *)
547 continue_editing () (* Processes the action, if any. *)
550 let page = q#param "page" in
551 let page = if page = "" then "index" else page in
557 register_script ~restrict:[CanEdit] run