2 * Written by Richard W.M. Jones <rich@merjis.com>.
3 * Copyright (C) 2004 Merjis Ltd.
4 * $Id: edit.ml,v 1.5 2004/09/08 13:09:05 rich Exp $
15 open Cocanwiki_template
17 open Cocanwiki_emailnotify
19 open Cocanwiki_strings
21 let template = get_template "edit.html"
22 let template_conflict = get_template "edit_conflict.html"
24 (* We keep an "internal model" of the page - see build_internal_model ()
28 id : int; (* Original page ID. *)
29 description : string; (* Description. *)
30 redirect : string; (* Redirect to ("" = none). *)
31 contents : (string * string * string) list;
32 (* (sectionname, divname, content)
33 * for each section. *)
36 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
37 (* Workaround bugs in IE, specifically lack of support for <button>
42 let ua = Table.get (Request.headers_in r) "User-Agent" in
43 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
46 Not_found | String.Invalid_string -> false in
47 template#conditional "msie" msie;
49 (* Build the internal model from the parameters passed to the script. *)
50 let build_internal_model () =
51 let id = int_of_string (q#param "id") in
52 let description = q#param "description" in
53 let redirect = q#param "redirect" in
55 let contents = ref [] in
57 while q#param_exists ("content_" ^ string_of_int !i) do
58 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
59 let content = q#param ("content_" ^ string_of_int !i) in
60 let divname = q#param ("divname_" ^ string_of_int !i) in
61 contents := (sectionname, divname, content) :: !contents;
64 let contents = List.rev !contents in
67 description = description;
69 contents = contents; }
72 (* Check for errors in the model. *)
73 let check_for_errors model =
74 let errors = ref [] in
75 let add_error msg = errors := msg :: !errors in
76 let get_errors () = List.rev !errors in
78 if model.redirect = "" then (
80 if model.contents = [] then
81 add_error ("This page is empty. Use 'Insert new section here' " ^
82 "to write something!");
84 (* Description field? *)
85 if model.description = "" then
86 add_error ("The description field is very important! This field is " ^
87 "used by search engines and directories to describe " ^
88 "what's on this page.");
90 else (* it's a redirect *) (
91 (* Redirect points to a real page? *)
92 let sth = dbh#prepare_cached "select 1 from pages
97 and redirect is null" in
98 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
100 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
102 add_error ("Redirect must point to an ordinary page " ^
103 "(ie. not to a page which is itself a redirect).")
106 (* All sections have sectionnames? *)
107 List.iter (function (sectionnames, _, _)
108 when string_is_whitespace sectionnames ->
109 add_error ("Every section must have a title.");
116 (* Various "actions" that can be performed on the model. *)
117 let action_insert model posn item =
118 (* posn = 0 means insert before the first element of the current list. *)
123 | n, x :: xs -> x :: (loop (n-1, xs))
125 let contents = loop (posn, model.contents) in
126 { model with contents = contents }
128 let action_moveup model posn =
129 (* posn = 1 means move up the first element, ie. do nothing
130 * posn = 2 means move up the second element to the first position
138 | 2, x :: y :: xs -> y :: x :: xs
139 | n, x :: xs -> x :: (loop (n-1, xs))
141 let contents = loop (posn, model.contents) in
142 { model with contents = contents }
144 let action_movedn model posn =
145 (* posn = 1 means move down the first element to the second position
152 | 1, 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_delete model posn =
159 (* posn = 1 means delete the first element *)
165 | n, x :: xs -> x :: (loop (n-1, xs))
167 let contents = loop (posn, model.contents) in
168 { model with contents = contents }
171 (* Convert model to template. *)
172 let model_to_template model template =
173 template#set "id" (string_of_int model.id);
174 template#set "description" model.description;
176 (* Redirects table. *)
177 let sth = dbh#prepare_cached "select url, title from pages
178 where url is not null
180 and hostid = ? and id <> ?
182 sth#execute [`Int hostid; `Int model.id];
183 let table = sth#map (function [`String url; `String title] ->
184 let selected = model.redirect = url in
185 [ "url", Template.VarString url;
186 "title", Template.VarString title;
187 "selected", Template.VarConditional selected ]
188 | _ -> assert false) in
189 template#table "redirects" table;
191 (* Need to go to the database to get the title of the page ... *)
192 let sth = dbh#prepare_cached "select title from pages
193 where hostid = ? and id = ?" in
194 sth#execute [`Int hostid; `Int model.id];
195 let title = sth#fetch1string () in
196 template#set "title" title;
198 let ordering = ref 0 in
201 (fun (sectionname, divname, content) ->
202 incr ordering; let ordering = !ordering in
203 [ "ordering", Template.VarString (string_of_int ordering);
204 "sectionname", Template.VarString sectionname;
205 "divname", Template.VarString divname;
206 "content", Template.VarString content ]) model.contents in
207 template#table "contents" table;
209 (* Check for errors and put those into the template. *)
210 let errors = check_for_errors model in
211 let errors = List.map (fun msg ->
212 [ "error", Template.VarString msg ]) errors in
213 template#table "errors" errors;
214 template#conditional "has_errors" (errors <> [])
217 (* Begin editing a page, pulling the page out of the database and building
220 let begin_editing page =
221 (* Pull out the page itself from the database. *)
222 let sth = dbh#prepare_cached "select id, title, description,
223 coalesce (redirect, '')
225 where hostid = ? and url = ?" in
226 sth#execute [`Int hostid; `String page];
228 let pageid, title, description, redirect =
229 match sth#fetch1 () with
230 [`Int pageid; `String title; `String description; `String redirect]->
231 pageid, title, description, redirect
232 | _ -> assert false in
234 (* Get the sections. *)
235 let sth = dbh#prepare_cached "select sectionname, content,
236 coalesce (divname, '')
239 order by ordering" in
240 sth#execute [`Int pageid];
244 | [`String sectionname; `String content; `String divname] ->
245 sectionname, divname, content
246 | _ -> assert false) in
248 let model = { id = pageid;
249 description = description;
251 contents = contents; } in
253 model_to_template model template
256 let continue_editing () =
257 let model = ref (build_internal_model ()) in
259 (* An "action" parameter? *)
260 let is_action, get_action =
261 let actions = q#params in
262 (* Don't actually care about the value fields ... *)
263 let actions = List.map (fun (str, _) -> str) actions in
264 (* Some of our actions are imagemaps, so parameters like name.x, name.y
265 * need to be changed to name and have resulting duplicates removed.
268 List.filter (fun str ->
269 String.length str > 7 &&
270 String.sub str 0 7 = "action_" &&
271 not (String.ends_with str ".y")) actions in
274 if String.ends_with str ".x" then (
275 let str = String.sub str 0 (String.length str - 2) in
281 let action_type = String.sub str 7 6 in
283 String.sub str 14 (String.length str - 14) in
284 let action_value = int_of_string action_value in
285 action_type, action_value) actions in
287 let is_action typ = List.mem_assoc typ actions in
288 let get_value typ = List.assoc typ actions in
293 if is_action "insert" then (
294 let posn = get_action "insert" in
295 let item = "New section - change this", "", "Write some content here." in
296 model := action_insert !model posn item
297 ) else if is_action "moveup" then (
298 let posn = get_action "moveup" in
299 model := action_moveup !model posn
300 ) else if is_action "movedn" then (
301 let posn = get_action "movedn" in
302 model := action_movedn !model posn
303 ) else if is_action "delete" then (
304 let posn = get_action "delete" in
305 model := action_delete !model posn
308 model_to_template !model template
311 (* Try to save the page. Returns a boolean indicating if the
312 * page was saved successfully.
315 let model = build_internal_model () in
316 let no_errors = [] = check_for_errors model in
318 (* No errors, so we can save the page ... *)
320 (* Pull out fields from the database. *)
321 let sth = dbh#prepare_cached "select creation_date,
322 coalesce (url, url_deleted),
325 where hostid = ? and id = ?" in
326 sth#execute [`Int hostid; `Int model.id];
328 let creation_date, url, title, css =
329 match sth#fetch1 () with
330 [ creation_date; `String url; `String title; css ] ->
331 creation_date, url, title, css
332 | _ -> assert false in
334 (* Has someone else edited this page in the meantime? *)
335 let sth = dbh#prepare_cached "select max(id) from pages
336 where hostid = ? and url = ?" in
337 sth#execute [`Int hostid; `String url];
339 let max_id = sth#fetch1int () in
340 let edited = max_id <> model.id in
343 (* Edited by someone else ... Get the other's changes. *)
345 get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
347 (* Synthesize our own changes. *)
348 let old_page = get_version_for_diff dbh model.id in
350 let css = match css with
351 `Null -> "" | `String css -> css
352 | _ -> assert false in
353 page_for_diff css (List.map (fun (sectionname, _, content) ->
354 sectionname, content) model.contents) in
355 let our_diff = diff_cmd old_page new_page in
357 (* Fill out the conflict template. *)
358 template_conflict#set "other_diff" other_diff;
359 template_conflict#set "our_diff" our_diff;
360 template_conflict#set "old_version" (string_of_int model.id);
361 template_conflict#set "new_version" (string_of_int max_id);
362 template_conflict#set "url" url;
364 q#template template_conflict;
368 (* Defer the pages_redirect_cn constraint because that would
369 * temporarily fail on the next UPDATE.
373 "set constraints pages_redirect_cn, sitemenu_url_cn deferred" in
376 (* Mark the old page as deleted. NB. There is a small race
377 * condition here because PostgreSQL doesn't do isolation
378 * properly. If a user tries to visit this page between the
379 * delete and the creation of the new page, then they'll get
380 * a page not found error. (XXX)
382 let sth = dbh#prepare_cached "update pages set url_deleted = url,
384 where hostid = ? and id = ?" in
385 sth#execute [`Int hostid; `Int model.id];
387 (* Get the IP address of the user, if available. *)
389 try `String (Connection.remote_ip (Request.connection r))
390 with Not_found -> `Null in
393 let redirect = if model.redirect = "" then `Null
394 else `String model.redirect in
396 (* Create the new page. *)
397 let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
398 description, creation_date, logged_ip,
400 values (?, ?, ?, ?, ?, ?, ?, ?)" in
401 sth#execute [`Int hostid; `String url; `String title;
402 `String model.description; creation_date; logged_ip;
405 (* New page ID <> old page ID model.id. *)
406 let pageid = sth#serial "pages_id_seq" in
408 (* Create the page contents. *)
409 let sth = dbh#prepare_cached "insert into contents (pageid,
410 ordering, sectionname, divname, content)
411 values (?, ?, ?, ?, ?)" in
412 let ordering = ref 0 in (* Creating new ordering. *)
413 List.iter (fun (sectionname, divname, content) ->
415 if string_is_whitespace divname then `Null
416 else `String divname in
417 incr ordering; let ordering = !ordering in
418 sth#execute [`Int pageid; `Int ordering;
419 `String sectionname; divname;
423 (* Commit changes to the database. *)
426 (* Email notification, if anyone is listed for this host. *)
427 let subject = "Page " ^ url ^ " has been edited" in
430 (* Prepare the diff between this version and the previous version. *)
431 let diff, _ = get_diff dbh hostid url ~version:pageid () in
432 "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
435 email_notify ~body ~subject dbh hostid;
437 let buttons = [ ok_button ("/" ^ url) ] in
438 ok ~title:"Saved" ~buttons
439 q "The page was saved."
446 let sth = dbh#prepare_cached "select url from pages
447 where hostid = ? and id = ?" in
448 sth#execute [`Int hostid; `Int id];
449 let url = sth#fetch1string () in
451 q#redirect ("http://" ^ hostname ^ "/" ^ url)
454 (* This codes decides where we are in the current editing cycle.
457 * id - if set, then we are in the midst of editing a page.
458 * save - if set, then we want to save the page.
459 * cancel - if set, abandon changes and go back to viewing the page.
460 * action_* - one of the action buttons was set, eg. move up/down.
461 * page - the page URL opened newly for editing.
464 let id = int_of_string (q#param "id") in
465 if q#param_true "cancel" then (
469 if q#param_true "save" then (
470 let ok = try_save () in
471 if ok then raise CgiExit (* ... else fall through *)
473 continue_editing () (* Processes the action, if any. *)
476 let page = q#param "page" in
477 let page = if page = "" then "index" else page in
483 register_script ~restrict:[CanEdit] run