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: upload_image.ml,v 1.11 2004/11/01 17:05:14 rich Exp $
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.
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.
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.
31 open Cocanwiki_emailnotify
33 open Cocanwiki_strings
35 (* Valid image names. *)
36 let image_ok_re = Pcre.regexp "^[a-z0-9][-._a-z0-9]*\\.(jpg|jpeg|gif|ico|png)$"
38 let run r (q : cgi) (dbh : Dbi.connection) hostid { hostname = hostname } user=
39 let name = q#param "name" in
40 let alt = q#param "alt" in
41 let title = q#param "title" in
42 let longdesc = q#param "longdesc" in
43 let clazz = q#param "class" in
45 (* See if there was an upload. *)
48 let upload = q#upload "file" in
52 error ~title:"No image" ~back_button:true
53 q "No image was uploaded.";
56 (* Check the name is valid. *)
57 if not (Pcre.pmatch ~rex:image_ok_re name) then (
58 error ~title:"Bad Image Name" ~back_button:true
59 q ("The Image Name must contain only lowercase English letters, " ^
60 "numbers, dots, dashes and underscore. " ^
61 "It must end with .jpg, .gif or .png " ^
62 "depending on the image format.");
66 (* Check the image is an image, and get the size. *)
67 let mime_type, width, height =
68 try image_identify image
71 error ~title:"Bad image" ~back_button:true
72 q ("Unknown image type. Is the file you uploaded really an " ^
76 (* Check the image filename extension matches the MIME type. *)
80 String.ends_with name ".jpg" ||
81 String.ends_with name ".jpeg"
83 String.ends_with name ".gif"
85 String.ends_with name ".png"
86 | _ -> assert false in
88 error ~title:"Bad Image Name" ~back_button:true
89 q ("The Image Name extension has to match the image format. " ^
90 "For example if the image is in JPEG format, the name must " ^
91 "be 'something.jpg'. I detected the following image type " ^
92 "in the file you uploaded: " ^ mime_type);
96 (* Check some ALT text was supplied. *)
97 if string_is_whitespace alt then (
98 error ~title:"Missing Alt text" ~back_button:true
99 q ("You must supply Alt text describing the image. This is required " ^
100 "by accessibility laws and to allow search engines to discover the " ^
101 "content of images.");
105 let title = if string_is_whitespace title then `Null else `String title in
107 if string_is_whitespace longdesc then `Null else `String longdesc in
108 let clazz = if string_is_whitespace clazz then `Null else `String clazz in
110 (* Make a thumbnail of this image. *)
111 let thumbnail, tn_mime_type, tn_width, tn_height =
112 image_thumbnail image 120 120 in
114 (* Check if something with the same name already exists. If replace=1
115 * then we can replace it, otherwise we must present an error message.
117 let replace = q#param_true "replace" in
118 let sth = dbh#prepare_cached "select 1 from images
119 where hostid = ? and name = ?" in
120 sth#execute [`Int hostid; `String name];
122 let exists = try sth#fetch1int () = 1 with Not_found -> false in
125 if not replace then (
126 error ~title:"Image already exists" ~back_button:true
127 q ("An image with the same name already exists.");
130 let sth = dbh#prepare_cached "update images
131 set name_deleted = name, name = null
132 where hostid = ? and name = ?" in
133 sth#execute [`Int hostid; `String name];
137 (* Put the image into the database. *)
140 "insert into images (hostid, name, image, width, height, alt,
141 title, longdesc, class, thumbnail, tn_width,
142 tn_height, mime_type, tn_mime_type)
143 values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" in
144 sth#execute [`Int hostid; `String name; `Binary image; `Int width;
145 `Int height; `String alt; title; longdesc; clazz;
146 `Binary thumbnail; `Int tn_width; `Int tn_height;
147 `String mime_type; `String tn_mime_type];
152 let subject = "Image " ^ name ^ " has been uploaded." in
154 "Page: http://" ^ hostname ^ "/_images" in
156 email_notify ~body ~subject ~user dbh hostid;
158 let buttons = [ ok_button "/_images" ] in
159 ok ~title:"Image uploaded" ~buttons
160 q "Image was uploaded successfully."
163 register_script ~restrict:[CanEdit] run