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.8 2004/09/09 12:21:22 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 } _ =
49 let template = get_template dbh hostid "edit.html" in
50 let template_conflict = get_template dbh hostid "edit_conflict.html" in
52 (* Workaround bugs in IE, specifically lack of support for <button>
57 let ua = Table.get (Request.headers_in r) "User-Agent" in
58 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
61 Not_found | String.Invalid_string -> false in
62 template#conditional "msie" msie;
64 (* Build the internal model from the parameters passed to the script. *)
65 let build_internal_model () =
66 let id = int_of_string (q#param "id") in
67 let description = q#param "description" in
68 let redirect = q#param "redirect" in
70 let contents = ref [] in
72 while q#param_exists ("content_" ^ string_of_int !i) do
73 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
74 let content = q#param ("content_" ^ string_of_int !i) in
75 let divname = q#param ("divname_" ^ string_of_int !i) in
76 contents := (sectionname, divname, content) :: !contents;
79 let contents = List.rev !contents in
82 description = description;
84 contents = contents; }
87 (* Check for errors in the model. *)
88 let check_for_errors model =
89 let errors = ref [] in
90 let add_error msg = errors := msg :: !errors in
91 let get_errors () = List.rev !errors in
93 if model.redirect = "" then (
95 if model.contents = [] then
96 add_error ("This page is empty. Use 'Insert new section here' " ^
97 "to write something!");
99 (* Description field? *)
100 if model.description = "" then
101 add_error ("The description field is very important! This field is " ^
102 "used by search engines and directories to describe " ^
103 "what's on this page.");
105 else (* it's a redirect *) (
106 (* Redirect points to a real page? *)
107 let sth = dbh#prepare_cached "select 1 from pages
112 and redirect is null" in
113 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
115 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
117 add_error ("Redirect must point to an ordinary page " ^
118 "(ie. not to a page which is itself a redirect).")
121 (* All sections have sectionnames? *)
122 List.iter (function (sectionnames, _, _)
123 when string_is_whitespace sectionnames ->
124 add_error ("Every section must have a title.");
131 (* Various "actions" that can be performed on the model. *)
132 let action_insert model posn item =
133 (* posn = 0 means insert before the first element of the current list. *)
138 | n, x :: xs -> x :: (loop (n-1, xs))
140 let contents = loop (posn, model.contents) in
141 { model with contents = contents }
143 let action_moveup model posn =
144 (* posn = 1 means move up the first element, ie. do nothing
145 * posn = 2 means move up the second element to the first position
153 | 2, x :: y :: xs -> y :: x :: xs
154 | n, x :: xs -> x :: (loop (n-1, xs))
156 let contents = loop (posn, model.contents) in
157 { model with contents = contents }
159 let action_movedn model posn =
160 (* posn = 1 means move down the first element to the second position
167 | 1, 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_delete model posn =
174 (* posn = 1 means delete the first element *)
180 | n, x :: xs -> x :: (loop (n-1, xs))
182 let contents = loop (posn, model.contents) in
183 { model with contents = contents }
186 (* Convert model to template. *)
187 let model_to_template model template =
188 template#set "id" (string_of_int model.id);
189 template#set "description" model.description;
191 (* Redirects table. *)
192 let sth = dbh#prepare_cached "select url, title from pages
193 where url is not null
195 and hostid = ? and id <> ?
197 sth#execute [`Int hostid; `Int model.id];
198 let table = sth#map (function [`String url; `String title] ->
199 let selected = model.redirect = url in
200 [ "url", Template.VarString url;
201 "title", Template.VarString title;
202 "selected", Template.VarConditional selected ]
203 | _ -> assert false) in
204 template#table "redirects" table;
206 (* Need to go to the database to get the title of the page ... *)
207 let sth = dbh#prepare_cached "select title from pages
208 where hostid = ? and id = ?" in
209 sth#execute [`Int hostid; `Int model.id];
210 let title = sth#fetch1string () in
211 template#set "title" title;
213 let ordering = ref 0 in
216 (fun (sectionname, divname, content) ->
217 incr ordering; let ordering = !ordering in
218 [ "ordering", Template.VarString (string_of_int ordering);
219 "sectionname", Template.VarString sectionname;
220 "divname", Template.VarString divname;
221 "content", Template.VarString content ]) model.contents in
222 template#table "contents" table;
224 (* Check for errors and put those into the template. *)
225 let errors = check_for_errors model in
226 let errors = List.map (fun msg ->
227 [ "error", Template.VarString msg ]) errors in
228 template#table "errors" errors;
229 template#conditional "has_errors" (errors <> [])
232 (* Begin editing a page, pulling the page out of the database and building
235 let begin_editing page =
236 (* Pull out the page itself from the database. *)
237 let sth = dbh#prepare_cached "select id, title, description,
238 coalesce (redirect, '')
240 where hostid = ? and url = ?" in
241 sth#execute [`Int hostid; `String page];
243 let pageid, title, description, redirect =
244 match sth#fetch1 () with
245 [`Int pageid; `String title; `String description; `String redirect]->
246 pageid, title, description, redirect
247 | _ -> assert false in
249 (* Get the sections. *)
250 let sth = dbh#prepare_cached "select sectionname, content,
251 coalesce (divname, '')
254 order by ordering" in
255 sth#execute [`Int pageid];
259 | [`String sectionname; `String content; `String divname] ->
260 sectionname, divname, content
261 | _ -> assert false) in
263 let model = { id = pageid;
264 description = description;
266 contents = contents; } in
268 model_to_template model template
271 let continue_editing () =
272 let model = ref (build_internal_model ()) in
274 (* An "action" parameter? *)
275 let is_action, get_action =
276 let actions = q#params in
277 (* Don't actually care about the value fields ... *)
278 let actions = List.map (fun (str, _) -> str) actions in
279 (* Some of our actions are imagemaps, so parameters like name.x, name.y
280 * need to be changed to name and have resulting duplicates removed.
283 List.filter (fun str ->
284 String.length str > 7 &&
285 String.sub str 0 7 = "action_" &&
286 not (String.ends_with str ".y")) actions in
289 if String.ends_with str ".x" then (
290 let str = String.sub str 0 (String.length str - 2) in
296 let action_type = String.sub str 7 6 in
298 String.sub str 14 (String.length str - 14) in
299 let action_value = int_of_string action_value in
300 action_type, action_value) actions in
302 let is_action typ = List.mem_assoc typ actions in
303 let get_value typ = List.assoc typ actions in
308 if is_action "insert" then (
309 let posn = get_action "insert" in
310 let item = "New section - change this", "", "Write some content here." in
311 model := action_insert !model posn item
312 ) else if is_action "moveup" then (
313 let posn = get_action "moveup" in
314 model := action_moveup !model posn
315 ) else if is_action "movedn" then (
316 let posn = get_action "movedn" in
317 model := action_movedn !model posn
318 ) else if is_action "delete" then (
319 let posn = get_action "delete" in
320 model := action_delete !model posn
323 model_to_template !model template
326 (* Try to save the page. Returns a boolean indicating if the
327 * page was saved successfully.
330 let model = build_internal_model () in
331 let no_errors = [] = check_for_errors model in
333 (* No errors, so we can save the page ... *)
335 (* Pull out fields from the database. *)
336 let sth = dbh#prepare_cached "select creation_date,
337 coalesce (url, url_deleted),
340 where hostid = ? and id = ?" in
341 sth#execute [`Int hostid; `Int model.id];
343 let creation_date, url, title, css =
344 match sth#fetch1 () with
345 [ creation_date; `String url; `String title; css ] ->
346 creation_date, url, title, css
347 | _ -> assert false in
349 (* Has someone else edited this page in the meantime? *)
350 let sth = dbh#prepare_cached "select max(id) from pages
351 where hostid = ? and url = ?" in
352 sth#execute [`Int hostid; `String url];
354 let max_id = sth#fetch1int () in
355 let edited = max_id <> model.id in
358 (* Edited by someone else ... Get the other's changes. *)
360 get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
362 (* Synthesize our own changes. *)
363 let old_page = get_version_for_diff dbh model.id in
365 let css = match css with
366 `Null -> "" | `String css -> css
367 | _ -> assert false 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 model.id);
376 template_conflict#set "new_version" (string_of_int max_id);
377 template_conflict#set "url" url;
379 q#template template_conflict;
383 (* Defer the pages_redirect_cn constraint because that would
384 * temporarily fail on the next UPDATE.
388 "set constraints pages_redirect_cn, sitemenu_url_cn deferred" in
391 (* Mark the old page as deleted. NB. There is a small race
392 * condition here because PostgreSQL doesn't do isolation
393 * properly. If a user tries to visit this page between the
394 * delete and the creation of the new page, then they'll get
395 * a page not found error. (XXX)
397 let sth = dbh#prepare_cached "update pages set url_deleted = url,
399 where hostid = ? and id = ?" in
400 sth#execute [`Int hostid; `Int model.id];
402 (* Get the IP address of the user, if available. *)
404 try `String (Connection.remote_ip (Request.connection r))
405 with Not_found -> `Null in
408 let redirect = if model.redirect = "" then `Null
409 else `String model.redirect in
411 (* Create the new page. *)
412 let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
413 description, creation_date, logged_ip,
415 values (?, ?, ?, ?, ?, ?, ?, ?)" in
416 sth#execute [`Int hostid; `String url; `String title;
417 `String model.description; creation_date; logged_ip;
420 (* New page ID <> old page ID model.id. *)
421 let pageid = sth#serial "pages_id_seq" in
423 (* Create the page contents. *)
424 let sth = dbh#prepare_cached "insert into contents (pageid,
425 ordering, sectionname, divname, content)
426 values (?, ?, ?, ?, ?)" in
427 let ordering = ref 0 in (* Creating new ordering. *)
428 List.iter (fun (sectionname, divname, content) ->
430 if string_is_whitespace divname then `Null
431 else `String divname in
432 incr ordering; let ordering = !ordering in
433 sth#execute [`Int pageid; `Int ordering;
434 `String sectionname; divname;
438 (* Commit changes to the database. *)
441 (* Email notification, if anyone is listed for this host. *)
442 let subject = "Page " ^ url ^ " has been edited" in
445 (* Prepare the diff between this version and the previous version. *)
446 let diff, _ = get_diff dbh hostid url ~version:pageid () in
447 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
450 email_notify ~body ~subject dbh hostid;
452 let buttons = [ ok_button ("/" ^ url) ] in
453 ok ~title:"Saved" ~buttons
454 q "The page was saved."
461 let sth = dbh#prepare_cached "select url from pages
462 where hostid = ? and id = ?" in
463 sth#execute [`Int hostid; `Int id];
464 let url = sth#fetch1string () in
466 q#redirect ("http://" ^ hostname ^ "/" ^ url)
469 (* This codes decides where we are in the current editing cycle.
472 * id - if set, then we are in the midst of editing a page.
473 * save - if set, then we want to save the page.
474 * cancel - if set, abandon changes and go back to viewing the page.
475 * action_* - one of the action buttons was set, eg. move up/down.
476 * page - the page URL opened newly for editing.
479 let id = int_of_string (q#param "id") in
480 if q#param_true "cancel" then (
484 if q#param_true "save" then (
485 let ok = try_save () in
486 if ok then raise CgiExit (* ... else fall through *)
488 continue_editing () (* Processes the action, if any. *)
491 let page = q#param "page" in
492 let page = if page = "" then "index" else page in
498 register_script ~restrict:[CanEdit] run