2 * Written by Richard W.M. Jones <rich@merjis.com>.
3 * Copyright (C) 2004 Merjis Ltd.
4 * $Id: edit.ml,v 1.2 2004/09/07 13:40:10 rich Exp $
17 open Cocanwiki_template
19 open Cocanwiki_emailnotify
22 let template = get_template "edit.html"
23 let template_conflict = get_template "edit_conflict.html"
25 (* We keep an "internal model" of the page - see build_internal_model ()
29 id : int; (* Original page ID. *)
30 description : string; (* Description. *)
31 redirect : string; (* Redirect to ("" = none). *)
32 contents : (string * string * string) list;
33 (* (sectionname, divname, content)
34 * for each section. *)
37 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
38 (* Workaround bugs in IE, specifically lack of support for <button>
43 let ua = Table.get (Request.headers_in r) "User-Agent" in
44 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
47 Not_found | String.Invalid_string -> false in
48 template#conditional "msie" msie;
50 (* Build the internal model from the parameters passed to the script. *)
51 let build_internal_model () =
52 let id = int_of_string (q#param "id") in
53 let description = q#param "description" in
54 let redirect = q#param "redirect" in
56 let contents = ref [] in
58 while q#param_exists ("content_" ^ string_of_int !i) do
59 let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
60 let content = q#param ("content_" ^ string_of_int !i) in
61 let divname = q#param ("divname_" ^ string_of_int !i) in
62 contents := (sectionname, divname, content) :: !contents;
65 let contents = List.rev !contents in
68 description = description;
70 contents = contents; }
73 (* Check for errors in the model. *)
74 let check_for_errors model =
75 let errors = ref [] in
76 let add_error msg = errors := msg :: !errors in
77 let get_errors () = List.rev !errors in
79 if model.redirect = "" then (
81 if model.contents = [] then
82 add_error ("This page is empty. Use 'Insert new section here' " ^
83 "to write something!");
85 (* Description field? *)
86 if model.description = "" then
87 add_error ("The description field is very important! This field is " ^
88 "used by search engines and directories to describe " ^
89 "what's on this page.");
91 else (* it's a redirect *) (
92 (* Redirect points to a real page? *)
93 let sth = dbh#prepare_cached "select 1 from pages
98 and redirect is null" in
99 sth#execute [`Int hostid; `String model.redirect; `Int model.id];
101 let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
103 add_error ("Redirect must point to an ordinary page " ^
104 "(ie. not to a page which is itself a redirect).")
107 (* All sections have sectionnames? *)
108 List.iter (function (sectionnames, _, _)
109 when string_is_whitespace sectionnames ->
110 add_error ("Every section must have a title.");
117 (* Various "actions" that can be performed on the model. *)
118 let action_insert model posn item =
119 (* posn = 0 means insert before the first element of the current list. *)
124 | n, x :: xs -> x :: (loop (n-1, xs))
126 let contents = loop (posn, model.contents) in
127 { model with contents = contents }
129 let action_moveup model posn =
130 (* posn = 1 means move up the first element, ie. do nothing
131 * posn = 2 means move up the second element to the first position
139 | 2, x :: y :: xs -> y :: x :: xs
140 | n, x :: xs -> x :: (loop (n-1, xs))
142 let contents = loop (posn, model.contents) in
143 { model with contents = contents }
145 let action_movedn model posn =
146 (* posn = 1 means move down the first element to the second position
153 | 1, 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_delete model posn =
160 (* posn = 1 means delete the first element *)
166 | n, x :: xs -> x :: (loop (n-1, xs))
168 let contents = loop (posn, model.contents) in
169 { model with contents = contents }
172 (* Convert model to template. *)
173 let model_to_template model template =
174 template#set "id" (string_of_int model.id);
175 template#set "description" model.description;
177 (* Redirects table. *)
178 let sth = dbh#prepare_cached "select url, title from pages
179 where url is not null
181 and hostid = ? and id <> ?
183 sth#execute [`Int hostid; `Int model.id];
184 let table = sth#map (function [`String url; `String title] ->
185 let selected = model.redirect = url in
186 [ "url", Template.VarString url;
187 "title", Template.VarString title;
188 "selected", Template.VarConditional selected ]
189 | _ -> assert false) in
190 template#table "redirects" table;
192 (* Need to go to the database to get the title of the page ... *)
193 let sth = dbh#prepare_cached "select title from pages
194 where hostid = ? and id = ?" in
195 sth#execute [`Int hostid; `Int model.id];
196 let title = sth#fetch1string () in
197 template#set "title" title;
199 let ordering = ref 0 in
202 (fun (sectionname, divname, content) ->
203 incr ordering; let ordering = !ordering in
204 [ "ordering", Template.VarString (string_of_int ordering);
205 "sectionname", Template.VarString sectionname;
206 "divname", Template.VarString divname;
207 "content", Template.VarString content ]) model.contents in
208 template#table "contents" table;
210 (* Check for errors and put those into the template. *)
211 let errors = check_for_errors model in
212 let errors = List.map (fun msg ->
213 [ "error", Template.VarString msg ]) errors in
214 template#table "errors" errors;
215 template#conditional "has_errors" (errors <> [])
218 (* Begin editing a page, pulling the page out of the database and building
221 let begin_editing page =
222 (* Pull out the page itself from the database. *)
223 let sth = dbh#prepare_cached "select id, title, description,
224 coalesce (redirect, '')
226 where hostid = ? and url = ?" in
227 sth#execute [`Int hostid; `String page];
229 let pageid, title, description, redirect =
230 match sth#fetch1 () with
231 [`Int pageid; `String title; `String description; `String redirect]->
232 pageid, title, description, redirect
233 | _ -> assert false in
235 (* Get the sections. *)
236 let sth = dbh#prepare_cached "select sectionname, content,
237 coalesce (divname, '')
240 order by ordering" in
241 sth#execute [`Int pageid];
245 | [`String sectionname; `String content; `String divname] ->
246 sectionname, divname, content
247 | _ -> assert false) in
249 let model = { id = pageid;
250 description = description;
252 contents = contents; } in
254 model_to_template model template
257 let continue_editing () =
258 let model = ref (build_internal_model ()) in
260 (* An "action" parameter? *)
261 let is_action, get_action =
262 let actions = q#params in
263 (* Don't actually care about the value fields ... *)
264 let actions = List.map (fun (str, _) -> str) actions in
265 (* Some of our actions are imagemaps, so parameters like name.x, name.y
266 * need to be changed to name and have resulting duplicates removed.
269 List.filter (fun str ->
270 String.length str > 7 &&
271 String.sub str 0 7 = "action_" &&
272 not (String.ends_with str ".y")) actions in
275 if String.ends_with str ".x" then (
276 let str = String.sub str 0 (String.length str - 2) in
282 let action_type = String.sub str 7 6 in
284 String.sub str 14 (String.length str - 14) in
285 let action_value = int_of_string action_value in
286 action_type, action_value) actions in
288 let is_action typ = List.mem_assoc typ actions in
289 let get_value typ = List.assoc typ actions in
294 if is_action "insert" then (
295 let posn = get_action "insert" in
296 let item = "New section - change this", "", "Write some content here." in
297 model := action_insert !model posn item
298 ) else if is_action "moveup" then (
299 let posn = get_action "moveup" in
300 model := action_moveup !model posn
301 ) else if is_action "movedn" then (
302 let posn = get_action "movedn" in
303 model := action_movedn !model posn
304 ) else if is_action "delete" then (
305 let posn = get_action "delete" in
306 model := action_delete !model posn
309 model_to_template !model template
312 (* Try to save the page. Returns a boolean indicating if the
313 * page was saved successfully.
316 let model = build_internal_model () in
317 let no_errors = [] = check_for_errors model in
319 (* No errors, so we can save the page ... *)
321 (* Pull out fields from the database. *)
322 let sth = dbh#prepare_cached "select creation_date,
323 coalesce (url, url_deleted),
326 where hostid = ? and id = ?" in
327 sth#execute [`Int hostid; `Int model.id];
329 let creation_date, url, title, css =
330 match sth#fetch1 () with
331 [ creation_date; `String url; `String title; css ] ->
332 creation_date, url, title, css
333 | _ -> assert false in
335 (* Has someone else edited this page in the meantime? *)
336 let sth = dbh#prepare_cached "select max(id) from pages
337 where hostid = ? and url = ?" in
338 sth#execute [`Int hostid; `String url];
340 let max_id = sth#fetch1int () in
341 let edited = max_id <> model.id in
344 (* Edited by someone else ... Get the other's changes. *)
346 get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
348 (* Synthesize our own changes. *)
349 let old_page = get_version_for_diff dbh model.id in
351 let css = match css with
352 `Null -> "" | `String css -> css
353 | _ -> assert false in
354 page_for_diff css (List.map (fun (sectionname, _, content) ->
355 sectionname, content) model.contents) in
356 let our_diff = diff_cmd old_page new_page in
358 (* Fill out the conflict template. *)
359 template_conflict#set "other_diff" other_diff;
360 template_conflict#set "our_diff" our_diff;
361 template_conflict#set "old_version" (string_of_int model.id);
362 template_conflict#set "new_version" (string_of_int max_id);
363 template_conflict#set "url" url;
365 q#template template_conflict;
369 (* Defer the pages_redirect_cn constraint because that would
370 * temporarily fail on the next UPDATE.
373 dbh#prepare_cached "set constraints pages_redirect_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