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.21 2004/10/21 19:54:29 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 let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
38 let template = get_template dbh hostid "edit.html" in
39 let template_conflict = get_template dbh hostid "edit_conflict.html" in
40 let template_email = get_template dbh hostid "edit_page_email.txt" in
42 (* Workaround bugs in IE, specifically lack of support for <button>
47 let ua = Table.get (Request.headers_in r) "User-Agent" in
48 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
51 Not_found | String.Invalid_string -> false in
52 template#conditional "msie" msie;
54 (* Build the internal model from the parameters passed to the script. *)
55 let build_internal_model () =
56 let id = int_of_string (q#param "id") in
57 let description = q#param "description" in
58 let redirect = q#param "redirect" in
59 let pt = match q#param "pt_type" with
60 "page" -> Page (q#param "pt_value")
61 | "title" -> Title (q#param "pt_value")
62 | _ -> failwith "unknown value for pt_type parameter" in
64 let contents = ref [] in
66 while q#param_exists ("content_" ^ string_of_int !i) do
67 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
68 let content = q#param ("content_" ^ string_of_int !i) in
69 let divname = q#param ("divname_" ^ string_of_int !i) in
70 contents := (sectionname, divname, content) :: !contents;
73 let contents = List.rev !contents in
77 description = description;
79 contents = contents; }
82 (* Check for errors in the model. *)
83 let check_for_errors model =
84 let errors = ref [] in
85 let add_error msg = errors := msg :: !errors in
86 let get_errors () = List.rev !errors in
88 if model.redirect = "" then (
90 if model.contents = [] then
91 add_error ("This page is empty. Use 'Insert new section here' " ^
92 "to write something!");
94 (* Description field? *)
95 if model.description = "" then
96 add_error ("The description field is very important! This field is " ^
97 "used by search engines and directories to describe " ^
98 "what's on this page.");
100 else (* it's a redirect *) (
101 (* Redirect points to a real page? *)
102 let sth = dbh#prepare_cached "select 1 from pages
107 and redirect is null" in
108 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
110 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
112 add_error ("Redirect must point to an ordinary page " ^
113 "(ie. not to a page which is itself a redirect).")
116 (* All sections after the first one have sectionnames? The first
117 * section ONLY is allowed to have an empty title.
119 if model.contents <> [] then
120 List.iter (function (sectionnames, _, _)
121 when string_is_whitespace sectionnames ->
123 ("Every section except the first must have a title.");
125 (List.tl model.contents);
130 (* Various "actions" that can be performed on the model. *)
131 let action_insert model posn item =
132 (* posn = 0 means insert before the first element of the current list. *)
137 | n, x :: xs -> x :: (loop (n-1, xs))
139 let contents = loop (posn, model.contents) in
140 { model with contents = contents }
142 let action_moveup model posn =
143 (* posn = 1 means move up the first element, ie. do nothing
144 * posn = 2 means move up the second element to the first position
152 | 2, x :: y :: xs -> y :: x :: xs
153 | n, x :: xs -> x :: (loop (n-1, xs))
155 let contents = loop (posn, model.contents) in
156 { model with contents = contents }
158 let action_movedn model posn =
159 (* posn = 1 means move down the first element to the second position
166 | 1, x :: y :: xs -> y :: x :: xs
167 | n, x :: xs -> x :: (loop (n-1, xs))
169 let contents = loop (posn, model.contents) in
170 { model with contents = contents }
172 let action_delete model posn =
173 (* posn = 1 means delete the first element *)
179 | n, x :: xs -> x :: (loop (n-1, xs))
181 let contents = loop (posn, model.contents) in
182 { model with contents = contents }
185 (* Convert model to template. *)
186 let model_to_template model template =
187 template#set "id" (string_of_int model.id);
188 template#set "description" model.description;
192 template#set "pt_type" "page";
193 template#set "pt_value" page
195 template#set "pt_type" "title";
196 template#set "pt_value" title);
198 (* Redirects table. *)
199 let sth = dbh#prepare_cached "select url, title from pages
200 where url is not null
202 and hostid = ? and id <> ?
204 sth#execute [`Int hostid; `Int model.id];
205 let table = sth#map (function [`String url; `String title] ->
206 let selected = model.redirect = url in
207 [ "url", Template.VarString url;
208 "title", Template.VarString title;
209 "selected", Template.VarConditional selected ]
210 | _ -> assert false) in
211 template#table "redirects" table;
213 if model.id <> 0 then (
214 (* Need to go to the database to get the title of the page ... *)
215 let sth = dbh#prepare_cached "select title from pages
216 where hostid = ? and id = ?" in
217 sth#execute [`Int hostid; `Int model.id];
218 let title = sth#fetch1string () in
219 template#set "title" title;
222 Page page -> template#set "title" page
223 | Title title -> template#set "title" title
226 let ordering = ref 0 in
229 (fun (sectionname, divname, content) ->
230 incr ordering; let ordering = !ordering in
231 [ "ordering", Template.VarString (string_of_int ordering);
232 "sectionname", Template.VarString sectionname;
233 "divname", Template.VarString divname;
234 "content", Template.VarString content ]) model.contents in
235 template#table "contents" table;
237 (* Check for errors and put those into the template. *)
238 let errors = check_for_errors model in
239 let errors = List.map (fun msg ->
240 [ "error", Template.VarString msg ]) errors in
241 template#table "errors" errors;
242 template#conditional "has_errors" (errors <> [])
245 (* Check if a URL exists in the database. *)
246 let page_exists page =
248 dbh#prepare_cached "select 1 from pages where hostid = ? and url = ?" in
249 sth#execute [`Int hostid; `String page];
251 try sth#fetch1int () = 1 with Not_found -> false
254 (* Begin editing a page, pulling the page out of the database and building
257 let begin_editing page =
258 let model = load_page dbh hostid ~url:page () in
259 model_to_template model template
262 (* Begin editing with a blank page, typically a template. *)
263 let begin_editing_new pt =
268 match Wikilib.generate_url_of_title dbh hostid title with
269 Wikilib.GenURL_OK url -> url, title
270 | Wikilib.GenURL_Duplicate url ->
271 q#redirect ("http://" ^ hostname ^ "/" ^ url);
273 | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
274 error ~back_button:true ~title:"Bad page name"
275 q "The page name supplied is too short or invalid.";
278 let model = match pt with
279 Page url -> new_page pt
280 | Title title -> new_page_with_title title in
282 model_to_template model template
285 let continue_editing () =
286 let model = ref (build_internal_model ()) in
288 (* An "action" parameter? *)
289 let is_action, get_action =
290 let actions = q#params in
291 (* Don't actually care about the value fields ... *)
292 let actions = List.map (fun (str, _) -> str) actions in
293 (* Some of our actions are imagemaps, so parameters like name.x, name.y
294 * need to be changed to name and have resulting duplicates removed.
297 List.filter (fun str ->
298 String.length str > 7 &&
299 String.sub str 0 7 = "action_" &&
300 not (String.ends_with str ".y")) actions in
303 if String.ends_with str ".x" then (
304 let str = String.sub str 0 (String.length str - 2) in
310 let action_type = String.sub str 7 6 in
312 String.sub str 14 (String.length str - 14) in
313 let action_value = int_of_string action_value in
314 action_type, action_value) actions in
316 let is_action typ = List.mem_assoc typ actions in
317 let get_value typ = List.assoc typ actions in
322 if is_action "insert" then (
323 let posn = get_action "insert" in
324 let item = "New section - change this", "", "Write some content here." in
325 model := action_insert !model posn item
326 ) else if is_action "moveup" then (
327 let posn = get_action "moveup" in
328 model := action_moveup !model posn
329 ) else if is_action "movedn" then (
330 let posn = get_action "movedn" in
331 model := action_movedn !model posn
332 ) else if is_action "delete" then (
333 let posn = get_action "delete" in
334 model := action_delete !model posn
337 model_to_template !model template
340 (* Try to save the page. Returns a boolean indicating if the
341 * page was saved successfully.
344 let model = build_internal_model () in
345 let no_errors = [] = check_for_errors model in
347 (* No errors, so we can save the page ... *)
351 save_page dbh hostid ~user ~r model
354 error ~back_button:true ~title:"Page exists"
355 q ("While you were editing that page, it looks " ^
356 "like another user created the same page.");
359 | SaveConflict (new_version, old_version, url, css) ->
360 (* Edited by someone else ... Get the other's changes. *)
362 get_diff dbh hostid url
363 ~old_version ~version:new_version () in
365 (* Synthesize our own changes. *)
366 let old_page = get_version_for_diff dbh old_version in
368 page_for_diff css (List.map (fun (sectionname, _, content) ->
369 sectionname, content) model.contents) in
370 let our_diff = diff_cmd old_page new_page in
372 (* Fill out the conflict template. *)
373 template_conflict#set "other_diff" other_diff;
374 template_conflict#set "our_diff" our_diff;
375 template_conflict#set "old_version" (string_of_int old_version);
376 template_conflict#set "new_version" (string_of_int new_version);
377 template_conflict#set "url" url;
379 q#template template_conflict;
382 (* General email notification of page edits. Send an email to
383 * anyone in the page_emails table who has a confirmed address
384 * and who hasn't received an email already today.
386 let sth = dbh#prepare_cached "select email, opt_out from page_emails
387 where hostid = ? and url = ?
389 and last_sent < current_date" in
390 sth#execute [`Int hostid; `String url];
392 let addrs = sth#map (function [`String email; `String opt_out] ->
394 | _ -> assert false) in
396 if addrs <> [] then (
397 (* Construct the email. *)
398 template_email#set "hostname" hostname;
399 template_email#set "page" url;
402 "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
404 (* Send each email individually (they all have different opt out
407 List.iter (fun (to_addr, opt_out) ->
408 template_email#set "opt_out" opt_out;
409 let body = template_email#to_string in
410 Sendmail.send_mail ~subject
411 ~to_addr:[to_addr] ~body ())
415 (* Update the database to record when these emails were sent. *)
416 let sth = dbh#prepare_cached "update page_emails
417 set last_sent = current_date
418 where hostid = ? and url = ?
419 and pending is null" in
420 sth#execute [`Int hostid; `String url];
422 (* Commit changes to the database. *)
425 (* Email notification, if anyone is listed for this host. *)
426 let subject = "Page " ^ url ^ " has been edited" in
429 (* Prepare the diff between this version and the previous version. *)
430 let diff, _ = get_diff dbh hostid url ~version:pageid () in
431 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
434 email_notify ~body ~subject ~user dbh hostid;
436 (* Redirect back to the URL. *)
437 q#redirect ("http://" ^ hostname ^ "/" ^ url);
445 let sth = dbh#prepare_cached "select url from pages
446 where hostid = ? and id = ?" in
447 sth#execute [`Int hostid; `Int id];
449 ) else if q#param "pt_type" = "page" then
452 (* Create a new page, but the user hits the cancel button. Because
453 * we didn't save where they came from, we now have nowhere to
454 * go. So we redirect to the home page. XXX
458 q#redirect ("http://" ^ hostname ^ "/" ^ url);
462 (* This codes decides where we are in the current editing cycle.
465 * id - if set, then we are in the midst of editing a page.
466 * save - if set, then we want to save the page.
467 * cancel - if set, abandon changes and go back to viewing the page.
468 * action_* - one of the action buttons was set, eg. move up/down.
469 * page - the page URL opened newly for editing, or a template which
471 * title - page doesn't yet exist; create it.
474 try Some (int_of_string (q#param "id")) with Not_found -> None in
476 | None -> (* Begin editing the page. *)
477 if q#param_exists "page" then (
478 let page = q#param "page" in
479 let page = if page = "" then "index" else page in
480 if page_exists page then
483 begin_editing_new (Page page)
485 let title = q#param "title" in
486 begin_editing_new (Title title)
490 if q#param_true "cancel" then
492 if q#param_true "save" then
493 try_save (); (* might fail and fall through ... *)
500 register_script ~restrict:[CanEdit] run