scripts/upload_image.ml

   1 (* COCANWIKI scripts.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: upload_image.ml,v 1.3 2004/09/07 14:58:34 rich Exp $
   5  *)
   6
   7 open Apache
   8 open Registry
   9 open Cgi
  10 open Printf
  11
  12 open ExtString
  13
  14 open Cocanwiki
  15 open Cocanwiki_ok
  16 open Cocanwiki_emailnotify
  17 open Cocanwiki_images
  18
  19 let is_ws_re = Pcre.regexp "^\\s*$"
  20 let is_whitespace str = Pcre.pmatch ~rex:is_ws_re str
  21
  22 (* Valid image names. *)
  23 let image_ok_re = Pcre.regexp "^[a-z0-9][_a-z0-9]*\\.(jpg|jpeg|gif|ico|png)$"
  24
  25 let run r (q : cgi) (dbh : Dbi.connection) (hostid, hostname, _) _ =
  26   let name = q#param "name" in
  27   let alt = q#param "alt" in
  28   let title = q#param "title" in
  29   let longdesc = q#param "longdesc" in
  30   let clazz = q#param "class" in
  31
  32   (* See if there was an upload. *)
  33   let image =
  34     try
  35       let upload = q#upload "image" in
  36       upload.upload_value
  37     with
  38         Not_found ->
  39           error ~title:"No image" ~back_button:true
  40             q "No image was uploaded.";
  41           raise CgiExit in
  42
  43   (* Check the name is valid. *)
  44   if not (Pcre.pmatch ~rex:image_ok_re name) then (
  45     error ~title:"Bad Image Name" ~back_button:true
  46       q ("The Image Name must contain only lowercase English letters, " ^
  47          "numbers and underscore.  It must end with .jpg, .gif or .png " ^
  48          "depending on the image format.");
  49     raise CgiExit
  50   );
  51
  52   (* Check the image is an image, and get the size. *)
  53   let mime_type, width, height =
  54     try image_identify image
  55     with
  56         Invalid_argument _ ->
  57           error ~title:"Bad image" ~back_button:true
  58             q ("Unknown image type.  Is the file you uploaded really an " ^
  59                "image?");
  60           raise CgiExit in
  61
  62   (* Check the image filename extension matches the MIME type. *)
  63   let ext_ok =
  64     match mime_type with
  65         "image/jpeg" ->
  66           String.ends_with name ".jpg" ||
  67           String.ends_with name ".jpeg"
  68       | "image/gif" ->
  69           String.ends_with name ".gif"
  70       | "image/png" ->
  71           String.ends_with name ".png"
  72       | _ -> assert false in
  73   if not ext_ok then (
  74     error ~title:"Bad Image Name" ~back_button:true
  75       q ("The Image Name extension has to match the image format.  " ^
  76          "For example if the image is in JPEG format, the name must " ^
  77          "be 'something.jpg'.  I detected the following image type " ^
  78          "in the file you uploaded: " ^ mime_type);
  79     raise CgiExit
  80   );
  81
  82   (* Check some ALT text was supplied. *)
  83   if is_whitespace alt then (
  84     error ~title:"Missing Alt text" ~back_button:true
  85       q ("You must supply Alt text describing the image.  This is required " ^
  86          "by accessibility laws and to allow search engines to discover the " ^
  87          "content of images.");
  88     raise CgiExit
  89   );
  90
  91   let title = if is_whitespace title then `Null else `String title in
  92   let longdesc = if is_whitespace longdesc then `Null else `String longdesc in
  93   let clazz = if is_whitespace clazz then `Null else `String clazz in
  94
  95   (* Make a thumbnail of this image. *)
  96   let thumbnail, tn_mime_type, tn_width, tn_height =
  97     image_thumbnail image 120 120 in
  98
  99   (* Put the image into the database. *)
 100   let sth =
 101     dbh#prepare_cached
 102       "insert into images (hostid, name, image, width, height, alt,
 103                            title, longdesc, class, thumbnail, tn_width,
 104                            tn_height, mime_type, tn_mime_type)
 105        values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" in
 106   sth#execute [`Int hostid; `String name; `Binary image; `Int width;
 107                `Int height; `String alt; title; longdesc; clazz;
 108                `Binary thumbnail; `Int tn_width; `Int tn_height;
 109                `String mime_type; `String tn_mime_type];
 110
 111   dbh#commit ();
 112
 113   (* Email notify. *)
 114   let subject = "Image " ^ name ^ " has been uploaded." in
 115   let body = fun () ->
 116     "Page: http://" ^ hostname ^ "/_images" in
 117
 118   email_notify ~body ~subject dbh hostid;
 119
 120   let buttons = [ ok_button "/_images" ] in
 121   ok ~title:"Image uploaded" ~buttons
 122     q "Image was uploaded successfully."
 123
 124 let () =
 125   register_script run