X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=scripts%2Flib%2Fcocanwiki.ml;h=d1f8ec6c993ccf4258749e62da3e9d1a082ae3e9;hb=d303f75eed3a09bbe2516d9a2a9a4aa9b862ceb3;hp=38480bac7aa20b9450ef48c611bfda44d2a7e8bc;hpb=5468846e2527f6a141f958b5002d85a043224cc8;p=cocanwiki.git diff --git a/scripts/lib/cocanwiki.ml b/scripts/lib/cocanwiki.ml index 38480ba..d1f8ec6 100644 --- a/scripts/lib/cocanwiki.ml +++ b/scripts/lib/cocanwiki.ml @@ -1,7 +1,7 @@ (* COCANWIKI - a wiki written in Objective CAML. * Written by Richard W.M. Jones . * Copyright (C) 2004 Merjis Ltd. - * $Id: cocanwiki.ml,v 1.4 2004/11/10 16:52:04 rich Exp $ + * $Id: cocanwiki.ml,v 1.9 2006/03/27 16:43:44 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 @@ -27,13 +27,6 @@ open Printf open Cocanwiki_ok open Cocanwiki_strings -module Pool = DbiPool (Dbi_postgres) - -(* This function is used to grab a database handle. It's used in a couple - * of very special places, and is not for general consumption. - *) -let _get_dbh r = Pool.get r "cocanwiki" - (* The "host object". *) type host_t = { hostname : string; canonical_hostname : string; @@ -57,7 +50,7 @@ type prefs_t = { (* The "user object". *) type user_t = Anonymous (* Not logged in. *) - | User of int * string * permissions_t list * prefs_t + | User of int32 * string * permissions_t list * prefs_t (* Userid, name, perms, prefs. *) let test_permission {edit_anon = edit_anon; view_anon = view_anon} perm user = @@ -97,146 +90,182 @@ let register_script ?(restrict = []) ?(anonymous = true) run = register_script (fun r -> let q = new cgi r in - let dbh = _get_dbh r in - - (* Get the host ID, by comparing the Host: header with the hostnames - * table in the database. - *) - let hostid, hostname, canonical_hostname, edit_anon, view_anon = - let hostname = try Request.hostname r - with Not_found -> - error ~back_button:true - ~title:"Browser problem" q - ("Your browser didn't send a \"Host\" header as part of " ^ - "the HTTP request. Unfortunately this web server cannot " ^ - "handle HTTP requests without a \"Host\" header."); - return () in - let hostname = String.lowercase hostname in - let sth = - dbh#prepare_cached - "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]; + (* XXX Database pooling. *) + let dbh = PGOCaml.connect ~database:"cocanwiki" () in + PGOCaml.begin_work dbh; + let exn = try - (match sth#fetch1 () with - [ `Int id; `String canonical_hostname; - `Bool edit_anon; `Bool view_anon ] -> - id, hostname, canonical_hostname, edit_anon, view_anon - | _ -> assert false) - with - Not_found -> + (* Get the host ID, by comparing the Host: header with the hostnames + * table in the database. + *) + let hostid, hostname, canonical_hostname, edit_anon, view_anon = + let hostname = try Request.hostname r + with Not_found -> + error ~back_button:true + ~title:"Browser problem" dbh (-1l) q + ("Your browser didn't send a \"Host\" header as part of " ^ + "the HTTP request. Unfortunately this web server cannot "^ + "handle HTTP requests without a \"Host\" header."); + return () in + let hostname = String.lowercase hostname in + + let rows = + PGSQL(dbh) + "select h.id, h.canonical_hostname, h.edit_anon, h.view_anon + from hostnames hn, hosts h + where hn.name = $hostname and hn.hostid = h.id" in + + match rows with + | [id, canonical_hostname, edit_anon, view_anon] -> + id, hostname, canonical_hostname, edit_anon, view_anon + | [] -> error ~back_button:true - ~title:"Unknown website" q + ~title:"Unknown website" dbh (-1l) q ("No website called \"" ^ hostname ^ "\" can be found. " ^ "If you are the administrator of this site, check that " ^ "the hostname is listed in the \"hostnames\" table " ^ "in the database."); - return () in + return () + | _ -> assert false in - (* Create the host object. *) - let host = { hostname = hostname; - canonical_hostname = canonical_hostname; - edit_anon = edit_anon; - view_anon = view_anon } in + (* Create the host object. *) + let host = { hostname = hostname; + canonical_hostname = canonical_hostname; + edit_anon = edit_anon; + view_anon = view_anon } in - (* Look for the user's cookie, and determine from this the user - * object. - *) - let user = - try - let cookie = - (* Allow the user to deliberately specify an extra "cookie" - * parameter, which we will send back as a cookie. This is - * useful for "mail my password"-type scripts. - *) - if q#param_exists "cookie" then ( - let value = q#param "cookie" in - let cookie = Cookie.cookie ~name:"auth" ~value ~path:"/" () in - Table.set (Request.headers_out r) "Set-Cookie" cookie#as_string; - value - ) else ( - (* Normal cookie, from the headers. *) - let header = Table.get (Request.headers_in r) "Cookie" in - let cookies = Cookie.parse header in + (* Look for the user's cookie, and determine from this the user + * object. + *) + let user = + try let cookie = - List.find (fun cookie -> cookie#name = "auth") cookies in - cookie#value - ) in + (* Allow the user to deliberately specify an extra "cookie" + * parameter, which we will send back as a cookie. This is + * useful for "mail my password"-type scripts. + *) + if q#param_exists "cookie" then ( + let value = q#param "cookie" in + let cookie = Cookie.cookie "auth" value ~path:"/" in + Table.set (Request.headers_out r) + "Set-Cookie" cookie#to_string; + value + ) else ( + (* Normal cookie, from the headers. *) + let header = Table.get (Request.headers_in r) "Cookie" in + let cookies = Cookie.parse header in + let cookie = + List.find (fun cookie -> cookie#name = "auth") cookies in + cookie#value + ) in + + let rows = + PGSQL(dbh) + "select u.id, u.name, u.can_edit, u.can_manage_users, + u.can_manage_contacts, u.can_manage_site, + u.can_edit_global_css, u.can_import_mail, + u.email, u.email_notify + from usercookies uc, users u + where uc.cookie = $cookie + and uc.userid = u.id + and u.hostid = $hostid" in + match rows with + | [userid, name, can_edit, can_manage_users, + can_manage_contacts, can_manage_site, + can_edit_global_css, can_import_mail, + email, email_notify] -> + (* 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 + let perms = + if can_manage_contacts then CanManageContacts :: perms + else perms in + let perms = + if can_manage_site then CanManageSite :: perms + else perms in + let perms = + if can_edit_global_css then CanEditGlobalCSS :: perms + else perms in + let perms = + if can_import_mail then CanImportMail :: perms + else perms in + (* Preferences. *) + let prefs = { email = email; + email_notify = email_notify; } in + User (userid, name, perms, prefs) + | [] -> raise Not_found + | _ -> assert false + with + Not_found -> Anonymous in + + (* If the ~restrict parameter is given, then we want to check that + * the user has sufficient permission to run this script. + *) + let permitted = + if not anonymous && user = Anonymous then false + else + match restrict with + | [] -> true (* empty list = no restrictions *) + | rs -> + List.fold_left (||) false + (List.map (fun r -> test_permission host r user) rs) in + + if permitted then ( + (* Call the actual CGI script. *) + run r q dbh hostid host user + ) else ( + if user = Anonymous then ( + (* Not logged in and no permission to do the requested action, + * so redirect to the login script. If possible set the + * redirect parameter so that we return to the right URL. + *) + let redirect = + try + (* If we passed through mod_rewrite, then it saved the + * unmodified original URL in a subprocess environment + * variable called SCRIPT_URL: + *) + let tbl = Request.subprocess_env r in + Some (Table.get tbl "SCRIPT_URL") + with + Not_found -> + try + (* Otherwise try the ordinary uri field + * in request_rec. + *) + Some (Request.uri r) + with Not_found -> + None in + + let url = + "http://" ^ hostname ^ "/_login" ^ + match redirect with + | None -> "" + | Some url -> "?redirect=" ^ Cgi_escape.escape_url url in + q#redirect url + ) else + error ~back_button:true + ~title:"Access denied" + dbh hostid q + "You do not have permission to access this part of the site." + ); - let sth = - dbh#prepare_cached - "select u.id, u.name, u.can_edit, u.can_manage_users, - u.can_manage_contacts, u.can_manage_site, - u.can_edit_global_css, u.can_import_mail, - u.email, u.email_notify - from usercookies uc, users u - where uc.cookie = ? and uc.userid = u.id and u.hostid = ?" in - sth#execute [`String cookie; `Int hostid]; - (match sth#fetch1 () with - [ `Int userid; `String name; - `Bool can_edit; `Bool can_manage_users; - `Bool can_manage_contacts; `Bool can_manage_site; - `Bool can_edit_global_css; `Bool can_import_mail; - (`Null | `String _) as email; `Bool email_notify ] -> - (* 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 - let perms = - if can_manage_contacts then CanManageContacts :: perms - else perms in - let perms = - if can_manage_site then CanManageSite :: perms - else perms in - let perms = - if can_edit_global_css then CanEditGlobalCSS :: perms - else perms in - let perms = - if can_import_mail then CanImportMail :: perms - else perms in - (* Preferences. *) - let email = - match email with - `Null -> None - | `String email -> Some email in - let prefs = { email = email; - email_notify = email_notify; } in - User (userid, name, perms, prefs) - | _ -> assert false) + None (* no exception *) with - Not_found -> Anonymous - in + exn -> Some exn in - (* If the ~restrict parameter is given, then we want to check that - * the user has sufficient permission to run this script. - *) - let permitted = - if not anonymous && user = Anonymous then false - else - match restrict with - [] -> true (* empty list = no restrictions *) - | rs -> - List.fold_left (||) false - (List.map (fun r -> test_permission host r user) rs) in + (* XXX Connection pooling - see above. *) + PGOCaml.close dbh; - if permitted then ( - (* Call the actual CGI script. *) - 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." - ) + (* May re-raise the caught exception. *) + Option.may raise exn ) (* Convert a section name into something valid for use in @@ -252,7 +281,7 @@ let linkname_of_sectionname str = str (* List of extensions currently registered. *) -type extension_t = Dbi.connection -> int -> string -> string +type extension_t = PGOCaml.pa_pg_data PGOCaml.t -> int32 -> string -> string let extensions = ref ([] : (string * extension_t) list) (* Maximum degree of redirection. *)