(* COCANWIKI - a wiki written in Objective CAML.
* Written by Richard W.M. Jones <rich@merjis.com>.
* Copyright (C) 2004 Merjis Ltd.
- * $Id: cocanwiki.ml,v 1.10 2004/09/23 11:51:17 rich Exp $
+ * $Id: cocanwiki.ml,v 1.16 2004/10/10 14:44:50 rich Exp $
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
*)
let _get_dbh r = Pool.get r "cocanwiki"
-(* Server-wide settings.
- *
- * These are stored in a single row in the database in the table
- * 'server_settings'. You must restart the server if you change
- * this row.
- *
- * It's not possible to read these at server start-up time because the
- * Apache server is still running as 'root' and will not normally be
- * allowed to access the database. We thus read them at the earliest
- * opportunity, in a request context, and cache the results.
- *)
-let server_settings_version =
- let settings = ref None in
- let get_settings (dbh : Dbi.connection) =
- let sth = dbh#prepare "select version from server_settings" in
- sth#execute [];
- let s =
- match sth#fetch1 () with
- | [ `Int version ] -> version
- | _ -> assert false in
- sth#finish ();
- settings := Some s;
- s
- in
-
- let server_settings_version dbh =
- let (version) =
- match !settings with
- None -> get_settings dbh
- | Some settings -> settings in
- version
- in
-
- server_settings_version
-
-(* The [CgiExit] exception should be folded back into the base
- * mod_caml code at some point. It just causes the 'run' function to
- * return at that point safely. (XXX)
- *)
-exception CgiExit
+(* The "host object". *)
+type host_t = { hostname : string;
+ edit_anon : bool;
+ view_anon : bool }
(* Permissions and restrictions.
*
* who can use the script. For example:
* register_script ~restrict:[CanEdit ; CanManageUsers] run
*)
-type permissions_t = CanEdit | CanManageUsers | CanManageContacts
+type permissions_t = CanView | CanEdit | CanManageUsers | CanManageContacts
| CanManageSite | CanEditGlobalCSS
(* The "user object". *)
| User of int * string * permissions_t list
(* Userid, name, permissions. *)
-let test_permission edit_anon perm user =
+let test_permission {edit_anon = edit_anon; view_anon = view_anon} perm user =
if perm = CanEdit && edit_anon then true
+ else if perm = CanView && view_anon then true
else match user with
Anonymous -> false
| User (_, _, perms) -> List.mem perm perms
-let can_edit edit_anon = test_permission edit_anon CanEdit
-let can_manage_users = test_permission false CanManageUsers
-let can_manage_contacts = test_permission false CanManageContacts
-let can_manage_site = test_permission false CanManageSite
-let can_edit_global_css = test_permission false CanEditGlobalCSS
-
-(* The "host object". *)
-type host_t = { hostname : string;
- edit_anon : bool; }
+let can_edit host = test_permission host CanEdit
+let can_manage_users host = test_permission host CanManageUsers
+let can_manage_contacts host = test_permission host CanManageContacts
+let can_manage_site host = test_permission host CanManageSite
+let can_edit_global_css host = test_permission host CanEditGlobalCSS
(* Our wrapper around the standard [register_script] function.
*
(* Get the host ID, by comparing the Host: header with the hostnames
* table in the database.
*)
- let hostid, hostname, edit_anon =
+ let hostid, hostname, edit_anon, view_anon =
let hostname = try Request.hostname r
with Not_found -> failwith "No ``Host:'' header in request" in
let hostname = String.lowercase hostname in
let sth =
dbh#prepare_cached
- "select h.id, h.canonical_hostname, h.edit_anon
+ "select h.id, h.canonical_hostname, h.edit_anon, h.view_anon
from hostnames hn, hosts h
where hn.name = ? and hn.hostid = h.id" in
sth#execute [`String hostname];
try
(match sth#fetch1 () with
- [ `Int id; `String hostname; `Bool edit_anon ] ->
- id, hostname, edit_anon
+ [ `Int id; `String hostname;
+ `Bool edit_anon; `Bool view_anon ] ->
+ id, hostname, edit_anon, view_anon
| _ -> assert false)
with
Not_found ->
"the hosts/hostnames tables in the database.") in
(* Create the host object. *)
- let host = { hostname = hostname; edit_anon = edit_anon; } in
+ let host = { hostname = hostname;
+ edit_anon = edit_anon;
+ view_anon = view_anon } in
(* Look for the user's cookie, and determine from this the user
* object.
`Bool can_edit; `Bool can_manage_users;
`Bool can_manage_contacts; `Bool can_manage_site;
`Bool can_edit_global_css ] ->
- let perms = if can_edit then [ CanEdit ] else [] in
+ (* Every logged in user can view. *)
+ let perms = [CanView] in
+ let perms =
+ if can_edit then CanEdit :: perms
+ else perms in
let perms =
if can_manage_users then CanManageUsers :: perms
else perms in
[] -> true (* empty list = no restrictions *)
| rs ->
List.fold_left (||) false
- (List.map (fun r -> test_permission edit_anon r user) rs) in
+ (List.map (fun r -> test_permission host r user) rs) in
if permitted then (
(* Call the actual CGI script. *)
- try
- run r q dbh hostid host user
- with
- CgiExit -> ()
- ) else
- error ~back_button:true
- ~title:"Access denied"
- q "You do not have permission to access this part of the site."
+ run r q dbh hostid host user
+ ) else (
+ if user = Anonymous then
+ q#redirect ("http://" ^ hostname ^ "/_login")
+ else
+ error ~back_button:true
+ ~title:"Access denied"
+ q "You do not have permission to access this part of the site."
+ )
)
(* Convert a section name into something valid for use in <a name="...">
if not (isalnum str.[i]) then str.[i] <- '_'
done;
str
+
+(* List of extensions currently registered. *)
+type extension_t = Dbi.connection -> int -> string -> string
+let extensions = ref ([] : (string * extension_t) list)
+
+(* Maximum degree of redirection. *)
+let max_redirect = 4