scripts/lib/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.6 2006/08/16 15:27: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 Cocanwiki
  30 open Cocanwiki_extensions
  31 open Cocanwiki_template
  32 open Cocanwiki_strings
  33 open Cocanwiki_date
  34
  35 let day_template = _get_template "calendar_day.html"
  36 let month_template = _get_template "calendar_month.html"
  37 let year_template = _get_template "calendar_year.html"
  38 let year_1m_template = _get_template "calendar_year_1m.html"
  39
  40 (* Check a date is valid. *)
  41 let check_date (y, m, d) =
  42   try
  43     let t = Date.make y m d in
  44     Date.year t = y
  45         && Date.int_of_month (Date.month t) = m
  46         && Date.day_of_month t = d
  47   with
  48       Date.Out_of_bounds | Date.Undefined -> false
  49
  50 let rec range a b =
  51   if a <= b then
  52     a :: range (a+1) b
  53   else
  54     []
  55
  56 let ascii_isdigit = function '0'..'9' -> true | _ -> false
  57
  58 let extension r dbh hostid url =
  59   (* Validate a date in the form "yyyy[/mm[/dd]]".  Returns a (yyyy, mm, dd)
  60    * tuple with missing fields set to 0.  If the string doesn't parse or the
  61    * date isn't valid, then raises Not_found.
  62    *)
  63   let valid_date str =
  64     if String.length str = 4 &&
  65       ascii_isdigit str.[0] && ascii_isdigit str.[1] &&
  66       ascii_isdigit str.[2] && ascii_isdigit str.[3] then (
  67         let yyyy = int_of_string (String.sub str 0 4) in
  68         (yyyy, 0, 0)
  69       )
  70     else if String.length str = 7 &&
  71       ascii_isdigit str.[0] && ascii_isdigit str.[1] &&
  72       ascii_isdigit str.[2] && ascii_isdigit str.[3] &&
  73       str.[4] = '/' &&
  74       ascii_isdigit str.[5] && ascii_isdigit str.[6] 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         if mm >= 1 && mm <= 12 then (yyyy, mm, 0) else raise Not_found
  78       )
  79     else if String.length str = 10 &&
  80       ascii_isdigit str.[0] && ascii_isdigit str.[1] &&
  81       ascii_isdigit str.[2] && ascii_isdigit str.[3] &&
  82       str.[4] = '/' &&
  83       ascii_isdigit str.[5] && ascii_isdigit str.[6] &&
  84       str.[7] = '/' &&
  85       ascii_isdigit str.[8] && ascii_isdigit str.[9] then (
  86         let yyyy = int_of_string (String.sub str 0 4) in
  87         let mm = int_of_string (String.sub str 5 2) in
  88         let dd = int_of_string (String.sub str 8 2) in
  89         let date = (yyyy, mm, dd) in
  90         if check_date date then date else raise Not_found
  91       )
  92     else
  93       raise Not_found
  94   in
  95
  96   (* From the links table, find all links to this page, or sub-calendar pages.
  97    * This query overselects.  We then filter the real pages in OCaml.
  98    *)
  99   let rows =
 100     let patt = url ^ "%" in
 101     PGSQL(dbh)
 102       "select li.from_url, p.title, li.to_url
 103          from links li, pages p
 104         where li.hostid = $hostid and li.to_url like $patt
 105           and li.hostid = p.hostid and li.from_url = p.url" in
 106
 107   let pages =
 108     let results =
 109       List.map (fun (from_url, title, to_url) ->
 110                   from_url, title, to_url) rows in
 111     List.filter_map
 112       (fun (from_url, title, to_url) ->
 113          try let date = valid_date to_url in Some (date, (title, from_url))
 114          with Not_found -> None) results in
 115   let pages = List.sort pages in
 116
 117   (* Validate the date in the URL itself. *)
 118   let date =
 119     try Some (valid_date url)
 120     with Not_found -> None in
 121
 122   match date with
 123     | None ->                           (* Not a valid date. *)
 124         "<p>" ^ url ^ " is not an actual date.</p>"
 125     | Some (yyyy, 0, 0) ->              (* Year view. *)
 126         let template = year_template in
 127
 128         template#set "yyyy" (string_of_int yyyy);
 129         template#set "prev_yyyy" (string_of_int (yyyy - 1));
 130         template#set "next_yyyy" (string_of_int (yyyy + 1));
 131
 132         (* Return true if there are any events on a particular day. *)
 133         let has_events date = List.exists (fun (d, _) -> date = d) pages in
 134
 135         let int_of_day_of_week = function
 136           | Date.Sun -> 0 | Date.Mon -> 1 | Date.Tue -> 2
 137           | Date.Wed -> 3 | Date.Thu -> 4 | Date.Fri -> 5
 138           | Date.Sat -> 6
 139         in
 140
 141         (* Generate each month template separately ...
 142          * Wow, finally found a place I can use a for loop.
 143          *)
 144         for mm = 1 to 12 do
 145           let str =
 146             let template = year_1m_template in
 147             template#set "yyyy" (string_of_int yyyy);
 148             template#set "mm" (sprintf "%02d" mm);
 149             template#set "month_name"
 150               (!Printer.month_name (Date.month_of_int mm));
 151             let dow = Date.day_of_week (Date.make yyyy mm 1) in
 152             let max_dd = Date.days_in_month (Date.make yyyy mm 1) in
 153             let dd = ref (1 - int_of_day_of_week dow) in
 154             let rows = ref [] in
 155             for r = 0 to 5 do           (* up to 5 rows ... *)
 156               let cols = ref [] in
 157               for c = 0 to 6 do         (* 7 columns, Sunday - Saturday *)
 158                 let is_day = !dd >= 1 && !dd <= max_dd in
 159                 let clasz =
 160                   if is_day then (
 161                     let is_weekend =
 162                       match Date.day_of_week (Date.make yyyy mm !dd) with
 163                           Date.Sat | Date.Sun -> true | _ -> false in
 164                     let date = yyyy, mm, !dd in
 165                     let events = has_events date in
 166                     (if is_weekend then "cal_year_1m_weekend " else "") ^
 167                     (if events then "cal_year_1m_events" else "")
 168                   ) else
 169                     "cal_year_1m_empty" in
 170                 let col =
 171                   [ "is_day", Template.VarConditional is_day;
 172                     "dd", Template.VarString (sprintf "%02d" !dd);
 173                     "class", Template.VarString clasz ] in
 174                 cols := col :: !cols;
 175                 incr dd
 176               done;
 177               rows := [ "cols", Template.VarTable (List.rev !cols) ] :: !rows;
 178               cols := []
 179             done;
 180
 181             template#table "rows" (List.rev !rows);
 182
 183             template#to_string in
 184           template#set ("month" ^ string_of_int mm) str
 185         done;
 186
 187         (* Annual events. *)
 188         let events =
 189           List.filter (function ((_, 0, 0), _) -> true | _ -> false) pages in
 190
 191         let table =
 192           List.map (fun (_, (title, page)) ->
 193                       [ "title", Template.VarString title;
 194                         "page", Template.VarString page ]) events in
 195         template#table "events" table;
 196
 197         template#to_string
 198
 199     | Some (yyyy, mm, 0) ->             (* Month view. *)
 200         let template = month_template in
 201
 202         template#set "month_name" (!Printer.month_name (Date.month_of_int mm));
 203         template#set "yyyy" (string_of_int yyyy);
 204         template#set "mm" (sprintf "%02d" mm);
 205
 206         let prev_yyyy, prev_mm =
 207           if mm = 1 then yyyy - 1, 12
 208           else yyyy, mm - 1 in
 209         let next_yyyy, next_mm =
 210           if mm = 12 then yyyy + 1, 1
 211           else yyyy, mm + 1 in
 212         template#set "prev_yyyy" (string_of_int prev_yyyy);
 213         template#set "prev_mm" (sprintf "%02d" prev_mm);
 214         template#set "next_yyyy" (string_of_int next_yyyy);
 215         template#set "next_mm" (sprintf "%02d" next_mm);
 216
 217         (* Get all monthly events and all daily events. *)
 218         let monthly_events, daily_events =
 219           List.partition (function ((_, _, 0), _) -> true | _ -> false)
 220             pages in
 221
 222         (* Table of monthly events. *)
 223         let table =
 224           List.map (fun (_, (title, page)) ->
 225                       [ "title", Template.VarString title;
 226                         "page", Template.VarString page ]) monthly_events in
 227         template#table "monthly_events" table;
 228
 229         (* How many days in this month? *)
 230         let max_dd = Date.days_in_month (Date.make yyyy mm 1) in
 231         let days = range 1 max_dd in
 232
 233         let table =
 234           List.map (fun dd ->
 235                       let events =
 236                         List.filter (fun ((_, _, d), _) -> d = dd)
 237                           daily_events in
 238                       let table =
 239                         List.map (fun (_, (title, page)) ->
 240                                     [ "title", Template.VarString title;
 241                                       "page", Template.VarString page ])
 242                           events in
 243                       let is_weekend =
 244                         match Date.day_of_week (Date.make yyyy mm dd) with
 245                             Date.Sat | Date.Sun -> true | _ -> false in
 246                       [ "dd", Template.VarString (sprintf "%02d" dd);
 247                         "is_weekend", Template.VarConditional is_weekend;
 248                         "events", Template.VarTable table ])
 249             days in
 250         template#table "days" table;
 251
 252         template#to_string
 253
 254     | Some (yyyy, mm, dd) ->            (* Single day view. *)
 255         let template = day_template in
 256
 257         (* XXX This will change once we start doing date and time events.
 258          * For now it is very simple indeed.
 259          *)
 260         template#set "yyyy" (string_of_int yyyy);
 261         template#set "mm" (sprintf "%02d" mm);
 262         template#set "dd" (sprintf "%02d" dd);
 263
 264         template#set "month_name" (!Printer.month_name (Date.month_of_int mm));
 265
 266         let t = Date.make yyyy mm dd in
 267         let dow = Date.day_of_week t in
 268         template#set "short_weekday" (Printer.short_name_of_day dow);
 269
 270         let oneday = Date.Period.day 1 in
 271         let prev_t = Date.rem t oneday in
 272         let next_t = Date.add t oneday in
 273         let prev_yyyy, prev_mm, prev_dd =
 274           Date.year prev_t, Date.int_of_month (Date.month prev_t),
 275           Date.day_of_month prev_t in
 276         let next_yyyy, next_mm, next_dd =
 277           Date.year next_t, Date.int_of_month (Date.month next_t),
 278           Date.day_of_month next_t in
 279
 280         template#set "prev_yyyy" (string_of_int prev_yyyy);
 281         template#set "prev_mm" (sprintf "%02d" prev_mm);
 282         template#set "prev_dd" (sprintf "%02d" prev_dd);
 283         template#set "next_yyyy" (string_of_int next_yyyy);
 284         template#set "next_mm" (sprintf "%02d" next_mm);
 285         template#set "next_dd" (sprintf "%02d" next_dd);
 286
 287         let table = List.map (fun (_, (title, page)) ->
 288                                 [ "title", Template.VarString title;
 289                                   "page", Template.VarString page ]) pages in
 290         template#table "events" table;
 291
 292         template#to_string
 293
 294 (* Register the extension. *)
 295 let () =
 296   extensions := ("calendar", extension) :: !extensions