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