X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=scripts%2Flib%2Fcocanwiki.ml;h=ad625c10ef0e019bdb7a08a9af473726741b6af2;hb=cd059731a60fd3d4dcf426430ad26ff227b91910;hp=33eb3b5ebbb45d2bccc3183cd93b11f2580aab17;hpb=295f2cde3f43ccf7f775d39b95925e10aa4c37cb;p=cocanwiki.git diff --git a/scripts/lib/cocanwiki.ml b/scripts/lib/cocanwiki.ml index 33eb3b5..ad625c1 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.5 2005/03/31 14:24:04 rich Exp $ + * $Id: cocanwiki.ml,v 1.10 2006/03/28 16:24:08 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 = @@ -74,6 +67,24 @@ let can_manage_site host = test_permission host CanManageSite let can_edit_global_css host = test_permission host CanEditGlobalCSS let can_import_mail host = test_permission host CanImportMail +let get_uri_from_request r = + 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 + (* Our wrapper around the standard [register_script] function. * * The optional ~restrict and ~anonymous parameters work as follows: @@ -97,146 +108,192 @@ 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 "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 + (* 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 - 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) + 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 = get_uri_from_request r 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." + ); + + None (* no exception *) with - Not_found -> Anonymous - in + exn -> Some exn in + + (* XXX Connection pooling - see above. *) + PGOCaml.close dbh; - (* If the ~restrict parameter is given, then we want to check that - * the user has sufficient permission to run this script. + (* To help with debugging, if there is an exception, print some + * extended details. *) - 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 + (match exn with + | Some exn -> + fprintf stderr "COCANWIKI exception: %S\n" (Std.dump exn); + fprintf stderr "Time: %s\n" + (Printer.CalendarPrinter.to_string (Calendar.now ())); + let hostname = + try Some (Request.hostname r) with Not_found -> None in + fprintf stderr "Host: "; + (match hostname with + | None -> fprintf stderr "not available\n" + | Some hostname -> fprintf stderr "%S\n" hostname + ); + let uri = get_uri_from_request r in + fprintf stderr "Request: "; + (match uri with + | None -> fprintf stderr "not available\n" + | Some uri -> fprintf stderr "%S\n" uri + ); + | _ -> () + ); - 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 +309,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. *)