(* 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.4 2005/11/17 10:14:43 rich Exp $
+ * $Id: cocanwiki_pages.ml,v 1.5 2006/03/27 16:43:44 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
type pt = Page of string | Title of string
type model = {
- id : int; (* Original page ID (0 = none). *)
+ id : int32; (* 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;
+ redirect : string option; (* Redirect to. *)
+ (* NB. Don't call this 'contents' because that clashes with the
+ * Pervasives.contents fields of the ref type.
+ *)
+ contents_ : (string option * string option * string) list;
(* (sectionname, divname, content)
* for each section. *)
}
exception SaveURLError
-exception SaveConflict of int * int * string * string
+exception SaveConflict of int32 * int32 * string * string
let new_page pt =
let description =
Page page -> page
| Title title -> title in
- let model = { id = 0;
+ let model = { id = 0l;
pt = pt;
description = description;
- redirect = "";
- contents = [] } in
+ redirect = None;
+ contents_ = [] } in
model
let new_page_with_title title =
(* Initial page contents. *)
- let contents = [ "", "", "<b>" ^ title ^ "</b> is " ] in
- let model = { id = 0;
+ let contents = [ None, None, "<b>" ^ title ^ "</b> is " ] in
+ let model = { id = 0l;
pt = Title title;
description = title;
- redirect = "";
- contents = contents } in
+ redirect = None;
+ contents_ = contents } in
model
-let load_page (dbh : Dbi.connection) hostid ~url ?version () =
+let load_page dbh hostid ~url ?version () =
(* Pull out the page itself from the database. *)
- let sth =
+ let rows =
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
+ | None ->
+ PGSQL(dbh) "select id, title, description, redirect
+ from pages
+ where hostid = $hostid and url = $url"
+ | Some version ->
+ PGSQL(dbh) "select id, title, description, redirect
+ from pages
+ where hostid = $hostid and id = $version and
+ (url = $url or url_deleted = $url)" 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
+ match rows with
+ | [row] -> row
+ | _ -> raise Not_found 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 contents = PGSQL(dbh)
+ "select sectionname, divname, content
+ from contents
+ where pageid = $pageid
+ order by ordering" in
let model = { id = pageid;
pt = Page url;
description = description;
redirect = redirect;
- contents = contents; } in
+ contents_ = contents } in
model
-let save_page (dbh : Dbi.connection) hostid ?user ?r model =
+let save_page dbh hostid ?user ?r model =
(* Logging information, if available. *)
let logged_user =
match user with
- None -> `Null
+ None -> None
| Some user ->
match user with
- | User (id, _, _, _) -> `Int id
- | _ -> `Null in
+ | User (id, _, _, _) -> Some id
+ | _ -> None in
let logged_ip =
match r with
- None -> `Null
+ None -> None
| 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
+ try Some (Connection.remote_ip (Request.connection r))
+ with Not_found -> None 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 (
+ if model.id = 0l then (
(* Create the page title or URL. *)
let url, title =
match model.pt with
| _ ->
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 description = model.description in
+ let redirect = model.redirect in
+ PGSQL(dbh) "insert into pages (hostid, url, title,
+ description, logged_ip, logged_user,
+ redirect)
+ values ($hostid, $url, $title, $description,
+ $?logged_ip, $?logged_user, $?redirect)";
- let pageid = Int64.to_int (sth#serial "pages_id_seq") in
+ let pageid = PGOCaml.serial4 dbh "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;
+ List.iter (
+ fun (sectionname, divname, content) ->
+ incr ordering; let ordering = Int32.of_int !ordering in
+ PGSQL(dbh)
+ "insert into contents (pageid, ordering, sectionname, divname,
+ content)
+ values ($pageid, $ordering,
+ $?sectionname, $?divname, $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 model_id = model.id in
+ let rows =
+ PGSQL(dbh)
+ "select creation_date, coalesce (url, url_deleted),
+ title, css
+ from pages
+ where hostid = $hostid and id = $model_id" in
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
+ match rows with
+ | [ row ] -> row
+ | _ -> assert false in
+ let url = Option.get url in
(* Title changed? *)
let title =
match model.pt with
- Title new_title when title <> new_title -> new_title
- | _ -> title in
+ | Title new_title when title <> new_title -> new_title
+ | _ -> title 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 = Option.get (
+ List.hd (
+ PGSQL(dbh) "select max(id) from pages
+ where hostid = $hostid and url = $url"
+ )
+ ) in
- let max_id = sth#fetch1int () in
- let edited = max_id <> model.id 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))
+ let css = match css with None -> "" | Some css -> css 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,
+ PGSQL(dbh)
+ "set constraints
+ pages_redirect_cn, sitemenu_url_cn,
page_emails_url_cn, links_from_cn, recently_visited_url_cn
- deferred" in
- sth#execute [];
+ deferred";
(* Mark the old page as deleted. NB. There is a small race
* condition here because PostgreSQL doesn't do isolation
* 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];
+ PGSQL(dbh) "update pages set url_deleted = url, url = null
+ where hostid = $hostid and id = $model_id";
+
+ let description = model.description in
+ let redirect = model.redirect in
+ PGSQL(dbh)
+ "insert into pages (hostid, url, title,
+ description, creation_date, logged_ip,
+ logged_user, redirect, css)
+ values ($hostid, $url, $title, $description, $creation_date,
+ $?logged_ip, $?logged_user, $?redirect, $?css)";
(* New page ID <> old page ID model.id. *)
- let pageid = Int64.to_int (sth#serial "pages_id_seq") in
+ let pageid = PGOCaml.serial4 dbh "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;
+ List.iter (
+ fun (sectionname, divname, content) ->
+ incr ordering; let ordering = Int32.of_int !ordering in
+ PGSQL(dbh) "insert into contents (pageid,
+ ordering, sectionname, divname, content)
+ values ($pageid, $ordering, $?sectionname,
+ $?divname, $content)"
+ ) model.contents_;
url, pageid
) in
git.annexia.org / cocanwiki.git / blobdiff