160 lines
5.7 KiB
OCaml
160 lines
5.7 KiB
OCaml
(* $Id: image.ml,v 5.8 2009-03-11 09:22:39 ddr Exp $ *)
|
|
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
|
|
let print_placeholder_gendered_portrait conf p size =
|
|
let open Gwdb in
|
|
let image, alt =
|
|
match get_sex p with
|
|
| Male -> ("male.png", "M")
|
|
| Female -> ("female.png", "F")
|
|
| Neuter -> ("sexunknown.png", "?")
|
|
in
|
|
Output.printf conf
|
|
{|<img src="%s/%s" alt="%s" title="sex" width="%d" height="%d">|}
|
|
(Util.images_prefix conf) image alt size size
|
|
|
|
(* ************************************************************************** *)
|
|
(* [Fonc] content : string -> int -> string -> unit *)
|
|
(* ************************************************************************** *)
|
|
|
|
(** [Description] : Envoie les en-têtes de contenu et de cache pour un fichier
|
|
image, pdf ou html sur le flux HTTP sortant de Wserver.
|
|
[Args] :
|
|
- ct : le content_type MIME du fichier, par exemple "image/png",
|
|
"image/jpeg" ou "application/pdf"
|
|
- len : la taille en octet du fichier
|
|
- fname : le nom du fichier
|
|
[Retour] : aucun
|
|
[Rem] : Ne pas utiliser en dehors de ce module. *)
|
|
let content conf ct len fname =
|
|
Output.status conf Def.OK;
|
|
Output.header conf "Content-type: %s" ct;
|
|
Output.header conf "Content-length: %d" len;
|
|
Output.header conf "Content-disposition: inline; filename=%s"
|
|
(Filename.basename fname);
|
|
(* TODO: Utiliser un cache public pour les images non personelles. *)
|
|
Output.header conf "Cache-control: private, max-age=%d" (60 * 60 * 24 * 365);
|
|
Output.flush conf
|
|
|
|
let print_image_file conf fname =
|
|
let res =
|
|
List.find_opt
|
|
(fun (suff, _ctype) ->
|
|
if
|
|
Filename.check_suffix fname suff
|
|
|| Filename.check_suffix fname (String.uppercase_ascii suff)
|
|
then true
|
|
else false)
|
|
[
|
|
(".png", "image/png");
|
|
(".jpg", "image/jpeg");
|
|
(".jpeg", "image/jpeg");
|
|
(".pjpeg", "image/jpeg");
|
|
(".gif", "image/gif");
|
|
(".pdf", "application/pdf");
|
|
(".htm", "text/html");
|
|
(".html", "text/html");
|
|
]
|
|
in
|
|
match res with
|
|
| None ->
|
|
Error
|
|
(Format.sprintf "Could not find mime type from extension for file: %s"
|
|
fname)
|
|
| Some (_suff, ctype) -> (
|
|
try
|
|
let ic = Secure.open_in_bin fname in
|
|
let buf = Bytes.create 1024 in
|
|
let len = in_channel_length ic in
|
|
content conf ctype len fname;
|
|
let rec loop len =
|
|
if len = 0 then ()
|
|
else
|
|
let olen = min (Bytes.length buf) len in
|
|
really_input ic buf 0 olen;
|
|
Output.print_sstring conf (Bytes.sub_string buf 0 olen);
|
|
loop (len - olen)
|
|
in
|
|
loop len;
|
|
close_in ic;
|
|
Ok ()
|
|
with Sys_error e ->
|
|
!GWPARAM.syslog `LOG_ERR
|
|
(Format.sprintf "Error printing image file content for %s : %s" fname
|
|
e);
|
|
Error e)
|
|
|
|
(* ************************************************************************** *)
|
|
(* [Fonc] print_portrait : Config.config -> Gwdb.base -> Gwdb.person -> unit *)
|
|
(* ************************************************************************** *)
|
|
|
|
(** [Description] : Affiche l'image d'une personne en réponse HTTP.
|
|
[Args] :
|
|
- conf : configuration de la requête
|
|
- base : base de donnée sélectionnée
|
|
- p : personne dans la base dont il faut afficher l'image
|
|
[Retour] : aucun
|
|
[Rem] : Ne pas utiliser en dehors de ce module. *)
|
|
let print_portrait conf base p =
|
|
match Image.get_portrait conf base p with
|
|
| Some (`Path path) ->
|
|
Result.fold ~ok:ignore
|
|
~error:(fun _ -> Hutil.incorrect_request conf)
|
|
(print_image_file conf path)
|
|
| Some (`Url url) ->
|
|
Util.html conf;
|
|
Output.print_sstring conf "<head><title>";
|
|
Output.print_sstring conf (Util.transl_nth conf "image/images" 0);
|
|
Output.print_sstring conf "</title></head><body>";
|
|
Output.print_sstring conf (Printf.sprintf {|<img src=%s>|} url);
|
|
Output.print_sstring conf "</body></html>"
|
|
| None -> Hutil.incorrect_request conf
|
|
|
|
let print_source conf f =
|
|
let fname = if f.[0] = '/' then String.sub f 1 (String.length f - 1) else f in
|
|
let fname = Image.source_filename conf fname in
|
|
if (conf.wizard || conf.friend) || Image.is_not_private_img conf fname then
|
|
Result.fold ~ok:ignore
|
|
~error:(fun _ -> Hutil.incorrect_request conf)
|
|
(print_image_file conf fname)
|
|
else Hutil.incorrect_request conf
|
|
|
|
let print conf base =
|
|
match Util.p_getenv conf.env "s" with
|
|
| Some f -> print_source conf f
|
|
| None -> (
|
|
match Util.find_person_in_env conf base "" with
|
|
| Some p -> print_portrait conf base p
|
|
| None -> Hutil.incorrect_request conf)
|
|
|
|
let print_html conf =
|
|
let ext =
|
|
match Util.p_getenv conf.env "s" with
|
|
| Some f -> Filename.extension f
|
|
| _ -> ""
|
|
in
|
|
match ext with
|
|
| ".htm" | ".html" | ".pdf" ->
|
|
let title _ = Output.print_sstring conf "Error" in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf
|
|
"<body><ul><li>DOCH not available for html and pdf.";
|
|
Hutil.trailer conf
|
|
| _ ->
|
|
Util.html conf;
|
|
Output.print_sstring conf "<head><title>";
|
|
Output.print_sstring conf (Util.transl_nth conf "image/images" 0);
|
|
Output.print_sstring conf "</title></head><body><img src=\"";
|
|
Output.print_string conf (Util.commd conf);
|
|
Mutil.list_iter_first
|
|
(fun first (k, v) ->
|
|
let v = if k = "m" then Adef.encoded "IM" else v in
|
|
if not first then Output.print_sstring conf "&";
|
|
Output.print_sstring conf k;
|
|
Output.print_sstring conf "=";
|
|
Output.print_string conf v)
|
|
conf.env;
|
|
Output.print_sstring conf "\"></body></html>"
|