scripts/edit.ml

   1 (* COCANWIKI scripts.
   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 $
   5  *)
   6
   7 open Apache
   8 open Registry
   9 open Cgi
  10 open Printf
  11
  12 open ExtString
  13
  14 open Merjisforwiki
  15
  16 open Cocanwiki
  17 open Cocanwiki_template
  18 open Cocanwiki_ok
  19 open Cocanwiki_emailnotify
  20 open Cocanwiki_diff
  21
  22 let template = get_template "edit.html"
  23 let template_conflict = get_template "edit_conflict.html"
  24
  25 (* We keep an "internal model" of the page - see build_internal_model ()
  26  * below.
  27  *)
  28 type model_t = {
  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. *)
  35 }
  36
  37 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
  38   (* Workaround bugs in IE, specifically lack of support for <button>
  39    * elements.
  40    *)
  41   let msie =
  42     try
  43       let ua = Table.get (Request.headers_in r) "User-Agent" in
  44       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  45       true
  46     with
  47         Not_found | String.Invalid_string -> false in
  48   template#conditional "msie" msie;
  49
  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
  55
  56     let contents = ref [] in
  57     let i = ref 1 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;
  63       incr i
  64     done;
  65     let contents = List.rev !contents in
  66
  67     { id = id;
  68       description = description;
  69       redirect = redirect;
  70       contents = contents; }
  71   in
  72
  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
  78
  79     if model.redirect = "" then (
  80       (* Empty page? *)
  81       if model.contents = [] then
  82         add_error ("This page is empty.  Use 'Insert new section here' " ^
  83                    "to write something!");
  84
  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.");
  90     )
  91     else (* it's a redirect *) (
  92       (* Redirect points to a real page? *)
  93       let sth = dbh#prepare_cached "select 1 from pages
  94                                      where hostid = ?
  95                                        and url is not null
  96                                        and url = ?
  97                                        and id <> ?
  98                                        and redirect is null" in
  99       sth#execute [`Int hostid; `String model.redirect; `Int model.id];
 100
 101       let ok = try sth#fetch1 () = [`Int 1] with Not_found -> false in
 102       if not ok then
 103         add_error ("Redirect must point to an ordinary page " ^
 104                    "(ie. not to a page which is itself a redirect).")
 105     );
 106
 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.");
 111                  | _ -> ())
 112       model.contents;
 113
 114     get_errors ()
 115   in
 116
 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. *)
 120     let rec loop =
 121       function
 122           0, xs -> item :: xs
 123         | _, [] -> [ item ]
 124         | n, x :: xs -> x :: (loop (n-1, xs))
 125     in
 126     let contents = loop (posn, model.contents) in
 127     { model with contents = contents }
 128   in
 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
 132      * etc.
 133      *)
 134     let rec loop =
 135       function
 136           0, xs
 137         | 1, xs -> xs
 138         | _, [] -> []
 139         | 2, x :: y :: xs -> y :: x :: xs
 140         | n, x :: xs -> x :: (loop (n-1, xs))
 141     in
 142     let contents = loop (posn, model.contents) in
 143     { model with contents = contents }
 144   in
 145   let action_movedn model posn =
 146     (* posn = 1 means move down the first element to the second position
 147      * etc.
 148      *)
 149     let rec loop =
 150       function
 151           0, xs -> xs
 152         | _, [] -> []
 153         | 1, x :: y :: xs -> y :: x :: xs
 154         | n, x :: xs -> x :: (loop (n-1, xs))
 155     in
 156     let contents = loop (posn, model.contents) in
 157     { model with contents = contents }
 158   in
 159   let action_delete model posn =
 160     (* posn = 1 means delete the first element *)
 161     let rec loop =
 162       function
 163           0, xs -> xs
 164         | _, [] -> []
 165         | 1, x :: xs -> xs
 166         | n, x :: xs -> x :: (loop (n-1, xs))
 167     in
 168     let contents = loop (posn, model.contents) in
 169     { model with contents = contents }
 170   in
 171
 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;
 176
 177     (* Redirects table. *)
 178     let sth = dbh#prepare_cached "select url, title from pages
 179                                    where url is not null
 180                                      and redirect is null
 181                                      and hostid = ? and id <> ?
 182                                    order by 2" in
 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;
 191
 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;
 198
 199     let ordering = ref 0 in
 200     let table =
 201       List.map
 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;
 209
 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 <> [])
 216   in
 217
 218   (* Begin editing a page, pulling the page out of the database and building
 219    * a model from it.
 220    *)
 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, '')
 225                                     from pages
 226                                    where hostid = ? and url = ?" in
 227     sth#execute [`Int hostid; `String page];
 228
 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
 234
 235     (* Get the sections. *)
 236     let sth = dbh#prepare_cached "select sectionname, content,
 237                                          coalesce (divname, '')
 238                                     from contents
 239                                    where pageid = ?
 240                                    order by ordering" in
 241     sth#execute [`Int pageid];
 242
 243     let contents =
 244       sth#map (function
 245                  | [`String sectionname; `String content; `String divname] ->
 246                      sectionname, divname, content
 247                  | _ -> assert false) in
 248
 249     let model = { id = pageid;
 250                   description = description;
 251                   redirect = redirect;
 252                   contents = contents; } in
 253
 254     model_to_template model template
 255   in
 256
 257   let continue_editing () =
 258     let model = ref (build_internal_model ()) in
 259
 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.
 267        *)
 268       let actions =
 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
 273       let actions =
 274         List.map (fun str ->
 275                     if String.ends_with str ".x" then (
 276                       let str = String.sub str 0 (String.length str - 2) in
 277                       str
 278                     )
 279                     else str) actions in
 280       let actions =
 281         List.map (fun str ->
 282                     let action_type = String.sub str 7 6 in
 283                     let action_value =
 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
 287
 288       let is_action typ = List.mem_assoc typ actions in
 289       let get_value typ = List.assoc typ actions in
 290
 291       is_action, get_value
 292     in
 293
 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
 307     );
 308
 309     model_to_template !model template
 310   in
 311
 312   (* Try to save the page.  Returns a boolean indicating if the
 313    * page was saved successfully.
 314    *)
 315   let try_save () =
 316     let model = build_internal_model () in
 317     let no_errors = [] = check_for_errors model in
 318     if no_errors then (
 319       (* No errors, so we can save the page ... *)
 320
 321       (* Pull out fields from the database. *)
 322       let sth = dbh#prepare_cached "select creation_date,
 323                                            coalesce (url, url_deleted),
 324                                            title, css
 325                                       from pages
 326                                      where hostid = ? and id = ?" in
 327       sth#execute [`Int hostid; `Int model.id];
 328
 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
 334
 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];
 339
 340       let max_id = sth#fetch1int () in
 341       let edited = max_id <> model.id in
 342
 343       if edited then (
 344         (* Edited by someone else ...  Get the other's changes. *)
 345         let other_diff, _ =
 346           get_diff dbh hostid url ~old_version:model.id ~version:max_id () in
 347
 348         (* Synthesize our own changes. *)
 349         let old_page = get_version_for_diff dbh model.id in
 350         let new_page =
 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
 357
 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;
 364
 365         q#template template_conflict;
 366         raise CgiExit
 367       );
 368
 369       (* Defer the pages_redirect_cn constraint because that would
 370        * temporarily fail on the next UPDATE.
 371        *)
 372       let sth =
 373         dbh#prepare_cached "set constraints pages_redirect_cn deferred" in
 374       sth#execute [];
 375
 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)
 381        *)
 382       let sth = dbh#prepare_cached "update pages set url_deleted = url,
 383                                                      url = null
 384                                      where hostid = ? and id = ?" in
 385       sth#execute [`Int hostid; `Int model.id];
 386
 387       (* Get the IP address of the user, if available. *)
 388       let logged_ip =
 389         try `String (Connection.remote_ip (Request.connection r))
 390         with Not_found -> `Null in
 391
 392       (* Get redirect. *)
 393       let redirect = if model.redirect = "" then `Null
 394                      else `String model.redirect in
 395
 396       (* Create the new page. *)
 397       let sth = dbh#prepare_cached "insert into pages (hostid, url, title,
 398                                       description, creation_date, logged_ip,
 399                                       redirect, css)
 400                                     values (?, ?, ?, ?, ?, ?, ?, ?)" in
 401       sth#execute [`Int hostid; `String url; `String title;
 402                    `String model.description; creation_date; logged_ip;
 403                    redirect; css];
 404
 405       (* New page ID <> old page ID model.id. *)
 406       let pageid = sth#serial "pages_id_seq" in
 407
 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) ->
 414                    let divname =
 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;
 420                                 `String content])
 421         model.contents;
 422
 423       (* Commit changes to the database. *)
 424       dbh#commit ();
 425
 426       (* Email notification, if anyone is listed for this host. *)
 427       let subject = "Page " ^ url ^ " has been edited" in
 428
 429       let body = fun () ->
 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" ^
 433         diff in
 434
 435       email_notify ~body ~subject dbh hostid;
 436
 437       let buttons = [ ok_button ("/" ^ url) ] in
 438       ok ~title:"Saved" ~buttons
 439         q "The page was saved."
 440     );
 441
 442     no_errors
 443   in
 444
 445   let cancel id =
 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
 450
 451     q#redirect ("http://" ^ hostname ^ "/" ^ url)
 452   in
 453
 454   (* This codes decides where we are in the current editing cycle.
 455    *
 456    * Inputs:
 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.
 462    *)
 463   (try
 464      let id = int_of_string (q#param "id") in
 465      if q#param_true "cancel" then (
 466        cancel id;
 467        raise CgiExit
 468      );
 469      if q#param_true "save" then (
 470        let ok = try_save () in
 471        if ok then raise CgiExit         (* ... else fall through *)
 472      );
 473      continue_editing ()                (* Processes the action, if any. *)
 474    with
 475        Not_found ->
 476          let page = q#param "page" in
 477          let page = if page = "" then "index" else page in
 478          begin_editing page);
 479
 480   q#template template
 481
 482 let () =
 483   register_script run