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 $
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.
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.
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.
31 open Cocanwiki_template
33 open Cocanwiki_emailnotify
34 open Cocanwiki_strings
36 (* We keep an "internal model" of the menu - see build_internal_model ()
39 type model_t = (string * string) list (* label, url *)
41 let run r (q : cgi) dbh hostid { hostname = hostname } user=
42 let template = get_template dbh hostid "edit_sitemenu.html" in
44 (* Workaround bugs in IE, specifically lack of support for <button>
49 let ua = Table.get (Request.headers_in r) "User-Agent" in
50 ignore (String.find ua "MSIE"); (* Throws Invalid_string if not found. *)
53 Not_found | Invalid_string -> false in
54 template#conditional "msie" msie;
56 (* Pull in the list of URLs in useful format. *)
58 "select url, title from pages
59 where hostid = $hostid
63 let urls = List.map (fun (url, title) -> Option.get url, title) urls in
65 (* Build the internal model from the parameters passed to the script. *)
66 let build_internal_model () =
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;
75 (List.rev !model : model_t)
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
84 (* XXX Not implemented yet. *)
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. *)
99 | n, x :: xs -> x :: (loop (n-1, xs))
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
113 | 2, x :: y :: xs -> y :: x :: xs
114 | n, x :: xs -> x :: (loop (n-1, xs))
118 let action_movedn model posn =
119 (* posn = 1 means move down the first element to the second position
126 | 1, x :: y :: xs -> y :: x :: xs
127 | n, x :: xs -> x :: (loop (n-1, xs))
131 let action_delete model posn =
132 (* posn = 1 means delete the first element *)
138 | n, x :: xs -> x :: (loop (n-1, xs))
143 (* Convert model to template. *)
144 let model_to_template model template =
145 let ordering = ref 0 in
149 incr ordering; let ordering = !ordering in
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
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;
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 <> [])
173 (* Begin editing a page, pulling the menu out of the database and building
176 let begin_editing () =
178 PGSQL(dbh) "select label, url, ordering
180 where hostid = $hostid
181 order by ordering" in
183 let model = List.map (fun (label, url, _) -> label, url) rows in
185 model_to_template model template
188 let continue_editing () =
189 let model = ref (build_internal_model ()) in
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.
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
206 if String.ends_with str ".x" then (
207 let str = String.sub str 0 (String.length str - 2) in
213 let action_type = String.sub str 7 6 in
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
219 let is_action typ = List.mem_assoc typ actions in
220 let get_value typ = List.assoc typ actions in
225 if is_action "insert" then (
226 let posn = get_action "insert" 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
240 model_to_template !model template
243 (* Try to save the page. Returns a boolean indicating if the
244 * page was saved successfully.
247 let model = build_internal_model () in
248 let no_errors = [] = check_for_errors model in
250 (* No errors, so we can save the page ... *)
252 PGSQL(dbh) "delete from sitemenu where hostid = $hostid";
254 fun i (label, url) ->
255 let ordering = Int32.of_int (10 * (i+1)) in
257 "insert into sitemenu (hostid, label, url, ordering)
258 values ($hostid, $label, $url, $ordering)"
261 (* Commit changes to the database. *)
264 (* Email notification, if anyone is listed for this host. *)
265 let subject = "The site menu has been edited" in
267 let body = fun () -> "Site: http://" ^ hostname ^ "/\n\n" in
269 email_notify ~body ~subject ~user dbh hostid;
271 let buttons = [ ok_button "/_bin/host_menu.cmo" ] in
272 ok ~title:"Saved" ~buttons
273 dbh hostid q "The site menu was saved."
280 q#redirect ("http://" ^ hostname ^ "/_bin/host_menu.cmo")
283 (* This codes decides where we are in the current editing cycle.
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.
292 if q#param_true "inedit" then (
293 if q#param_true "cancel" then
295 if q#param_true "save" then (
296 let ok = try_save () in
297 if ok then return () (* ... else fall through *)
299 continue_editing () (* Processes the action, if any. *)
306 register_script ~restrict:[CanEdit] run