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.18 2004/10/10 15:33:36 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
37 type pt_t = Page of string | Title of string
39 (* We keep an "internal model" of the page - see build_internal_model ()
43 id : int; (* Original page ID (0 = none). *)
44 pt : pt_t; (* Page of title (only used if id=0) *)
45 description : string; (* Description. *)
46 redirect : string; (* Redirect to ("" = none). *)
47 contents : (string * string * string) list;
48 (* (sectionname, divname, content)
49 * for each section. *)
52 let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
53 let template = get_template dbh hostid "edit.html" in
54 let template_conflict = get_template dbh hostid "edit_conflict.html" in
55 let template_email = get_template dbh hostid "edit_page_email.txt" in
57 (* Workaround bugs in IE, specifically lack of support for <button>
62 let ua = Table.get (Request.headers_in r) "User-Agent" in
63 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
66 Not_found | String.Invalid_string -> false in
67 template#conditional "msie" msie;
69 (* Build the internal model from the parameters passed to the script. *)
70 let build_internal_model () =
71 let id = int_of_string (q#param "id") in
72 let description = q#param "description" in
73 let redirect = q#param "redirect" in
74 let pt = match q#param "pt_type" with
75 "page" -> Page (q#param "pt_value")
76 | "title" -> Title (q#param "pt_value")
77 | _ -> failwith "unknown value for pt_type parameter" in
79 let contents = ref [] in
81 while q#param_exists ("content_" ^ string_of_int !i) do
82 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
83 let content = q#param ("content_" ^ string_of_int !i) in
84 let divname = q#param ("divname_" ^ string_of_int !i) in
85 contents := (sectionname, divname, content) :: !contents;
88 let contents = List.rev !contents in
92 description = description;
94 contents = contents; }
97 (* Check for errors in the model. *)
98 let check_for_errors model =
99 let errors = ref [] in
100 let add_error msg = errors := msg :: !errors in
101 let get_errors () = List.rev !errors in
103 if model.redirect = "" then (
105 if model.contents = [] then
106 add_error ("This page is empty. Use 'Insert new section here' " ^
107 "to write something!");
109 (* Description field? *)
110 if model.description = "" then
111 add_error ("The description field is very important! This field is " ^
112 "used by search engines and directories to describe " ^
113 "what's on this page.");
115 else (* it's a redirect *) (
116 (* Redirect points to a real page? *)
117 let sth = dbh#prepare_cached "select 1 from pages
122 and redirect is null" in
123 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
125 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
127 add_error ("Redirect must point to an ordinary page " ^
128 "(ie. not to a page which is itself a redirect).")
131 (* All sections after the first one have sectionnames? The first
132 * section ONLY is allowed to have an empty title.
134 if model.contents <> [] then
135 List.iter (function (sectionnames, _, _)
136 when string_is_whitespace sectionnames ->
138 ("Every section except the first must have a title.");
140 (List.tl model.contents);
145 (* Various "actions" that can be performed on the model. *)
146 let action_insert model posn item =
147 (* posn = 0 means insert before the first element of the current list. *)
152 | n, x :: xs -> x :: (loop (n-1, xs))
154 let contents = loop (posn, model.contents) in
155 { model with contents = contents }
157 let action_moveup model posn =
158 (* posn = 1 means move up the first element, ie. do nothing
159 * posn = 2 means move up the second element to the first position
167 | 2, x :: y :: xs -> y :: x :: xs
168 | n, x :: xs -> x :: (loop (n-1, xs))
170 let contents = loop (posn, model.contents) in
171 { model with contents = contents }
173 let action_movedn model posn =
174 (* posn = 1 means move down the first element to the second position
181 | 1, x :: y :: xs -> y :: x :: xs
182 | n, x :: xs -> x :: (loop (n-1, xs))
184 let contents = loop (posn, model.contents) in
185 { model with contents = contents }
187 let action_delete model posn =
188 (* posn = 1 means delete the first element *)
194 | n, x :: xs -> x :: (loop (n-1, xs))
196 let contents = loop (posn, model.contents) in
197 { model with contents = contents }
200 (* Convert model to template. *)
201 let model_to_template model template =
202 template#set "id" (string_of_int model.id);
203 template#set "description" model.description;
207 template#set "pt_type" "page";
208 template#set "pt_value" page
210 template#set "pt_type" "title";
211 template#set "pt_value" title);
213 (* Redirects table. *)
214 let sth = dbh#prepare_cached "select url, title from pages
215 where url is not null
217 and hostid = ? and id <> ?
219 sth#execute [`Int hostid; `Int model.id];
220 let table = sth#map (function [`String url; `String title] ->
221 let selected = model.redirect = url in
222 [ "url", Template.VarString url;
223 "title", Template.VarString title;
224 "selected", Template.VarConditional selected ]
225 | _ -> assert false) in
226 template#table "redirects" table;
228 if model.id <> 0 then (
229 (* Need to go to the database to get the title of the page ... *)
230 let sth = dbh#prepare_cached "select title from pages
231 where hostid = ? and id = ?" in
232 sth#execute [`Int hostid; `Int model.id];
233 let title = sth#fetch1string () in
234 template#set "title" title;
237 Page page -> template#set "title" page
238 | Title title -> template#set "title" title
241 let ordering = ref 0 in
244 (fun (sectionname, divname, content) ->
245 incr ordering; let ordering = !ordering in
246 [ "ordering", Template.VarString (string_of_int ordering);
247 "sectionname", Template.VarString sectionname;
248 "divname", Template.VarString divname;
249 "content", Template.VarString content ]) model.contents in
250 template#table "contents" table;
252 (* Check for errors and put those into the template. *)
253 let errors = check_for_errors model in
254 let errors = List.map (fun msg ->
255 [ "error", Template.VarString msg ]) errors in
256 template#table "errors" errors;
257 template#conditional "has_errors" (errors <> [])
260 (* Check if a URL exists in the database. *)
261 let page_exists page =
263 dbh#prepare_cached "select 1 from pages where hostid = ? and url = ?" in
264 sth#execute [`Int hostid; `String page];
266 try sth#fetch1int () = 1 with Not_found -> false
269 (* Begin editing a page, pulling the page out of the database and building
272 let begin_editing page =
273 (* Pull out the page itself from the database. *)
274 let sth = dbh#prepare_cached "select id, title, description,
275 coalesce (redirect, '')
277 where hostid = ? and url = ?" in
278 sth#execute [`Int hostid; `String page];
280 let pageid, title, description, redirect =
281 match sth#fetch1 () with
282 [`Int pageid; `String title; `String description; `String redirect]->
283 pageid, title, description, redirect
284 | _ -> assert false in
286 (* Get the sections. *)
287 let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
289 coalesce (divname, '')
292 order by ordering" in
293 sth#execute [`Int pageid];
297 | [`String sectionname; `String content; `String divname] ->
298 sectionname, divname, content
299 | _ -> assert false) in
301 let model = { id = pageid;
303 description = description;
305 contents = contents; } in
307 model_to_template model template
310 (* Begin editing with a blank page, typically a template. *)
311 let begin_editing_new pt =
316 match Wikilib.generate_url_of_title dbh hostid title with
317 Wikilib.GenURL_OK url -> url, title
318 | Wikilib.GenURL_Duplicate url ->
319 q#redirect ("http://" ^ hostname ^ "/" ^ url);
321 | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
322 error ~back_button:true ~title:"Bad page name"
323 q "The page name supplied is too short or invalid.";
326 (* Initial page contents. *)
332 "<b>" ^ title ^ "</b> is " ] in
334 let model = { id = 0;
338 contents = contents } in
340 model_to_template model template
343 let continue_editing () =
344 let model = ref (build_internal_model ()) in
346 (* An "action" parameter? *)
347 let is_action, get_action =
348 let actions = q#params in
349 (* Don't actually care about the value fields ... *)
350 let actions = List.map (fun (str, _) -> str) actions in
351 (* Some of our actions are imagemaps, so parameters like name.x, name.y
352 * need to be changed to name and have resulting duplicates removed.
355 List.filter (fun str ->
356 String.length str > 7 &&
357 String.sub str 0 7 = "action_" &&
358 not (String.ends_with str ".y")) actions in
361 if String.ends_with str ".x" then (
362 let str = String.sub str 0 (String.length str - 2) in
368 let action_type = String.sub str 7 6 in
370 String.sub str 14 (String.length str - 14) in
371 let action_value = int_of_string action_value in
372 action_type, action_value) actions in
374 let is_action typ = List.mem_assoc typ actions in
375 let get_value typ = List.assoc typ actions in
380 if is_action "insert" then (
381 let posn = get_action "insert" in
382 let item = "New section - change this", "", "Write some content here." in
383 model := action_insert !model posn item
384 ) else if is_action "moveup" then (
385 let posn = get_action "moveup" in
386 model := action_moveup !model posn
387 ) else if is_action "movedn" then (
388 let posn = get_action "movedn" in
389 model := action_movedn !model posn
390 ) else if is_action "delete" then (
391 let posn = get_action "delete" in
392 model := action_delete !model posn
395 model_to_template !model template
398 (* Try to save the page. Returns a boolean indicating if the
399 * page was saved successfully.
402 let model = build_internal_model () in
403 let no_errors = [] = check_for_errors model in
405 (* No errors, so we can save the page ... *)
407 (* Get the IP address of the user, if available. *)
409 try `String (Connection.remote_ip (Request.connection r))
410 with Not_found -> `Null in
414 | User (id, _, _) -> `Int id
419 if model.redirect = "" then `Null
420 else `String model.redirect in
423 (* Creating a new page (id = 0)? If so, we're just going to insert
424 * a new row, which is easy.
426 if model.id = 0 then (
427 (* Create the page title or URL. *)
432 match Wikilib.generate_url_of_title dbh hostid title with
433 Wikilib.GenURL_OK url -> url, title
434 | Wikilib.GenURL_Duplicate url ->
435 error ~back_button:true ~title:"Page exists"
436 q ("While you were editing that page, it looks " ^
437 "like another user created the same page.");
440 assert false (* This should have been detected in
444 let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
445 description, logged_ip, logged_user,
447 values (?, ?, ?, ?, ?, ?, ?)" in
448 sth#execute [`Int hostid; `String url; `String title;
449 `String model.description; logged_ip; logged_user;
452 let pageid = sth#serial "pages_id_seq" in
454 (* Create the page contents. *)
455 let sth = dbh#prepare_cached "insert into contents (pageid,
456 ordering, sectionname, divname,
458 values (?, ?, ?, ?, ?)" in
459 let ordering = ref 0 in (* Creating new ordering. *)
460 List.iter (fun (sectionname, divname, content) ->
462 if string_is_whitespace divname then `Null
463 else `String divname in
465 if string_is_whitespace sectionname then `Null
466 else `String sectionname in
467 incr ordering; let ordering = !ordering in
468 sth#execute [`Int pageid; `Int ordering;
469 sectionname; divname;
475 (* Otherwise it's an old page which we're updating. *)
477 (* Pull out fields from the database. *)
478 let sth = dbh#prepare_cached "select creation_date,
479 coalesce (url, url_deleted),
482 where hostid = ? and id = ?" in
483 sth#execute [`Int hostid; `Int model.id];
485 let creation_date, url, title, css =
486 match sth#fetch1 () with
487 [ creation_date; `String url; `String title; css ] ->
488 creation_date, url, title, css
489 | _ -> assert false in
491 (* Has someone else edited this page in the meantime? *)
492 let sth = dbh#prepare_cached "select max(id) from pages
493 where hostid = ? and url = ?" in
494 sth#execute [`Int hostid; `String url];
496 let max_id = sth#fetch1int () in
497 let edited = max_id <> model.id in
500 (* Edited by someone else ... Get the other's changes. *)
502 get_diff dbh hostid url
503 ~old_version:model.id ~version:max_id () in
505 (* Synthesize our own changes. *)
506 let old_page = get_version_for_diff dbh model.id in
508 let css = match css with
509 `Null -> "" | `String css -> css
510 | _ -> assert false in
511 page_for_diff css (List.map (fun (sectionname, _, content) ->
512 sectionname, content) model.contents) in
513 let our_diff = diff_cmd old_page new_page in
515 (* Fill out the conflict template. *)
516 template_conflict#set "other_diff" other_diff;
517 template_conflict#set "our_diff" our_diff;
518 template_conflict#set "old_version" (string_of_int model.id);
519 template_conflict#set "new_version" (string_of_int max_id);
520 template_conflict#set "url" url;
522 q#template template_conflict;
526 (* Defer the pages_redirect_cn constraint because that would
527 * temporarily fail on the next UPDATE.
531 "set constraints pages_redirect_cn, sitemenu_url_cn,
532 page_emails_url_cn, links_from_cn deferred" in
535 (* Mark the old page as deleted. NB. There is a small race
536 * condition here because PostgreSQL doesn't do isolation
537 * properly. If a user tries to visit this page between the
538 * delete and the creation of the new page, then they'll get
539 * a page not found error. (XXX)
541 let sth = dbh#prepare_cached "update pages set url_deleted = url,
543 where hostid = ? and id = ?" in
544 sth#execute [`Int hostid; `Int model.id];
546 (* Create the new page. *)
547 let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
548 description, creation_date, logged_ip,
549 logged_user, redirect, css)
550 values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
551 sth#execute [`Int hostid; `String url; `String title;
552 `String model.description; creation_date; logged_ip;
553 logged_user; redirect; css];
555 (* New page ID <> old page ID model.id. *)
556 let pageid = sth#serial "pages_id_seq" in
558 (* Create the page contents. *)
559 let sth = dbh#prepare_cached "insert into contents (pageid,
560 ordering, sectionname, divname,
562 values (?, ?, ?, ?, ?)" in
563 let ordering = ref 0 in (* Creating new ordering. *)
564 List.iter (fun (sectionname, divname, content) ->
566 if string_is_whitespace divname then `Null
567 else `String divname in
569 if string_is_whitespace sectionname then `Null
570 else `String sectionname in
571 incr ordering; let ordering = !ordering in
572 sth#execute [`Int pageid; `Int ordering;
573 sectionname; divname;
577 (* General email notification of page edits. Send an email to
578 * anyone in the page_emails table who has a confirmed address
579 * and who hasn't received an email already today.
581 let sth = dbh#prepare_cached "select email, opt_out from page_emails
582 where hostid = ? and url = ?
584 and last_sent < current_date" in
585 sth#execute [`Int hostid; `String url];
587 let addrs = sth#map (function [`String email; `String opt_out] ->
589 | _ -> assert false) in
591 if addrs <> [] then (
592 (* Construct the email. *)
593 template_email#set "hostname" hostname;
594 template_email#set "page" url;
597 "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
599 (* Send each email individually (they all have different opt out
602 List.iter (fun (to_addr, opt_out) ->
603 template_email#set "opt_out" opt_out;
604 let body = template_email#to_string in
605 Sendmail.send_mail ~subject
606 ~to_addr:[to_addr] ~body ())
610 (* Update the database to record when these emails were sent. *)
611 let sth = dbh#prepare_cached "update page_emails
612 set last_sent = current_date
613 where hostid = ? and url = ?
614 and pending is null" in
615 sth#execute [`Int hostid; `String url];
620 (* Keep the links table in synch. *)
621 Cocanwiki_links.update_links_for_page dbh hostid url;
623 (* Commit changes to the database. *)
626 (* Email notification, if anyone is listed for this host. *)
627 let subject = "Page " ^ url ^ " has been edited" in
630 (* Prepare the diff between this version and the previous version. *)
631 let diff, _ = get_diff dbh hostid url ~version:pageid () in
632 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
635 email_notify ~body ~subject dbh hostid;
637 (* Redirect back to the URL. *)
638 q#redirect ("http://" ^ hostname ^ "/" ^ url);
646 let sth = dbh#prepare_cached "select url from pages
647 where hostid = ? and id = ?" in
648 sth#execute [`Int hostid; `Int id];
650 ) else if q#param "pt_type" = "page" then
653 (* Create a new page, but the user hits the cancel button. Because
654 * we didn't save where they came from, we now have nowhere to
655 * go. So we redirect to the home page. XXX
659 q#redirect ("http://" ^ hostname ^ "/" ^ url);
663 (* This codes decides where we are in the current editing cycle.
666 * id - if set, then we are in the midst of editing a page.
667 * save - if set, then we want to save the page.
668 * cancel - if set, abandon changes and go back to viewing the page.
669 * action_* - one of the action buttons was set, eg. move up/down.
670 * page - the page URL opened newly for editing, or a template which
672 * title - page doesn't yet exist; create it.
675 try Some (int_of_string (q#param "id")) with Not_found -> None in
677 | None -> (* Begin editing the page. *)
678 if q#param_exists "page" then (
679 let page = q#param "page" in
680 let page = if page = "" then "index" else page in
681 if page_exists page then
684 begin_editing_new (Page page)
686 let title = q#param "title" in
687 begin_editing_new (Title title)
691 if q#param_true "cancel" then
693 if q#param_true "save" then
694 try_save (); (* might fail and fall through ... *)
701 register_script ~restrict:[CanEdit] run