2 * Written by Richard W.M. Jones <rich@merjis.com>.
3 * Copyright (C) 2004 Merjis Ltd.
4 * $Id: cocanwiki.ml,v 1.2 2004/09/07 13:40:10 rich Exp $
16 module Pool = DbiPool (Dbi_postgres)
18 (* Generate a printable datestamp for pages. *)
19 let printable_date (date, _) =
20 sprintf "%d %s %04d" date.Dbi.day (short_month date.Dbi.month) date.Dbi.year
22 let printable_date_time (date, time) =
23 sprintf "%d %s %04d %02d:%02d" date.Dbi.day (short_month date.Dbi.month)
24 date.Dbi.year time.Dbi.hour time.Dbi.min
26 (* This function is used to grab a database handle. It's used in a couple
27 * of very special places, and is not for general consumption.
29 let _get_dbh r = Pool.get r "cocanwiki"
31 (* The [CgiExit] exception should be folded back into the base
32 * mod_caml code at some point. It just causes the 'run' function to
33 * return at that point safely. (XXX)
37 (* Permissions and restrictions.
39 * Use the optional ~restrict parameter to register_script to restrict
40 * who can use the script. For example:
41 * register_script ~restrict:[CanEdit ; CanManageUsers] run
43 type permissions_t = CanEdit | CanManageUsers
45 (* The "user object". *)
46 type user_t = Anonymous (* Not logged in. *)
47 | User of int * string * permissions_t list
48 (* Userid, name, permissions. *)
50 let test_permission edit_anon perm user =
51 if perm = CanEdit && edit_anon then true
54 | User (_, _, perms) -> List.mem perm perms
56 let can_edit edit_anon = test_permission edit_anon CanEdit
57 let can_manage_users = test_permission false CanManageUsers
59 (* Our wrapper around the standard [register_script] function. *)
60 let register_script ?(restrict = []) run =
61 (* Actually register the script with the real [Registry] module. *)
65 let dbh = _get_dbh r in
67 (* Get the host ID, by comparing the Host: header with the hostnames
68 * table in the database.
70 let hostid, hostname, edit_anon =
71 let hostname = try Request.hostname r
72 with Not_found -> failwith "No ``Host:'' header in request" in
73 let hostname = String.lowercase hostname in
77 "select h.id, h.canonical_hostname, h.edit_anon
78 from hostnames hn, hosts h
79 where hn.name = ? and hn.hostid = h.id" in
80 sth#execute [`String hostname];
83 (match sth#fetch1 () with
84 [ `Int id; `String hostname; `Bool edit_anon ] ->
85 id, hostname, edit_anon
89 failwith ("Hostname ``" ^ hostname ^ "'' not found in " ^
90 "the hosts/hostnames tables in the database.") in
92 (* Look for the user's cookie, and determine from this the user
98 (* Allow the user to deliberately specify an extra "cookie"
99 * parameter, which we will send back as a cookie. This is
100 * useful for "mail my password"-type scripts.
102 if q#param_exists "cookie" then (
103 let value = q#param "cookie" in
104 let cookie = Cookie.cookie ~name:"auth" ~value ~path:"/" () in
105 Table.set (Request.headers_out r) "Set-Cookie" cookie#as_string;
108 (* Normal cookie, from the headers. *)
109 let header = Table.get (Request.headers_in r) "Cookie" in
110 let cookies = Cookie.parse header in
112 List.find (fun cookie -> cookie#name = "auth") cookies in
118 "select u.id, u.name, u.can_edit, u.can_manage_users
119 from usercookies uc, users u
120 where uc.cookie = ? and uc.userid = u.id and u.hostid = ?" in
121 sth#execute [`String cookie; `Int hostid];
122 (match sth#fetch1 () with
123 [ `Int userid; `String name;
124 `Bool can_edit; `Bool can_manage_users ] ->
126 (if can_edit then [ CanEdit ] else []) @
127 (if can_manage_users then [ CanManageUsers ] else []) in
128 User (userid, name, perms)
131 Not_found -> Anonymous
134 (* If the ~restrict parameter is given, then we want to check that
135 * the user has sufficient permission to run this script.
139 [] -> true (* empty list = no restrictions *)
141 List.fold_left ((||)) false
142 (List.map (fun r -> test_permission edit_anon r user) rs) in
145 (* Call the actual CGI script. *)
147 run r q dbh (hostid, hostname, edit_anon) user
151 error ~back_button:true
152 ~title:"Access denied"
153 q "You do not have permission to access this part of the site."