+(* COCANWIKI - a wiki written in Objective CAML.
+ * Written by Richard W.M. Jones <rich@merjis.com>.
+ * Copyright (C) 2004 Merjis Ltd.
+ * $Id: cocanwiki_pages.ml,v 1.1 2004/10/11 14:13:04 rich Exp $
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ * Boston, MA 02111-1307, USA.
+ *)
+
+open Apache
+
+open Cocanwiki
+open Cocanwiki_strings
+
+type pt = Page of string | Title of string
+
+type model = {
+ id : int; (* Original page ID (0 = none). *)
+ pt : pt; (* Page of title (only used if id=0) *)
+ description : string; (* Description. *)
+ redirect : string; (* Redirect to ("" = none). *)
+ contents : (string * string * string) list;
+ (* (sectionname, divname, content)
+ * for each section. *)
+}
+
+exception SaveURLError
+exception SaveConflict of int * int * string * string
+
+let new_page pt =
+ let description =
+ match pt with
+ Page page -> page
+ | Title title -> title in
+
+ let model = { id = 0;
+ pt = pt;
+ description = description;
+ redirect = "";
+ contents = [] } in
+ model
+
+let new_page_with_title title =
+ (* Initial page contents. *)
+ let contents = [ "", "", "<b>" ^ title ^ "</b> is " ] in
+ let model = { id = 0;
+ pt = Title title;
+ description = title;
+ redirect = "";
+ contents = contents } in
+ model
+
+let load_page (dbh : Dbi.connection) hostid ~url ?version () =
+ (* Pull out the page itself from the database. *)
+ let sth =
+ match version with
+ None ->
+ let sth = dbh#prepare_cached "select id, title, description,
+ coalesce (redirect, '')
+ from pages
+ where hostid = ? and url = ?" in
+ sth#execute [`Int hostid; `String url];
+ sth
+ | Some version ->
+ let sth = dbh#prepare_cached "select id, title, description,
+ coalesce (redirect, '')
+ from pages
+ where hostid = ? and id = ? and
+ (url = ? or url_deleted = ?)" in
+ sth#execute [`Int hostid; `String url; `String url];
+ sth in
+
+ let pageid, title, description, redirect =
+ match sth#fetch1 () with
+ [`Int pageid; `String title; `String description; `String redirect] ->
+ pageid, title, description, redirect
+ | _ -> assert false in
+
+ (* Get the sections. *)
+ let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
+ content,
+ coalesce (divname, '')
+ from contents
+ where pageid = ?
+ order by ordering" in
+ sth#execute [`Int pageid];
+
+ let contents =
+ sth#map (function
+ | [`String sectionname; `String content; `String divname] ->
+ sectionname, divname, content
+ | _ -> assert false) in
+
+ let model = { id = pageid;
+ pt = Page url;
+ description = description;
+ redirect = redirect;
+ contents = contents; } in
+ model
+
+let save_page (dbh : Dbi.connection) hostid ?user ?r model =
+ (* Logging information, if available. *)
+ let logged_user =
+ match user with
+ None -> `Null
+ | Some user ->
+ match user with
+ | User (id, _, _) -> `Int id
+ | _ -> `Null in
+
+ let logged_ip =
+ match r with
+ None -> `Null
+ | Some r ->
+ try `String (Connection.remote_ip (Request.connection r))
+ with Not_found -> `Null in
+
+ (* Get redirect. *)
+ let redirect =
+ if model.redirect = "" then `Null
+ else `String model.redirect in
+
+ let url, pageid =
+ (* Creating a new page (id = 0)? If so, we're just going to insert
+ * a new row, which is easy.
+ *)
+ if model.id = 0 then (
+ (* Create the page title or URL. *)
+ let url, title =
+ match model.pt with
+ Page url -> url, url
+ | Title title ->
+ match Wikilib.generate_url_of_title dbh hostid title with
+ Wikilib.GenURL_OK url -> url, title
+ | _ ->
+ raise SaveURLError in
+
+ let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
+ description, logged_ip, logged_user,
+ redirect)
+ values (?, ?, ?, ?, ?, ?, ?)" in
+ sth#execute [`Int hostid; `String url; `String title;
+ `String model.description; logged_ip; logged_user;
+ redirect];
+
+ 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;
+
+ url, pageid
+ )
+ (* Otherwise it's an old page which we're updating. *)
+ else (
+ (* 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 (
+ let css = match css with
+ `Null -> "" | `String css -> css
+ | _ -> assert false in
+ raise (SaveConflict (max_id, model.id, url, css))
+ );
+
+ (* 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, recently_visited_url_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];
+
+ (* 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;
+
+ url, pageid
+ ) in
+
+ (* Keep the links table in synch. *)
+ Cocanwiki_links.update_links_for_page dbh hostid url;
+
+ url, pageid