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.38 2006/12/06 09:46:57 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 hostid {hostname = hostname} user =
38 let template = get_template r dbh hostid "edit.html" in
39 let template_conflict = get_template r dbh hostid "edit_conflict.html" in
40 let template_email = get_template r 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 | 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 = Int32.of_string (q#param "id") in
57 let description = q#param "description" in
58 let keywords = q#param "keywords" in
60 if string_is_whitespace keywords then None else Some keywords in
61 let noodp = match q#param "noodp" with
65 | _ -> failwith "unknown value for noodp parameter" in
66 let redirect = q#param "redirect" in
68 if string_is_whitespace redirect then None else Some redirect in
69 let pt = match q#param "pt_type" with
70 | "page" -> Page (q#param "pt_value")
71 | "title" -> Title (q#param "pt_value")
72 | _ -> failwith "unknown value for pt_type parameter" in
74 let contents = ref [] in
76 while q#param_exists ("content_" ^ string_of_int !i) do
77 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
79 if string_is_whitespace sectionname then None else Some sectionname in
80 let content = q#param ("content_" ^ string_of_int !i) in
81 let divname = q#param ("divname_" ^ string_of_int !i) in
83 if string_is_whitespace divname then None else Some divname in
84 let divclass = q#param ("divclass_" ^ string_of_int !i) in
86 if string_is_whitespace divclass then None else Some divclass in
87 let jsgo = q#param ("jsgo_" ^ string_of_int !i) in
88 let jsgo = if string_is_whitespace jsgo then None else Some jsgo in
89 contents := (sectionname, divname, divclass, jsgo, content) :: !contents;
92 let contents = List.rev !contents in
96 description = description;
100 contents_ = contents; }
103 (* Check for errors in the model. *)
104 let check_for_errors model =
105 let errors = ref [] in
106 let add_error msg = errors := msg :: !errors in
107 let get_errors () = List.rev !errors in
109 (match model.redirect with
112 if model.contents_ = [] then
113 add_error ("This page is empty. Use 'Insert new section here' " ^
114 "to write something!");
116 (* Description field? *)
117 if model.description = "" then
118 add_error ("The description field is very important! " ^
120 "used by search engines and directories to describe " ^
121 "what's on this page.");
124 (* Redirect points to a real page? *)
126 let model_id = model.id in
129 where hostid = $hostid and url is not null
130 and url = $redirect and id <> $model_id
131 and redirect is null" in
133 let ok = rows = [Some 1l] in
135 add_error ("Redirect must point to an ordinary page " ^
136 "(ie. not to a page which is itself a redirect).")
139 (* All sections after the first one have sectionnames? The first
140 * section ONLY is allowed to have an empty title.
142 if model.contents_ <> [] then
144 | (None, _, _, _, _) ->
146 "Every section except the first must have a title.";
148 (List.tl model.contents_);
150 (* There are two constraints on any non-null jsgo's:
151 * (1) Must only be present if divname or divclass is non-null.
152 * (2) Must point to a valid URL on the current host.
156 | (_, None, None, Some _, _) ->
158 "Javascript onclick can only be used with a CSS id/class."
159 | (_, _, _, Some jsgo, _) ->
161 PGSQL(dbh) "select 1 from pages
162 where hostid = $hostid
165 and redirect is null" in
166 let ok = rows = [Some 1l] in
168 add_error ("Javascript onclick must point to an ordinary page " ^
169 "on the current site (ie. not to a redirect). " ^
170 "Do not put '/' at the beginning of the URL.")
177 (* Various "actions" that can be performed on the model. *)
178 let action_insert model posn item =
179 (* posn = 0 means insert before the first element of the current list. *)
184 | n, x :: xs -> x :: (loop (n-1, xs))
186 let contents = loop (posn, model.contents_) in
187 { model with contents_ = contents }
189 let action_moveup model posn =
190 (* posn = 1 means move up the first element, ie. do nothing
191 * posn = 2 means move up the second element to the first position
199 | 2, x :: y :: xs -> y :: x :: xs
200 | n, x :: xs -> x :: (loop (n-1, xs))
202 let contents = loop (posn, model.contents_) in
203 { model with contents_ = contents }
205 let action_movedn model posn =
206 (* posn = 1 means move down the first element to the second position
213 | 1, x :: y :: xs -> y :: x :: xs
214 | n, x :: xs -> x :: (loop (n-1, xs))
216 let contents = loop (posn, model.contents_) in
217 { model with contents_ = contents }
219 let action_delete model posn =
220 (* posn = 1 means delete the first element *)
226 | n, x :: xs -> x :: (loop (n-1, xs))
228 let contents = loop (posn, model.contents_) in
229 { model with contents_ = contents }
232 (* Convert model to template. *)
233 let model_to_template model template =
234 template#set "id" (Int32.to_string model.id);
235 template#set "description" model.description;
236 template#set "keywords"
237 (match model.keywords with None -> "" | Some keywords -> keywords);
239 template#conditional "noodp_null" false;
240 template#conditional "noodp_true" false;
241 template#conditional "noodp_false" false;
242 (match model.noodp with
243 | None -> template#conditional "noodp_null" true
244 | Some true -> template#conditional "noodp_true" true
245 | Some false -> template#conditional "noodp_false" true);
249 template#set "pt_type" "page";
250 template#set "pt_value" page
252 template#set "pt_type" "title";
253 template#set "pt_value" title);
255 (* Redirects table. *)
257 let model_id = model.id in
259 "select url, title from pages
260 where url is not null
262 and hostid = $hostid and id <> $model_id
264 let table = List.map (
266 let url = Option.get url in
267 let is_index = url = "index" in
268 let selected = model.redirect = Some url in
269 [ "url", Template.VarString url;
270 "title", Template.VarString title;
271 "selected", Template.VarConditional selected;
272 "is_index", Template.VarConditional is_index ]
274 template#table "redirects" table;
276 if model.id <> 0l then (
277 (* Need to go to the database to get the title of the page ... *)
279 let model_id = model.id in
281 "select title from pages
282 where hostid = $hostid and id = $model_id" in
283 let title = List.hd rows in
284 template#set "title" title;
287 | Page page -> template#set "title" page
288 | Title title -> template#set "title" title
291 let ordering = ref 0 in
294 (fun (sectionname, divname, divclass, jsgo, content) ->
295 incr ordering; let ordering = Int32.of_int !ordering in
296 let sectionname = match sectionname with None -> "" | Some s -> s in
297 let divname = match divname with None -> "" | Some s -> s in
298 let divclass = match divclass with None -> "" | Some s -> s in
299 let jsgo = match jsgo with None -> "" | Some s -> s in
300 [ "ordering", Template.VarString (Int32.to_string ordering);
301 "sectionname", Template.VarString sectionname;
302 "divname", Template.VarString divname;
303 "divclass", Template.VarString divclass;
304 "jsgo", Template.VarString jsgo;
305 "content", Template.VarString content ]) model.contents_ in
306 template#table "contents" table;
308 (* Check for errors and put those into the template. *)
309 let errors = check_for_errors model in
310 let errors = List.map (fun msg ->
311 [ "error", Template.VarString msg ]) errors in
312 template#table "errors" errors;
313 template#conditional "has_errors" (errors <> [])
316 (* Check if a URL exists in the database. *)
317 let page_exists page =
318 let rows = PGSQL(dbh)
319 "select 1 from pages where hostid = $hostid and url = $page" in
323 (* Begin editing a page, pulling the page out of the database and building
326 let begin_editing page =
327 let model = load_page dbh hostid ~url:page () in
328 model_to_template model template
331 (* Begin editing with a blank page, typically a template. *)
332 let begin_editing_new pt =
333 (* Just check the title. *)
337 match Wikilib.generate_url_of_title r dbh hostid title with
338 | Wikilib.GenURL_OK url -> ()
339 | Wikilib.GenURL_Duplicate url ->
340 q#redirect ("http://" ^ hostname ^ "/" ^ url)
341 | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
342 error ~back_button:true ~title:"Bad page name"
344 "The page name supplied is too short or invalid.";
348 let model = match pt with
349 | Page url -> new_page pt
350 | Title title -> new_page_with_title title in
352 model_to_template model template
355 let continue_editing () =
356 let model = ref (build_internal_model ()) in
358 (* An "action" parameter? *)
359 let is_action, get_action =
360 let actions = q#params in
361 (* Don't actually care about the value fields ... *)
362 let actions = List.map (fun (str, _) -> str) actions in
363 (* Some of our actions are imagemaps, so parameters like name.x, name.y
364 * need to be changed to name and have resulting duplicates removed.
367 List.filter (fun str ->
368 String.length str > 7 &&
369 String.sub str 0 7 = "action_" &&
370 not (String.ends_with str ".y")) actions in
373 if String.ends_with str ".x" then (
374 let str = String.sub str 0 (String.length str - 2) in
380 let action_type = String.sub str 7 6 in
382 String.sub str 14 (String.length str - 14) in
383 let action_value = int_of_string action_value in
384 action_type, action_value) actions in
386 let is_action typ = List.mem_assoc typ actions in
387 let get_value typ = List.assoc typ actions in
392 if is_action "insert" then (
393 let posn = get_action "insert" in
395 Some "The title of this section",
397 "Write something here." in
398 model := action_insert !model posn item
399 ) else if is_action "moveup" then (
400 let posn = get_action "moveup" in
401 model := action_moveup !model posn
402 ) else if is_action "movedn" then (
403 let posn = get_action "movedn" in
404 model := action_movedn !model posn
405 ) else if is_action "delete" then (
406 let posn = get_action "delete" in
407 model := action_delete !model posn
410 model_to_template !model template
413 (* Try to save the page. Only returns if there were errors in
417 let model = build_internal_model () in
418 let no_errors = [] = check_for_errors model in
420 (* No errors, so we can save the page ... *)
423 save_page r dbh hostid ~user model
426 error ~back_button:true ~title:"Page exists"
428 ("While you were editing that page, it looks " ^
429 "like another user created the same page.");
432 | SaveConflict (new_version, old_version, url, css) ->
433 (* Edited by someone else ... Get the other's changes. *)
435 get_diff dbh hostid url ~old_version ~version:new_version () in
437 (* Synthesize our own changes. *)
438 let old_page = get_version_for_diff dbh old_version in
440 page_for_diff model css in
441 let our_diff = diff_cmd old_page new_page in
443 (* Fill out the conflict template. *)
444 template_conflict#set "other_diff" other_diff;
445 template_conflict#set "our_diff" our_diff;
446 template_conflict#set "old_version"
447 (Int32.to_string old_version);
448 template_conflict#set "new_version"
449 (Int32.to_string new_version);
450 template_conflict#set "url" url;
452 q#template template_conflict;
455 (* General email notification of page edits. Send an email to
456 * anyone in the page_emails table who has a confirmed address
457 * and who hasn't received an email already today.
459 let rows = PGSQL(dbh)
460 "select email, opt_out from page_emails
461 where hostid = $hostid and url = $url
463 and last_sent < current_date" in
464 let addrs = List.map (
465 fun (email, opt_out) ->
469 if addrs <> [] then (
470 (* Construct the email. *)
471 template_email#set "hostname" hostname;
472 template_email#set "page" url;
475 "Site notice: " ^ hostname ^ "/" ^ url ^ " has been updated" in
478 "text/plain", ["charset", Mimestring.mk_param "UTF-8"] in
480 (* Send each email individually (they all have different opt out
483 List.iter (fun (to_addr, opt_out) ->
484 template_email#set "opt_out" opt_out;
485 let body = template_email#to_string in
487 let msg = Netsendmail.compose ~to_addrs:["", to_addr]
488 ~subject ~content_type body in
489 Netsendmail.sendmail msg)
493 (* Update the database to record when these emails were sent. *)
496 set last_sent = current_date
497 where hostid = $hostid and url = $url
498 and pending is null";
500 (* Commit changes to the database. *)
503 (* Email notification, if anyone is listed for this host. *)
504 let subject = "Page " ^ url ^ " has been edited" in
507 (* Prepare the diff between this version and the previous version. *)
508 let diff, _ = get_diff dbh hostid url ~version:pageid () in
509 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
512 email_notify ~body ~subject ~user dbh hostid;
514 (* Redirect back to the URL. *)
515 q#redirect ("http://" ^ hostname ^ "/" ^ url)
522 let rows = PGSQL(dbh)
523 "select coalesce (url, url_deleted)
525 where hostid = $hostid and id = $id" in
526 Option.get (List.hd rows)
527 ) else if q#param "pt_type" = "page" then
530 (* Create a new page, but the user hits the cancel button. Because
531 * we didn't save where they came from, we now have nowhere to
532 * go. So we redirect to the home page. XXX
536 q#redirect ("http://" ^ hostname ^ "/" ^ url)
539 (* This code decides where we are in the current editing cycle.
542 * id - if set, then we are in the midst of editing a page.
543 * save - if set, then we want to save the page.
544 * cancel - if set, abandon changes and go back to viewing the page.
545 * action_* - one of the action buttons was set, eg. move up/down.
546 * page - the page URL opened newly for editing, or a template which
548 * title - page doesn't yet exist; create it.
551 try Some (Int32.of_string (q#param "id")) with Not_found -> None in
553 | None -> (* Begin editing the page. *)
554 if q#param_exists "page" then (
555 let page = q#param "page" in
556 let page = if page = "" then "index" else page in
557 if page_exists page then
560 begin_editing_new (Page page)
562 let title = q#param "title" in
563 begin_editing_new (Title title)
567 if q#param_true "cancel" then
569 if q#param_true "save" then
570 try_save (); (* might fail and fall through ... *)
577 register_script ~restrict:[CanEdit] run