X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=scripts%2Fpage.ml;h=db74684afa9035e6a41d17fa6dae5a27b0a89706;hb=d2de471ff7e79c1d6096bd8132aad80258852cdd;hp=47e6ae904e555ee5048f707be8150d46d3965452;hpb=4372ce9bf443ceca12449bcaf1a89460e85c05db;p=cocanwiki.git diff --git a/scripts/page.ml b/scripts/page.ml index 47e6ae9..db74684 100644 --- 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 . * Copyright (C) 2004 Merjis Ltd. - * $Id: page.ml,v 1.50 2006/08/03 13:33:15 rich Exp $ + * $Id: page.ml,v 1.59 2006/12/06 09:46:57 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 @@ -36,10 +36,12 @@ open Cocanwiki_links open Cocanwiki_extensions open Cocanwiki_strings -type fp_status = FPOK of int32 * string * string * Calendar.t * bool - | FPInternalRedirect of string - | FPExternalRedirect of string - | FPNotFound +type fp_status = + | FPOK of int32 * string * string * string option * Calendar.t * bool + * bool option + | FPInternalRedirect of string + | FPExternalRedirect of string + | FPNotFound (* Referer strings which help us decide if the user came from * a search engine and highlight terms in the page appropriately. @@ -71,22 +73,22 @@ let run r (q : cgi) dbh hostid *) let template_page_header = - get_template ~page dbh hostid "page_header.html" in - let template_page = get_template ~page dbh hostid "page.html" in + get_template ~page r dbh hostid "page_header.html" in + let template_page = get_template ~page r dbh hostid "page.html" in (* This is the simpler template for 404 pages. *) - let template_404_header = get_template dbh hostid "page_404_header.html" in - let template_404 = get_template dbh hostid "page_404.html" in + let template_404_header = get_template r dbh hostid "page_404_header.html" in + let template_404 = get_template r dbh hostid "page_404.html" in (* Host-specific fields. *) - let rows = PGSQL(dbh) - "select css is not null, feedback_email is not null, mailing_list, navigation - from hosts where id = $hostid" in - let has_host_css, has_feedback_email, mailing_list, navigation = + let rows = + PGSQL(dbh) + "select feedback_email is not null, mailing_list, navigation + from hosts where id = $hostid" in + let has_feedback_email, mailing_list, navigation = match rows with - | [Some has_host_css, Some has_feedback_email, - mailing_list, navigation] -> - has_host_css, has_feedback_email, mailing_list, navigation + | [Some has_feedback_email, mailing_list, navigation] -> + has_feedback_email, mailing_list, navigation | _ -> assert false in (* User permissions. *) @@ -182,12 +184,73 @@ let run r (q : cgi) dbh hostid in (* This code generates ordinary pages. *) - let make_page title description pageid last_modified_date has_page_css + let make_page title description keywords + pageid last_modified_date has_page_css noodp version page page' extension = let t = template_page in let th = template_page_header in - t#set "title" title; + (*t#set "title" title; - nothing uses ::title:: on page.html - removed *) + + (* Page title, h1 and superdirs (if any). *) th#set "title" title; + + let superdirs, h1 = + match String.nsplit title "/" with + | [] -> [], "" + | [h1] -> [], h1 + | xs -> + let xs = List.rev xs in + let h1 = List.hd xs in + let superdirs = List.rev (List.tl xs) in + + (* Check the superdirs are reasonable, then convert them + * into paths or redlinks. + * If any of this fails, then there are no superdirs. + *) + try + let pathsofar = ref "" in + let superdirs = + List.mapi ( + fun i name -> + (* Path will be something like "Dir1/Dir2". We want + * a URL like "dir1/dir2". + *) + let path = + if i = 0 then name else !pathsofar ^ "/" ^ name in + (* Path so far reasonable? *) + let url, redlink = + match Wikilib.generate_url_of_title r dbh hostid path with + | Wikilib.GenURL_Duplicate url -> url, None + | Wikilib.GenURL_OK url -> + (* Is it an extension page? *) + (match get_extension url with + | Some _ -> url, None (* extension page *) + | None -> url, Some path (* redlink *)) + | Wikilib.GenURL_BadURL | Wikilib.GenURL_TooShort -> + raise Exit in + pathsofar := path; + name, url, redlink + ) superdirs in + superdirs, h1 + with + Exit -> [], title in + + let superdirs = List.map ( + fun (name, url, redlink) -> + let is_redlink, redlink_title = + match redlink with + | None -> false, "" + | Some title -> true, title in + [ "url", Template.VarString url; + "name", Template.VarString name; + "is_redlink", Template.VarConditional is_redlink; + "redlink_title", Template.VarString redlink_title ] + ) superdirs in + + th#conditional "has_superdirs" (superdirs <> []); + th#table "superdirs" superdirs; + th#set "h1" h1; + t#set "last_modified_date" last_modified_date; (match description with @@ -196,6 +259,12 @@ let run r (q : cgi) dbh hostid th#conditional "has_description" true; th#set "description" description); + (match keywords with + None -> th#conditional "has_keywords" false + | Some keywords -> + th#conditional "has_keywords" true; + th#set "keywords" keywords); + if page <> page' then (* redirection *) ( t#set "page" page'; th#set "page" page'; @@ -207,9 +276,16 @@ let run r (q : cgi) dbh hostid t#conditional "redirected" false ); - th#conditional "has_host_css" has_host_css; th#conditional "has_page_css" has_page_css; + (* If the per-page noodp is not null, set the noodp flag here. Otherwise + * we will use the default (from hosts.global_noodp) which was set + * in Cocanwiki_template. + *) + (match noodp with + | None -> () + | Some b -> th#conditional "noodp" b); + (* Are we showing an old version of the page? If so, warn. *) (match version with None -> @@ -249,19 +325,33 @@ let run r (q : cgi) dbh hostid None -> [] | Some pageid -> let rows = PGSQL(dbh) - "select ordering, sectionname, content, divname, jsgo + "select ordering, sectionname, content, divname, divclass, jsgo from contents where pageid = $pageid order by ordering" in List.map - (fun (ordering, sectionname, content, divname, jsgo) -> + (fun (ordering, sectionname, content, divname, divclass, jsgo) -> let divname, has_divname = match divname with | None -> "", false | Some divname -> divname, true in + let divclass, has_divclass = + match divclass with + | None -> "", false + | Some divclass -> divclass, true in let jsgo, has_jsgo = match jsgo with | None -> "", false | Some jsgo -> jsgo, true in + + let has_divclass, divclass = + if has_jsgo then + (true, + if divclass = "" then "jsgo_div" + else divclass ^ " jsgo_div") + else + has_divclass, divclass in + let has_div = has_divname || has_divclass in + let sectionname, has_sectionname = match sectionname with | None -> "", false @@ -277,6 +367,9 @@ let run r (q : cgi) dbh hostid (Wikilib.xhtml_of_content r dbh hostid content); "has_divname", Template.VarConditional has_divname; "divname", Template.VarString divname; + "has_divclass", Template.VarConditional has_divclass; + "divclass", Template.VarString divclass; + "has_div", Template.VarConditional has_div; "has_jsgo", Template.VarConditional has_jsgo; "jsgo", Template.VarString jsgo ]) rows in @@ -293,6 +386,9 @@ let run r (q : cgi) dbh hostid "content", Template.VarString content; "has_divname", Template.VarConditional true; "divname", Template.VarString "form_div"; + "has_divclass", Template.VarConditional false; + "divclass", Template.VarString ""; + "has_div", Template.VarConditional true; "has_jsgo", Template.VarConditional false; "jsgo", Template.VarString ""; ] in @@ -317,13 +413,22 @@ let run r (q : cgi) dbh hostid if pageid <> None then ( match user with | User (userid, _, _, _) -> - PGSQL(dbh) - "delete from recently_visited - where hostid = $hostid and userid = $userid and url = $page'"; - PGSQL(dbh) - "insert into recently_visited (hostid, userid, url) - values ($hostid, $userid, $page')"; - PGOCaml.commit dbh; + (try + PGSQL(dbh) + "delete from recently_visited + where hostid = $hostid and userid = $userid + and url = $page'"; + PGSQL(dbh) + "insert into recently_visited (hostid, userid, url) + values ($hostid, $userid, $page')"; + PGOCaml.commit dbh; + with + exn -> + (* Exceptions here are non-fatal. Just print them. *) + prerr_endline "exception updating recently_visited:"; + prerr_endline (Printexc.to_string exn); + PGOCaml.rollback dbh; + ); PGOCaml.begin_work dbh; | _ -> () ); @@ -425,7 +530,7 @@ let run r (q : cgi) dbh hostid let keywords = Pcre.split ~rex:split_words search_terms in let keywords = List.filter (fun s -> not (string_is_whitespace s)) keywords in - let keywords = List.map String.lowercase keywords in + let keywords = List.map lowercase keywords in (* Turn the keywords into a tsearch2 ts_query string. *) let tsquery = String.concat "&" keywords in @@ -543,50 +648,50 @@ let run r (q : cgi) dbh hostid | None -> if allow_redirect then ( let rows = PGSQL(dbh) - "select url, redirect, id, title, description, - last_modified_date, css is not null + "select url, redirect, id, title, description, keywords, + last_modified_date, css is not null, noodp from pages where hostid = $hostid and lower (url) = lower ($page)" in match rows with - | [Some page', _, _, _, _, _, _] + | [Some page', _, _, _, _, _, _, _, _] when page <> page' -> (* different case *) FPExternalRedirect page' - | [ _, None, id, title, description, - last_modified_date, has_page_css ] -> + | [ _, None, id, title, description, keywords, + last_modified_date, has_page_css, noodp ] -> let has_page_css = Option.get has_page_css in - FPOK (id, title, description, last_modified_date, - has_page_css) - | [_, Some redirect, _, _, _, _, _] -> + FPOK (id, title, description, keywords, last_modified_date, + has_page_css, noodp) + | [_, Some redirect, _, _, _, _, _, _, _] -> FPInternalRedirect redirect | [] -> FPNotFound | _ -> assert false ) else (* redirects not allowed ... *) ( let rows = PGSQL(dbh) - "select id, title, description, last_modified_date, - css is not null + "select id, title, description, keywords, last_modified_date, + css is not null, noodp from pages where hostid = $hostid and url = $page" in match rows with - | [ id, title, description, - last_modified_date, has_page_css ] -> + | [ id, title, description, keywords, + last_modified_date, has_page_css, noodp ] -> let has_page_css = Option.get has_page_css in - FPOK (id, title, description, last_modified_date, - has_page_css) + FPOK (id, title, description, keywords, last_modified_date, + has_page_css, noodp) | [] -> FPNotFound | _ -> assert false ) | Some version -> let rows = PGSQL(dbh) - "select id, title, description, last_modified_date, - css is not null + "select id, title, description, keywords, last_modified_date, + css is not null, noodp from pages where hostid = $hostid and id = $version and (url = $page or url_deleted = $page)" in match rows with - | [ id, title, description, - last_modified_date, has_page_css ] -> + | [ id, title, description, keywords, + last_modified_date, has_page_css, noodp ] -> let has_page_css = Option.get has_page_css in - FPOK (id, title, description, last_modified_date, - has_page_css) + FPOK (id, title, description, keywords, last_modified_date, + has_page_css, noodp) | [] -> FPNotFound | _ -> assert false in @@ -603,17 +708,18 @@ let run r (q : cgi) dbh hostid let rec loop page' i = if i > max_redirect then ( error ~title:"Too many redirections" ~back_button:true - dbh hostid q + r dbh hostid q ("Too many redirects between pages. This may happen because " ^ "of a cycle of redirections."); return () ) else match fetch_page page' version allow_redirect with - | FPOK (pageid, title, description, last_modified_date, has_page_css)-> + | FPOK (pageid, title, description, keywords, + last_modified_date, has_page_css, noodp)-> (* Check if the page is also a template. *) let extension = get_extension page' in - make_page title (Some description) (Some pageid) - (printable_date last_modified_date) has_page_css + make_page title (Some description) keywords (Some pageid) + (printable_date last_modified_date) has_page_css noodp version page page' extension | FPInternalRedirect page' -> loop page' (i+1) @@ -628,8 +734,8 @@ let run r (q : cgi) dbh hostid (match extension with | (Some _) as extension -> let title = page' in - make_page title None None - "Now" false None page page' + make_page title None None None + "Now" false None None page page' extension | None -> make_404 ())