scripts/edit.ml

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: edit.ml,v 1.11 2004/09/23 11:56:47 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Printf
  26
  27 open ExtString
  28
  29 open Cocanwiki
  30 open Cocanwiki_template
  31 open Cocanwiki_ok
  32 open Cocanwiki_emailnotify
  33 open Cocanwiki_diff
  34 open Cocanwiki_strings
  35
  36 (* We keep an "internal model" of the page - see build_internal_model ()
  37  * below.
  38  *)
  39 type model_t = {
  40   id : int;                             (* Original page ID. *)
  41   description : string;                 (* Description. *)
  42   redirect : string;                    (* Redirect to ("" = none). *)
  43   contents : (string * string * string) list;
  44                                         (* (sectionname, divname, content)
  45                                          * for each section. *)
  46 }
  47
  48 let run r (q : cgi) (dbh : Dbi.connection) hostid {hostname = hostname} user =
  49   let template = get_template dbh hostid "edit.html" in
  50   let template_conflict = get_template dbh hostid "edit_conflict.html" in
  51
  52   (* Workaround bugs in IE, specifically lack of support for <button>
  53    * elements.
  54    *)
  55   let msie =
  56     try
  57       let ua = Table.get (Request.headers_in r) "User-Agent" in
  58       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  59       true
  60     with
  61         Not_found | String.Invalid_string -> false in
  62   template#conditional "msie" msie;
  63
  64   (* Build the internal model from the parameters passed to the script. *)
  65   let build_internal_model () =
  66     let id = int_of_string (q#param "id") in
  67     let description = q#param "description" in
  68     let redirect = q#param "redirect" in
  69
  70     let contents = ref [] in
  71     let i = ref 1 in
  72     while q#param_exists ("content_" ^ string_of_int !i) do
  73       let sectionname = q#param ("sectionname_" ^ string_of_int !i) in
  74       let content = q#param ("content_" ^ string_of_int !i) in
  75       let divname = q#param ("divname_" ^ string_of_int !i) in
  76       contents := (sectionname, divname, content) :: !contents;
  77       incr i
  78     done;
  79     let contents = List.rev !contents in
  80
  81     { id = id;
  82       description = description;
  83       redirect = redirect;
  84       contents = contents; }
  85   in
  86
  87   (* Check for errors in the model. *)
  88   let check_for_errors model =
  89     let errors = ref [] in
  90     let add_error msg = errors := msg :: !errors in
  91     let get_errors () = List.rev !errors in
  92
  93     if model.redirect = "" then (
  94       (* Empty page? *)
  95       if model.contents = [] then
  96         add_error ("This page is empty.  Use 'Insert new section here' " ^
  97                    "to write something!");
  98
  99       (* Description field? *)
 100       if model.description = "" then
 101         add_error ("The description field is very important!  This field is " ^
 102                    "used by search engines and directories to describe " ^
 103                    "what's on this page.");
 104     )
 105     else (* it's a redirect *) (
 106       (* Redirect points to a real page? *)
 107       let sth = dbh#prepare_cached "select 1 from pages
 108                                      where hostid = ?
 109                                        and url is not null
 110                                        and url = ?
 111                                        and id <> ?
 112                                        and redirect is null" in
 113       sth#execute [`Int hostid; `String model.redirect; `Int model.id];
 114
 115       let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
 116       if not ok then
 117         add_error ("Redirect must point to an ordinary page " ^
 118                    "(ie. not to a page which is itself a redirect).")
 119     );
 120
 121     (* All sections after the first one have sectionnames?  The first
 122      * section ONLY is allowed to have an empty title.
 123      *)
 124     if model.contents <> [] then
 125       List.iter (function (sectionnames, _, _)
 126                      when string_is_whitespace sectionnames ->
 127                        add_error
 128                        ("Every section except the first must have a title.");
 129                    | _ -> ())
 130         (List.tl model.contents);
 131
 132     get_errors ()
 133   in
 134
 135   (* Various "actions" that can be performed on the model. *)
 136   let action_insert model posn item =
 137     (* posn = 0 means insert before the first element of the current list. *)
 138     let rec loop =
 139       function
 140           0, xs -> item :: xs
 141         | _, [] -> [ item ]
 142         | n, x :: xs -> x :: (loop (n-1, xs))
 143     in
 144     let contents = loop (posn, model.contents) in
 145     { model with contents = contents }
 146   in
 147   let action_moveup model posn =
 148     (* posn = 1 means move up the first element, ie. do nothing
 149      * posn = 2 means move up the second element to the first position
 150      * etc.
 151      *)
 152     let rec loop =
 153       function
 154           0, xs
 155         | 1, xs -> xs
 156         | _, [] -> []
 157         | 2, x :: y :: xs -> y :: x :: xs
 158         | n, x :: xs -> x :: (loop (n-1, xs))
 159     in
 160     let contents = loop (posn, model.contents) in
 161     { model with contents = contents }
 162   in
 163   let action_movedn model posn =
 164     (* posn = 1 means move down the first element to the second position
 165      * etc.
 166      *)
 167     let rec loop =
 168       function
 169           0, xs -> xs
 170         | _, [] -> []
 171         | 1, x :: y :: xs -> y :: x :: xs
 172         | n, x :: xs -> x :: (loop (n-1, xs))
 173     in
 174     let contents = loop (posn, model.contents) in
 175     { model with contents = contents }
 176   in
 177   let action_delete model posn =
 178     (* posn = 1 means delete the first element *)
 179     let rec loop =
 180       function
 181           0, xs -> xs
 182         | _, [] -> []
 183         | 1, x :: xs -> xs
 184         | n, x :: xs -> x :: (loop (n-1, xs))
 185     in
 186     let contents = loop (posn, model.contents) in
 187     { model with contents = contents }
 188   in
 189
 190   (* Convert model to template. *)
 191   let model_to_template model template =
 192     template#set "id" (string_of_int model.id);
 193     template#set "description" model.description;
 194
 195     (* Redirects table. *)
 196     let sth = dbh#prepare_cached "select url, title from pages
 197                                    where url is not null
 198                                      and redirect is null
 199                                      and hostid = ? and id <> ?
 200                                    order by 2" in
 201     sth#execute [`Int hostid; `Int model.id];
 202     let table = sth#map (function [`String url; `String title] ->
 203                            let selected = model.redirect = url in
 204                            [ "url", Template.VarString url;
 205                              "title", Template.VarString title;
 206                              "selected", Template.VarConditional selected ]
 207                            | _ -> assert false) in
 208     template#table "redirects" table;
 209
 210     (* Need to go to the database to get the title of the page ... *)
 211     let sth = dbh#prepare_cached "select title from pages
 212                                    where hostid = ? and id = ?" in
 213     sth#execute [`Int hostid; `Int model.id];
 214     let title = sth#fetch1string () in
 215     template#set "title" title;
 216
 217     let ordering = ref 0 in
 218     let table =
 219       List.map
 220         (fun (sectionname, divname, content) ->
 221            incr ordering; let ordering = !ordering in
 222            [ "ordering", Template.VarString (string_of_int ordering);
 223              "sectionname", Template.VarString sectionname;
 224              "divname", Template.VarString divname;
 225              "content", Template.VarString content ]) model.contents in
 226     template#table "contents" table;
 227
 228     (* Check for errors and put those into the template. *)
 229     let errors = check_for_errors model in
 230     let errors = List.map (fun msg ->
 231                              [ "error", Template.VarString msg ]) errors in
 232     template#table "errors" errors;
 233     template#conditional "has_errors" (errors <> [])
 234   in
 235
 236   (* Begin editing a page, pulling the page out of the database and building
 237    * a model from it.
 238    *)
 239   let begin_editing page =
 240     (* Pull out the page itself from the database. *)
 241     let sth = dbh#prepare_cached "select id, title, description,
 242                                          coalesce (redirect, '')
 243                                     from pages
 244                                    where hostid = ? and url = ?" in
 245     sth#execute [`Int hostid; `String page];
 246
 247     let pageid, title, description, redirect =
 248       match sth#fetch1 () with
 249           [`Int pageid; `String title; `String description; `String redirect]->
 250             pageid, title, description, redirect
 251         | _ -> assert false in
 252
 253     (* Get the sections. *)
 254     let sth = dbh#prepare_cached "select coalesce (sectionname, ''),
 255                                          content,
 256                                          coalesce (divname, '')
 257                                     from contents
 258                                    where pageid = ?
 259                                    order by ordering" in
 260     sth#execute [`Int pageid];
 261
 262     let contents =
 263       sth#map (function
 264                  | [`String sectionname; `String content; `String divname] ->
 265                      sectionname, divname, content
 266                  | _ -> assert false) in
 267
 268     let model = { id = pageid;
 269                   description = description;
 270                   redirect = redirect;
 271                   contents = contents; } in
 272
 273     model_to_template model template
 274   in
 275
 276   let continue_editing () =
 277     let model = ref (build_internal_model ()) in
 278
 279     (* An "action" parameter? *)
 280     let is_action, get_action =
 281       let actions = q#params in
 282       (* Don't actually care about the value fields ... *)
 283       let actions = List.map (fun (str, _) -> str) actions in
 284       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 285        * need to be changed to name and have resulting duplicates removed.
 286        *)
 287       let actions =
 288         List.filter (fun str ->
 289                        String.length str > 7 &&
 290                        String.sub str 0 7 = "action_" &&
 291                        not (String.ends_with str ".y")) actions in
 292       let actions =
 293         List.map (fun str ->
 294                     if String.ends_with str ".x" then (
 295                       let str = String.sub str 0 (String.length str - 2) in
 296                       str
 297                     )
 298                     else str) actions in
 299       let actions =
 300         List.map (fun str ->
 301                     let action_type = String.sub str 7 6 in
 302                     let action_value =
 303                       String.sub str 14 (String.length str - 14) in
 304                     let action_value = int_of_string action_value in
 305                     action_type, action_value) actions in
 306
 307       let is_action typ = List.mem_assoc typ actions in
 308       let get_value typ = List.assoc typ actions in
 309
 310       is_action, get_value
 311     in
 312
 313     if is_action "insert" then (
 314       let posn = get_action "insert" in
 315       let item = "New section - change this", "", "Write some content here." in
 316       model := action_insert !model posn item
 317     ) else if is_action "moveup" then (
 318       let posn = get_action "moveup" in
 319       model := action_moveup !model posn
 320     ) else if is_action "movedn" then (
 321       let posn = get_action "movedn" in
 322       model := action_movedn !model posn
 323     ) else if is_action "delete" then (
 324       let posn = get_action "delete" in
 325       model := action_delete !model posn
 326     );
 327
 328     model_to_template !model template
 329   in
 330
 331   (* Try to save the page.  Returns a boolean indicating if the
 332    * page was saved successfully.
 333    *)
 334   let try_save () =
 335     let model = build_internal_model () in
 336     let no_errors = [] = check_for_errors model in
 337     if no_errors then (
 338       (* No errors, so we can save the page ... *)
 339
 340       (* Pull out fields from the database. *)
 341       let sth = dbh#prepare_cached "select creation_date,
 342                                            coalesce (url, url_deleted),
 343                                            title, css
 344                                       from pages
 345                                      where hostid = ? and id = ?" in
 346       sth#execute [`Int hostid; `Int model.id];
 347
 348       let creation_date, url, title, css =
 349         match sth#fetch1 () with
 350             [ creation_date; `String url; `String title; css ] ->
 351               creation_date, url, title, css
 352           | _ -> assert false in
 353
 354       (* Has someone else edited this page in the meantime? *)
 355       let sth = dbh#prepare_cached "select max(id) from pages
 356                                      where hostid = ? and url = ?" in
 357       sth#execute [`Int hostid; `String url];
 358
 359       let max_id = sth#fetch1int () in
 360       let edited = max_id <> model.id in
 361
 362       if edited then (
 363         (* Edited by someone else ...  Get the other's changes. *)
 364         let other_diff, _ =
 365           get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
 366
 367         (* Synthesize our own changes. *)
 368         let old_page = get_version_for_diff dbh model.id in
 369         let new_page =
 370           let css = match css with
 371               `Null -> "" | `String css -> css
 372             | _ -> assert false in
 373           page_for_diff css (List.map (fun (sectionname, _, content) ->
 374                                sectionname, content) model.contents) in
 375         let our_diff = diff_cmd old_page new_page in
 376
 377         (* Fill out the conflict template. *)
 378         template_conflict#set "other_diff" other_diff;
 379         template_conflict#set "our_diff" our_diff;
 380         template_conflict#set "old_version" (string_of_int model.id);
 381         template_conflict#set "new_version" (string_of_int max_id);
 382         template_conflict#set "url" url;
 383
 384         q#template template_conflict;
 385         return ()
 386       );
 387
 388       (* Defer the pages_redirect_cn constraint because that would
 389        * temporarily fail on the next UPDATE.
 390        *)
 391       let sth =
 392         dbh#prepare_cached
 393           "set constraints pages_redirect_cn, sitemenu_url_cn deferred" in
 394       sth#execute [];
 395
 396       (* Mark the old page as deleted.  NB. There is a small race
 397        * condition here because PostgreSQL doesn't do isolation
 398        * properly.  If a user tries to visit this page between the
 399        * delete and the creation of the new page, then they'll get
 400        * a page not found error. (XXX)
 401        *)
 402       let sth = dbh#prepare_cached "update pages set url_deleted = url,
 403                                                      url = null
 404                                      where hostid = ? and id = ?" in
 405       sth#execute [`Int hostid; `Int model.id];
 406
 407       (* Get the IP address of the user, if available. *)
 408       let logged_ip =
 409         try `String (Connection.remote_ip (Request.connection r))
 410         with Not_found -> `Null in
 411
 412       let logged_user =
 413         match user with
 414           | User (id, _, _) -> `Int id
 415           | _ -> `Null in
 416
 417       (* Get redirect. *)
 418       let redirect = if model.redirect = "" then `Null
 419                      else `String model.redirect in
 420
 421       (* Create the new page. *)
 422       let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
 423                                       description, creation_date, logged_ip,
 424                                       logged_user, redirect, css)
 425                                     values (?, ?, ?, ?, ?, ?, ?, ?, ?)" in
 426       sth#execute [`Int hostid; `String url; `String title;
 427                    `String model.description; creation_date; logged_ip;
 428                    logged_user; redirect; css];
 429
 430       (* New page ID <> old page ID model.id. *)
 431       let pageid = sth#serial "pages_id_seq" in
 432
 433       (* Create the page contents. *)
 434       let sth = dbh#prepare_cached "insert into contents (pageid,
 435                                       ordering, sectionname, divname, content)
 436                                     values (?, ?, ?, ?, ?)" in
 437       let ordering = ref 0 in           (* Creating new ordering. *)
 438       List.iter (fun (sectionname, divname, content) ->
 439                    let divname =
 440                      if string_is_whitespace divname then `Null
 441                      else `String divname in
 442                    let sectionname =
 443                      if string_is_whitespace sectionname then `Null
 444                      else `String sectionname in
 445                    incr ordering; let ordering = !ordering in
 446                    sth#execute [`Int pageid; `Int ordering;
 447                                 sectionname; divname;
 448                                 `String content])
 449         model.contents;
 450
 451       (* Commit changes to the database. *)
 452       dbh#commit ();
 453
 454       (* Email notification, if anyone is listed for this host. *)
 455       let subject = "Page " ^ url ^ " has been edited" in
 456
 457       let body = fun () ->
 458         (* Prepare the diff between this version and the previous version. *)
 459         let diff, _ = get_diff dbh hostid url ~version:pageid () in
 460         "Page: http://" ^ hostname ^ "/" ^ url ^ "\n\n" ^
 461         diff in
 462
 463       email_notify ~body ~subject dbh hostid;
 464
 465       let buttons = [ ok_button ("/" ^ url) ] in
 466       ok ~title:"Saved" ~buttons
 467         q "The page was saved."
 468     );
 469
 470     no_errors
 471   in
 472
 473   let cancel id =
 474     let sth = dbh#prepare_cached "select url from pages
 475                                    where hostid = ? and id = ?" in
 476     sth#execute [`Int hostid; `Int id];
 477     let url = sth#fetch1string () in
 478
 479     q#redirect ("http://" ^ hostname ^ "/" ^ url)
 480   in
 481
 482   (* This codes decides where we are in the current editing cycle.
 483    *
 484    * Inputs:
 485    *   id - if set, then we are in the midst of editing a page.
 486    *   save - if set, then we want to save the page.
 487    *   cancel - if set, abandon changes and go back to viewing the page.
 488    *   action_* - one of the action buttons was set, eg. move up/down.
 489    *   page - the page URL opened newly for editing.
 490    *)
 491   (try
 492      let id = int_of_string (q#param "id") in
 493      if q#param_true "cancel" then (
 494        cancel id;
 495        return ()
 496      );
 497      if q#param_true "save" then (
 498        let ok = try_save () in
 499        if ok then return ()             (* ... else fall through *)
 500      );
 501      continue_editing ()                (* Processes the action, if any. *)
 502    with
 503        Not_found ->
 504          let page = q#param "page" in
 505          let page = if page = "" then "index" else page in
 506          begin_editing page);
 507
 508   q#template template
 509
 510 let () =
 511   register_script ~restrict:[CanEdit] run