scripts/edit_sitemenu.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_sitemenu.ml,v 1.8 2004/12/01 13:55:55 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 open ExtList
  29
  30 open Cocanwiki
  31 open Cocanwiki_template
  32 open Cocanwiki_ok
  33 open Cocanwiki_emailnotify
  34 open Cocanwiki_strings
  35
  36 (* We keep an "internal model" of the menu - see build_internal_model ()
  37  * below.
  38  *)
  39 type model_t = (string * string) list   (* label, url *)
  40
  41 let run r (q : cgi) (dbh : Dbi.connection) hostid { hostname = hostname } user=
  42   let template = get_template dbh hostid "edit_sitemenu.html" in
  43
  44   (* Workaround bugs in IE, specifically lack of support for <button>
  45    * elements.
  46    *)
  47   let msie =
  48     try
  49       let ua = Table.get (Request.headers_in r) "User-Agent" in
  50       ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
  51       true
  52     with
  53         Not_found | Invalid_string -> false in
  54   template#conditional "msie" msie;
  55
  56   (* Pull in the list of URLs in useful format. *)
  57   let sth = dbh#prepare_cached "select url, title from pages
  58                                  where hostid = ?
  59                                    and url is not null
  60                                    and url <> 'index'
  61                                  order by 2" in
  62   sth#execute [`Int hostid];
  63
  64   let urls = sth#map (function [`String url; `String title] ->
  65                         url, title
  66                         | _ -> assert false) in
  67
  68   (* Build the internal model from the parameters passed to the script. *)
  69   let build_internal_model () =
  70     let model = ref [] in
  71     let i = ref 1 in
  72     while q#param_exists ("label_" ^ string_of_int !i) do
  73       let label = q#param ("label_" ^ string_of_int !i) in
  74       let url = q#param ("url_" ^ string_of_int !i) in
  75       model := (label, url) :: !model;
  76       incr i
  77     done;
  78     (List.rev !model : model_t)
  79   in
  80
  81   (* Check for errors in the model. *)
  82   let check_for_errors model =
  83     let errors = ref [] in
  84     let add_error msg = errors := msg :: !errors in
  85     let get_errors () = List.rev !errors in
  86
  87     (* XXX Not implemented yet. *)
  88
  89
  90
  91
  92     get_errors ()
  93   in
  94
  95   (* Various "actions" that can be performed on the model. *)
  96   let action_insert model posn item =
  97     (* posn = 0 means insert before the first element of the current list. *)
  98     let rec loop =
  99       function
 100           0, xs -> item :: xs
 101         | _, [] -> [ item ]
 102         | n, x :: xs -> x :: (loop (n-1, xs))
 103     in
 104     loop (posn, model)
 105   in
 106   let action_moveup model posn =
 107     (* posn = 1 means move up the first element, ie. do nothing
 108      * posn = 2 means move up the second element to the first position
 109      * etc.
 110      *)
 111     let rec loop =
 112       function
 113           0, xs
 114         | 1, xs -> xs
 115         | _, [] -> []
 116         | 2, x :: y :: xs -> y :: x :: xs
 117         | n, x :: xs -> x :: (loop (n-1, xs))
 118     in
 119     loop (posn, model)
 120   in
 121   let action_movedn model posn =
 122     (* posn = 1 means move down the first element to the second position
 123      * etc.
 124      *)
 125     let rec loop =
 126       function
 127           0, xs -> xs
 128         | _, [] -> []
 129         | 1, x :: y :: xs -> y :: x :: xs
 130         | n, x :: xs -> x :: (loop (n-1, xs))
 131     in
 132     loop (posn, model)
 133   in
 134   let action_delete model posn =
 135     (* posn = 1 means delete the first element *)
 136     let rec loop =
 137       function
 138           0, xs -> xs
 139         | _, [] -> []
 140         | 1, x :: xs -> xs
 141         | n, x :: xs -> x :: (loop (n-1, xs))
 142     in
 143     loop (posn, model)
 144   in
 145
 146   (* Convert model to template. *)
 147   let model_to_template model template =
 148     let ordering = ref 0 in
 149     let table =
 150       List.map
 151         (fun (label, url) ->
 152            incr ordering; let ordering = !ordering in
 153
 154            let table =
 155              List.map
 156                (fun (u, title) ->
 157                   let selected = u = url in
 158                   [ "url", Template.VarString u;
 159                     "title", Template.VarString (truncate 30 title);
 160                     "selected", Template.VarConditional selected ]) urls in
 161
 162            [ "ordering", Template.VarString (string_of_int ordering);
 163              "label", Template.VarString label;
 164              "url", Template.VarString url;
 165              "urls", Template.VarTable table; ]) model in
 166     template#table "contents" table;
 167
 168     (* Check for errors and put those into the template. *)
 169     let errors = check_for_errors model in
 170     let errors = List.map (fun msg ->
 171                              [ "error", Template.VarString msg ]) errors in
 172     template#table "errors" errors;
 173     template#conditional "has_errors" (errors <> [])
 174   in
 175
 176   (* Begin editing a page, pulling the menu out of the database and building
 177    * a model from it.
 178    *)
 179   let begin_editing () =
 180     let sth = dbh#prepare_cached "select label, url, ordering
 181                                     from sitemenu
 182                                    where hostid = ?
 183                                    order by ordering" in
 184     sth#execute [`Int hostid];
 185
 186     let model = sth#map (function [`String label; `String url; _] ->
 187                            label, url
 188                            | _ -> assert false) in
 189
 190     model_to_template model template
 191   in
 192
 193   let continue_editing () =
 194     let model = ref (build_internal_model ()) in
 195
 196     (* An "action" parameter? *)
 197     let is_action, get_action =
 198       let actions = q#params in
 199       (* Don't actually care about the value fields ... *)
 200       let actions = List.map (fun (str, _) -> str) actions in
 201       (* Some of our actions are imagemaps, so parameters like name.x, name.y
 202        * need to be changed to name and have resulting duplicates removed.
 203        *)
 204       let actions =
 205         List.filter (fun str ->
 206                        String.length str > 7 &&
 207                        String.sub str 0 7 = "action_" &&
 208                        not (String.ends_with str ".y")) actions in
 209       let actions =
 210         List.map (fun str ->
 211                     if String.ends_with str ".x" then (
 212                       let str = String.sub str 0 (String.length str - 2) in
 213                       str
 214                     )
 215                     else str) actions in
 216       let actions =
 217         List.map (fun str ->
 218                     let action_type = String.sub str 7 6 in
 219                     let action_value =
 220                       String.sub str 14 (String.length str - 14) in
 221                     let action_value = int_of_string action_value in
 222                     action_type, action_value) actions in
 223
 224       let is_action typ = List.mem_assoc typ actions in
 225       let get_value typ = List.assoc typ actions in
 226
 227       is_action, get_value
 228     in
 229
 230     if is_action "insert" then (
 231       let posn = get_action "insert" in
 232       let item = "", "" in
 233       model := action_insert !model posn item
 234     ) else if is_action "moveup" then (
 235       let posn = get_action "moveup" in
 236       model := action_moveup !model posn
 237     ) else if is_action "movedn" then (
 238       let posn = get_action "movedn" in
 239       model := action_movedn !model posn
 240     ) else if is_action "delete" then (
 241       let posn = get_action "delete" in
 242       model := action_delete !model posn
 243     );
 244
 245     model_to_template !model template
 246   in
 247
 248   (* Try to save the page.  Returns a boolean indicating if the
 249    * page was saved successfully.
 250    *)
 251   let try_save () =
 252     let model = build_internal_model () in
 253     let no_errors = [] = check_for_errors model in
 254     if no_errors then (
 255       (* No errors, so we can save the page ... *)
 256
 257       let sth = dbh#prepare_cached "delete from sitemenu where hostid = ?" in
 258       sth#execute [`Int hostid];
 259
 260       let sth = dbh#prepare_cached "insert into sitemenu (hostid, label, url,
 261                                     ordering) values (?, ?, ?, ?)" in
 262
 263       List.iteri (fun i (label, url) ->
 264                     let ordering = 10 * (i+1) in
 265                     sth#execute [`Int hostid; `String label; `String url;
 266                                  `Int ordering]) model;
 267
 268       (* Commit changes to the database. *)
 269       dbh#commit ();
 270
 271       (* Email notification, if anyone is listed for this host. *)
 272       let subject = "The site menu has been edited" in
 273
 274       let body = fun () -> "Site: http://" ^ hostname ^ "/\n\n" in
 275
 276       email_notify ~body ~subject ~user dbh hostid;
 277
 278       let buttons = [ ok_button "/_bin/host_menu.cmo" ] in
 279       ok ~title:"Saved" ~buttons
 280         q "The site menu was saved."
 281     );
 282
 283     no_errors
 284   in
 285
 286   let cancel () =
 287     q#redirect ("http://" ^ hostname ^ "/_bin/host_menu.cmo")
 288   in
 289
 290   (* This codes decides where we are in the current editing cycle.
 291    *
 292    * Inputs:
 293    *   inedit - if set, then we are in the midst of editing a page.
 294    *   save - if set, then we want to save the page.
 295    *   cancel - if set, abandon changes and go back to viewing the page.
 296    *   action_* - one of the action buttons was set, eg. move up/down.
 297    *   page - the page URL opened newly for editing.
 298    *)
 299   if q#param_true "inedit" then (
 300     if q#param_true "cancel" then (
 301       cancel ();
 302       return ()
 303     );
 304     if q#param_true "save" then (
 305       let ok = try_save () in
 306       if ok then return ()              (* ... else fall through *)
 307     );
 308     continue_editing ()                 (* Processes the action, if any. *)
 309   ) else
 310     begin_editing ();
 311
 312   q#template template
 313
 314 let () =
 315   register_script ~restrict:[CanEdit] run