- (* Pull out fields from the database. *)
- let sth = dbh#prepare_cached "select creation_date,
- coalesce (url, url_deleted),
- title, css
- from pages
- where hostid = ? and id = ?" in
- sth#execute [`Int hostid; `Int model.id];
-
- let creation_date, url, title, css =
- match sth#fetch1 () with
- [ creation_date; `String url; `String title; css ] ->
- creation_date, url, title, css
- | _ -> assert false in
-
- (* Has someone else edited this page in the meantime? *)
- let sth = dbh#prepare_cached "select max(id) from pages
- where hostid = ? and url = ?" in
- sth#execute [`Int hostid; `String url];
-
- let max_id = sth#fetch1int () in
- let edited = max_id <> model.id in
-
- if edited then (
- (* Edited by someone else ... Get the other's changes. *)
- let other_diff, _ =
- get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
-
- (* Synthesize our own changes. *)
- let old_page = get_version_for_diff dbh model.id in
- let new_page =
- let css = match css with
- `Null -> "" | `String css -> css
- | _ -> assert false in
- page_for_diff css (List.map (fun (sectionname, _, content) ->
- sectionname, content) model.contents) in
- let our_diff = diff_cmd old_page new_page in
-
- (* Fill out the conflict template. *)
- template_conflict#set "other_diff" other_diff;
- template_conflict#set "our_diff" our_diff;
- template_conflict#set "old_version" (string_of_int model.id);
- template_conflict#set "new_version" (string_of_int max_id);
- template_conflict#set "url" url;
-
- q#template template_conflict;
- return ()
- );
-
- (* Defer the pages_redirect_cn constraint because that would
- * temporarily fail on the next UPDATE.
- *)
- let sth =
- dbh#prepare_cached
- "set constraints pages_redirect_cn, sitemenu_url_cn,
- page_emails_url_cn, links_from_cn deferred" in
- sth#execute [];
-
- (* Mark the old page as deleted. NB. There is a small race
- * condition here because PostgreSQL doesn't do isolation
- * properly. If a user tries to visit this page between the
- * delete and the creation of the new page, then they'll get
- * a page not found error. (XXX)
- *)
- let sth = dbh#prepare_cached "update pages set url_deleted = url,
- url = null
- where hostid = ? and id = ?" in
- sth#execute [`Int hostid; `Int model.id];
-
- (* Get the IP address of the user, if available. *)
- let logged_ip =
- try `String (Connection.remote_ip (Request.connection r))
- with Not_found -> `Null in
-
- let logged_user =
- match user with
- | User (id, _, _) -> `Int id
- | _ -> `Null in
-
- (* Get redirect. *)
- let redirect = if model.redirect = "" then `Null
- else `String model.redirect in
-
- (* Create the new page. *)
- let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
- description, creation_date, logged_ip,
- logged_user, redirect, css)
- values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
- sth#execute [`Int hostid; `String url; `String title;
- `String model.description; creation_date; logged_ip;
- logged_user; redirect; css];
-
- (* New page ID <> old page ID model.id. *)
- let pageid = sth#serial "pages_id_seq" in
-
- (* Create the page contents. *)
- let sth = dbh#prepare_cached "insert into contents (pageid,
- ordering, sectionname, divname, content)
- values (?, ?, ?, ?, ?)" in
- let ordering = ref 0 in (* Creating new ordering. *)
- List.iter (fun (sectionname, divname, content) ->
- let divname =
- if string_is_whitespace divname then `Null
- else `String divname in
- let sectionname =
- if string_is_whitespace sectionname then `Null
- else `String sectionname in
- incr ordering; let ordering = !ordering in
- sth#execute [`Int pageid; `Int ordering;
- sectionname; divname;
- `String content])
- model.contents;
-
- (* Keep the links table in synch. *)
- Cocanwiki_links.update_links_for_page dbh hostid url;
-
- (* Commit changes to the database. *)
- dbh#commit ();
-
- (* Email notification, if anyone is listed for this host. *)
- let subject = "Page " ^ url ^ " has been edited" in
-
- let body = fun () ->
- (* Prepare the diff between this version and the previous version. *)
- let diff, _ = get_diff dbh hostid url ~version:pageid () in
- "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
- diff in
-
- email_notify ~body ~subject dbh hostid;
+ let url, pageid =
+ try
+ save_page dbh hostid ~user ~r model
+ with
+ SaveURLError ->
+ error ~back_button:true ~title:"Page exists"
+ q ("While you were editing that page, it looks " ^
+ "like another user created the same page.");
+ return ()
+
+ | SaveConflict (new_version, old_version, url, css) ->
+ (* Edited by someone else ... Get the other's changes. *)
+ let other_diff, _ =
+ get_diff dbh hostid url ~old_version ~version:new_version () in
+
+ (* Synthesize our own changes. *)
+ let old_page = get_version_for_diff dbh old_version in
+ let new_page =
+ page_for_diff css (List.map (fun (sectionname, _, content) ->
+ sectionname, content) model.contents) in
+ let our_diff = diff_cmd old_page new_page in
+
+ (* Fill out the conflict template. *)
+ template_conflict#set "other_diff" other_diff;
+ template_conflict#set "our_diff" our_diff;
+ template_conflict#set "old_version" (string_of_int old_version);
+ template_conflict#set "new_version" (string_of_int new_version);
+ template_conflict#set "url" url;
+
+ q#template template_conflict;
+ return () in