UPPERCASE urls redirect to lowercase versions now.

diff --git a/scripts/page.ml b/scripts/page.ml
index 325a8da..aa66aed 100644 (file)
--- a/scripts/page.ml
+++ b/scripts/page.ml
@@ -1,7 +1,7 @@
 (* COCANWIKI - a wiki written in Objective CAML.
  * Written by Richard W.M. Jones <rich@merjis.com>.
  * Copyright (C) 2004 Merjis Ltd.
- * $Id: page.ml,v 1.40 2004/11/22 11:07:32 rich Exp $
+ * $Id: page.ml,v 1.41 2005/11/23 11:05:54 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
@@ -35,7 +35,8 @@ open Cocanwiki_server_settings
 open Cocanwiki_links
 
 type fp_status = FPOK of int * string * string * Dbi.datetime * bool
-              | FPRedirect of string
+              | FPInternalRedirect of string
+              | FPExternalRedirect of string
               | FPNotFound
 
 (* Referer strings which help us decide if the user came from
@@ -53,8 +54,7 @@ let split_qs_re = Pcre.regexp "\\?"
 let xhtml_re = Pcre.regexp "<.*?>|[^<>]+"
 
 let run r (q : cgi) (dbh : Dbi.connection) hostid
-    ({ edit_anon = edit_anon;
-       view_anon = view_anon } as host)
+    ({ edit_anon = edit_anon; view_anon = view_anon } as host)
     user =
   let page = q#param "page" in
   let page = if page = "" then "index" else page in
@@ -413,30 +413,29 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid
    * (2) Page is a redirect (fetches the name of the redirect page).
    * (3) Page not found in database, could be template or 404 error.
    *)
-  (* XXX Should do a case-insensitive matching of URLs, and if the URL differs
-   * in case only should redirect to the lowercase version.
-   *)
   let fetch_page page version allow_redirect =
     match version with
       | None ->
          if allow_redirect then (
            let sth =
              dbh#prepare_cached
-               "select redirect, id, title, description, last_modified_date,
-                        css is not null
-                   from pages where hostid = ? and url = ?" in
+               "select url, redirect, id, title, description,
+                        last_modified_date, css is not null
+                   from pages where hostid = ? and lower (url) = lower (?)" in
            sth#execute [`Int hostid; `String page];
            (try
               (match sth#fetch1 () with
-                 | [ `Null; `Int id; `String title; `String description;
-                     `Timestamp last_modified_date; `Bool has_page_css ] ->
-                     FPOK (id, title, description, last_modified_date,
-                           has_page_css)
-                 | `String redirect :: _ ->
-                     FPRedirect redirect
-                 | _ -> assert false)
+               | `String page' :: _ when page <> page' -> (* different case *)
+                   FPExternalRedirect page'
+               | [ _; `Null; `Int id; `String title; `String description;
+                   `Timestamp last_modified_date; `Bool has_page_css ] ->
+                   FPOK (id, title, description, last_modified_date,
+                         has_page_css)
+               | _ :: `String redirect :: _ ->
+                   FPInternalRedirect redirect
+               | xs -> failwith (Dbi.sdebug xs))
             with
-                Not_found -> FPNotFound)
+              Not_found -> FPNotFound)
          ) else (* redirects not allowed ... *) (
            let sth =
              dbh#prepare_cached
@@ -446,11 +445,11 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid
            sth#execute [`Int hostid; `String page];
            (try
               (match sth#fetch1 () with
-                 | [ `Int id; `String title; `String description;
-                     `Timestamp last_modified_date; `Bool has_page_css ] ->
-                     FPOK (id, title, description, last_modified_date,
-                           has_page_css)
-                 | _ -> assert false)
+               | [ `Int id; `String title; `String description;
+                   `Timestamp last_modified_date; `Bool has_page_css ] ->
+                   FPOK (id, title, description, last_modified_date,
+                         has_page_css)
+               | xs -> failwith (Dbi.sdebug xs))
             with
                 Not_found -> FPNotFound)
          )
@@ -466,11 +465,11 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid
                         `String page; `String page];
            (try
               (match sth#fetch1 () with
-                 | [ `Int id; `String title; `String description;
-                     `Timestamp last_modified_date; `Bool has_page_css ] ->
-                     FPOK (id, title, description, last_modified_date,
-                           has_page_css)
-                 | _ -> assert false)
+               | [ `Int id; `String title; `String description;
+                   `Timestamp last_modified_date; `Bool has_page_css ] ->
+                   FPOK (id, title, description, last_modified_date,
+                         has_page_css)
+               | xs -> failwith (Dbi.sdebug xs))
             with
                 Not_found -> FPNotFound)
   in
@@ -498,8 +497,14 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid
            make_page title (Some description) (Some pageid)
              (printable_date last_modified_date) has_page_css
              version page page' extension
-       | FPRedirect page' ->
+       | FPInternalRedirect page' ->
            loop page' (i+1)
+       | FPExternalRedirect page' ->
+           (* This normally happens when a user has request an uppercase
+            * page name.  We redirect to the true (lowercase) version.
+            *)
+           q#redirect ("http://" ^ host.hostname ^ "/" ^ page');
+           return ()
        | FPNotFound ->
            (* Might be a templated page with no content in it. *)
            let extension = get_extension page' in