scripts/cocanwiki_ext_calendar.ml

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: cocanwiki_ext_calendar.ml,v 1.3 2004/10/09 08:33:02 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Printf
  26
  27 open ExtList
  28
  29 open GregorianDate
  30
  31 open Cocanwiki
  32 open Cocanwiki_template
  33 open Cocanwiki_strings
  34 open Cocanwiki_date
  35
  36 let day_template = _get_template "calendar_day.html"
  37 let month_template = _get_template "calendar_month.html"
  38 let year_template = _get_template "calendar_year.html"
  39 let year_1m_template = _get_template "calendar_year_1m.html"
  40
  41 let rec range a b =
  42   if a <= b then
  43     a :: range (a+1) b
  44   else
  45     []
  46
  47 let extension (dbh : Dbi.connection) hostid url =
  48   (* Validate a date in the form "yyyy[/mm[/dd]]".  Returns a (yyyy, mm, dd)
  49    * tuple with missing fields set to 0.  If the string doesn't parse or the
  50    * date isn't valid, then raises Not_found.
  51    *)
  52   let valid_date str =
  53     if String.length str = 4 &&
  54       isdigit str.[0] && isdigit str.[1] &&
  55       isdigit str.[2] && isdigit str.[3] then (
  56         let yyyy = int_of_string (String.sub str 0 4) in
  57         (yyyy, 0, 0)
  58       )
  59     else if String.length str = 7 &&
  60       isdigit str.[0] && isdigit str.[1] &&
  61       isdigit str.[2] && isdigit str.[3] &&
  62       str.[4] = '/' &&
  63       isdigit str.[5] && isdigit str.[6] then (
  64         let yyyy = int_of_string (String.sub str 0 4) in
  65         let mm = int_of_string (String.sub str 5 2) in
  66         if mm >= 1 && mm <= 12 then (yyyy, mm, 0) else raise Not_found
  67       )
  68     else if String.length str = 10 &&
  69       isdigit str.[0] && isdigit str.[1] &&
  70       isdigit str.[2] && isdigit str.[3] &&
  71       str.[4] = '/' &&
  72       isdigit str.[5] && isdigit str.[6] &&
  73       str.[7] = '/' &&
  74       isdigit str.[8] && isdigit str.[9] then (
  75         let yyyy = int_of_string (String.sub str 0 4) in
  76         let mm = int_of_string (String.sub str 5 2) in
  77         let dd = int_of_string (String.sub str 8 2) in
  78         let date = (yyyy, mm, dd) in
  79         if GregorianDate.check_date date then date else raise Not_found
  80       )
  81     else
  82       raise Not_found
  83   in
  84
  85   (* From the links table, find all links to this page, or sub-calendar pages.
  86    * This query overselects.  We then filter the real pages in OCaml.
  87    *)
  88   let sth =
  89     dbh#prepare_cached
  90       "select li.from_url, p.title, li.to_url
  91          from links li, pages p
  92         where li.hostid = ? and li.to_url like ?
  93           and li.hostid = p.hostid and li.from_url = p.url" in
  94   sth#execute [`Int hostid; `String (url ^ "%")];
  95
  96   let pages =
  97     let results =
  98       sth#map (function [`String from_url; `String title; `String to_url] ->
  99                  from_url, title, to_url
 100                  | _ -> assert false) in
 101     List.filter_map
 102       (fun (from_url, title, to_url) ->
 103          try let date = valid_date to_url in Some (date, (title, from_url))
 104          with Not_found -> None) results in
 105   let pages = List.sort pages in
 106
 107   (* Validate the date in the URL itself. *)
 108   let date =
 109     try Some (valid_date url)
 110     with Not_found -> None in
 111
 112   match date with
 113     | None ->                           (* Not a valid date. *)
 114         "<p>" ^ url ^ " is not an actual date.</p>"
 115     | Some (yyyy, 0, 0) ->              (* Year view. *)
 116         let template = year_template in
 117
 118         template#set "yyyy" (string_of_int yyyy);
 119         template#set "prev_yyyy" (string_of_int (yyyy - 1));
 120         template#set "next_yyyy" (string_of_int (yyyy + 1));
 121
 122         (* Return true if there are any events on a particular day. *)
 123         let has_events date = List.exists (fun (d, _) -> date = d) pages in
 124
 125         (* Generate each month template separately ...
 126          * Wow, finally found a place I can use a for loop.
 127          *)
 128         for mm = 1 to 12 do
 129           let str =
 130             let template = year_1m_template in
 131             template#set "yyyy" (string_of_int yyyy);
 132             template#set "mm" (sprintf "%02d" mm);
 133             template#set "month_name" (long_month mm);
 134             let dow = GregorianDate.day_of_week (yyyy, mm, 1) in
 135             let dow = if dow = 7 then 0 else dow in
 136             let max_dd = GregorianDate.days_in_month yyyy mm in
 137             let dd = ref (1-dow) in
 138             let rows = ref [] in
 139             for r = 0 to 5 do           (* up to 5 rows ... *)
 140               let cols = ref [] in
 141               for c = 0 to 6 do         (* 7 columns, Sunday - Saturday *)
 142                 let is_day = !dd >= 1 && !dd <= max_dd in
 143                 let clasz =
 144                   if is_day then (
 145                     let date = yyyy, mm, !dd in
 146                     let is_weekend = GregorianDate.day_of_week date >= 6 in
 147                     let events = has_events date in
 148                     (if is_weekend then "cal_year_1m_weekend " else "") ^
 149                     (if events then "cal_year_1m_events" else "")
 150                   ) else
 151                     "cal_year_1m_empty" in
 152                 let col =
 153                   [ "is_day", Template.VarConditional is_day;
 154                     "dd", Template.VarString (sprintf "%02d" !dd);
 155                     "class", Template.VarString clasz ] in
 156                 cols := col :: !cols;
 157                 incr dd
 158               done;
 159               rows := [ "cols", Template.VarTable (List.rev !cols) ] :: !rows;
 160               cols := []
 161             done;
 162
 163             template#table "rows" (List.rev !rows);
 164
 165             template#to_string in
 166           template#set ("month" ^ string_of_int mm) str
 167         done;
 168
 169         (* Annual events. *)
 170         let events =
 171           List.filter (function ((_, 0, 0), _) -> true | _ -> false) pages in
 172
 173         let table =
 174           List.map (fun (_, (title, page)) ->
 175                       [ "title", Template.VarString title;
 176                         "page", Template.VarString page ]) events in
 177         template#table "events" table;
 178
 179         template#to_string
 180
 181     | Some (yyyy, mm, 0) ->             (* Month view. *)
 182         let template = month_template in
 183
 184         template#set "month_name" (long_month mm);
 185         template#set "yyyy" (string_of_int yyyy);
 186         template#set "mm" (sprintf "%02d" mm);
 187
 188         let prev_yyyy, prev_mm =
 189           if mm = 1 then yyyy - 1, 12
 190           else yyyy, mm - 1 in
 191         let next_yyyy, next_mm =
 192           if mm = 12 then yyyy + 1, 1
 193           else yyyy, mm + 1 in
 194         template#set "prev_yyyy" (string_of_int prev_yyyy);
 195         template#set "prev_mm" (sprintf "%02d" prev_mm);
 196         template#set "next_yyyy" (string_of_int next_yyyy);
 197         template#set "next_mm" (sprintf "%02d" next_mm);
 198
 199         (* Get all monthly events and all daily events. *)
 200         let monthly_events, daily_events =
 201           List.partition (function ((_, _, 0), _) -> true | _ -> false)
 202             pages in
 203
 204         (* Table of monthly events. *)
 205         let table =
 206           List.map (fun (_, (title, page)) ->
 207                       [ "title", Template.VarString title;
 208                         "page", Template.VarString page ]) monthly_events in
 209         template#table "monthly_events" table;
 210
 211         (* How many days in this month? *)
 212         let max_dd = GregorianDate.days_in_month yyyy mm in
 213         let days = range 1 max_dd in
 214
 215         let table =
 216           List.map (fun dd ->
 217                       let events =
 218                         List.filter (fun ((_, _, d), _) -> d = dd)
 219                           daily_events in
 220                       let table =
 221                         List.map (fun (_, (title, page)) ->
 222                                     [ "title", Template.VarString title;
 223                                       "page", Template.VarString page ])
 224                           events in
 225                       let is_weekend =
 226                         GregorianDate.day_of_week (yyyy, mm, dd) >= 6 in
 227                       [ "dd", Template.VarString (sprintf "%02d" dd);
 228                         "is_weekend", Template.VarConditional is_weekend;
 229                         "events", Template.VarTable table ])
 230             days in
 231         template#table "days" table;
 232
 233         template#to_string
 234
 235     | Some ((yyyy, mm, dd) as date) ->  (* Single day view. *)
 236         let template = day_template in
 237
 238         (* XXX This will change once we start doing date and time events.
 239          * For now it is very simple indeed.
 240          *)
 241         template#set "yyyy" (string_of_int yyyy);
 242         template#set "mm" (sprintf "%02d" mm);
 243         template#set "dd" (sprintf "%02d" dd);
 244
 245         template#set "month_name" (long_month mm);
 246         let dow = GregorianDate.day_of_week date in
 247         template#set "short_weekday" (short_weekday dow);
 248
 249         let prev_yyyy, prev_mm, prev_dd =
 250           GregorianDate.add_delta_days date (-1) in
 251         let next_yyyy, next_mm, next_dd =
 252           GregorianDate.add_delta_days date 1 in
 253
 254         template#set "prev_yyyy" (string_of_int prev_yyyy);
 255         template#set "prev_mm" (sprintf "%02d" prev_mm);
 256         template#set "prev_dd" (sprintf "%02d" prev_dd);
 257         template#set "next_yyyy" (string_of_int next_yyyy);
 258         template#set "next_mm" (sprintf "%02d" next_mm);
 259         template#set "next_dd" (sprintf "%02d" next_dd);
 260
 261         let table = List.map (fun (_, (title, page)) ->
 262                                 [ "title", Template.VarString title;
 263                                   "page", Template.VarString page ]) pages in
 264         template#table "events" table;
 265
 266         template#to_string
 267
 268 (* Register the extension. *)
 269 let () =
 270   extensions := ("calendar", extension) :: !extensions