scripts/cocanwiki.ml

   1 (* COCANWIKI scripts.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: cocanwiki.ml,v 1.1 2004/09/07 10:14:09 rich Exp $
   5  *)
   6
   7 open Apache
   8 open Registry
   9 open Cgi
  10 open Printf
  11
  12 open Merjisforwiki
  13
  14 module Pool = DbiPool (Dbi_postgres)
  15
  16 (* Wrapper around [Cgi.Template.template] function which loads the
  17  * template from a pre-defined path and sets up some default variables.
  18  *)
  19 let get_template =
  20   let path =
  21     try Sys.getenv "COCANWIKI_TEMPLATES"
  22     with Not_found -> "/usr/share/cocanwiki/templates" in
  23   let is_dir path =
  24     try (Unix.stat path).Unix.st_kind = Unix.S_DIR
  25     with Unix.Unix_error _ -> false in
  26   if not (is_dir path) then
  27     failwith ("environment variable $COCANWIKI_TEMPLATES " ^
  28               "must be set to point to my 'templates' directory " ^
  29               "(see README file for more details)");
  30   fun filename ->
  31     Template.template (path // filename)
  32
  33 (* Generate a printable datestamp for pages. *)
  34 let printable_date (date, _) =
  35   sprintf "%d %s %04d" date.Dbi.day (short_month date.Dbi.month) date.Dbi.year
  36
  37 let printable_date_time (date, time) =
  38   sprintf "%d %s %04d %02d:%02d" date.Dbi.day (short_month date.Dbi.month)
  39     date.Dbi.year time.Dbi.hour time.Dbi.min
  40
  41 (* This function is used to grab a database handle.  It's used in a couple
  42  * of very special places, and is not for general consumption.
  43  *)
  44 let _get_dbh r = Pool.get r "cocanwiki"
  45
  46 (* The [CgiExit] exception should be folded back into the base
  47  * mod_caml code at some point.  It just causes the 'run' function to
  48  * return at that point safely.  (XXX)
  49  *)
  50 exception CgiExit
  51
  52 (* Our wrapper around the standard [register_script] function. *)
  53 let register_script run =
  54   (* Actually register the script with the real [Registry] module. *)
  55   register_script
  56     (fun r ->
  57        let q = new cgi r in
  58        let dbh = _get_dbh r in
  59
  60        (* Get the host ID, by comparing the Host: header with the hostnames
  61         * table in the database.
  62         *)
  63        let hostid, hostname =
  64          let hostname = try Request.hostname r
  65          with Not_found -> failwith "No ``Host:'' header in request" in
  66          let hostname = String.lowercase hostname in
  67
  68          let sth = dbh#prepare_cached "select h.id, h.canonical_hostname
  69                                          from hostnames hn, hosts h
  70                                         where hn.name = ?
  71                                           and hn.hostid = h.id" in
  72          sth#execute [`String hostname];
  73
  74          try
  75            (match sth#fetch1 () with
  76                 [ `Int id; `String hostname ] -> id, hostname
  77               | _ -> assert false)
  78          with
  79              Not_found ->
  80                failwith ("Hostname ``" ^ hostname ^ "'' not found in " ^
  81                          "the hosts/hostnames tables in the database.") in
  82
  83        (* Call the actual CGI script.  Note the fourth (unit) argument
  84         * is reserved for later usage (for authentication information).
  85         *)
  86        try
  87          run r q dbh (hostid, hostname) ()
  88        with
  89            CgiExit -> ())