(* $Id: mailbox.ml 817 2004-07-31 13:15:46Z stolpmann $ *)
(**********************************************************************
* This CGI displays the contents of a mailbox. First, the available
* mail messages are listed, with a hyperlink for every message. If
* the user clicks at this link, the selected message can be viewed.
*
* Messages in MIME format can be decoded and displayed part by part.
* Images and HTML pages are included "inline" into the generated
* page. Attachments are represented by further hyperlinks allowing
* the attachments to be viewed and saved.
*
* Potentially dangerous contents like scripts are removed from the
* HTML pages, so the message viewer can be considered as safe with
* respect to viruses etc. Furthermore, images with a "src" attribute
* referring to another part of the message (using "cid" (content-id)
* URIs) are displayed in the HTML page.
*
* The mailbox must be in "mbox" format, i.e. there is a "From " line
* before every message.
*
* This program demonstrates the following techniques:
* - How to design a CGI with several pages
* - How a CGI can refer to itself
* - How to parse "mbox" mailboxes
* - How to parse MIME messages
* - How to cope with international character encodings
* - How to parse and transform HTML pages
**********************************************************************)
(**********************************************************************
* CONFIGURATION READ THIS CAREFULLY!!!
*
* You MUST change the following variables to your local conventions!
***********************************************************************)
let mbox_file = "testbox"
(* The mailbox file in mbox(5) format. *)
(**********************************************************************)
open Netcgi
open Netchannels
open Printf
(**********************************************************************
* MAILBOX ACCESS FUNCTIONS
*
* Various methods to extract mail data from the mailbox
**********************************************************************)
let from_re = Pcre.regexp ~flags:[`MULTILINE] "^From ";;
let lf_re = Pcre.regexp "\n";;
let input_max ch s pos len =
(* Try to read as much as possible *)
let n = ref (ch # input s pos len) in
let k = ref 1 in
( try
while !n < len && !k <> 0 do
k := (ch # input s (pos + !n) (len - !n));
n := !n + !k
done;
with
End_of_file -> ()
);
!n
;;
let scan_mailbox() =
(* Scans the mailbox for "From " lines. Returns a list of tuples
* (from_pos, header_pos, end_pos).
* from_pos: The byte position of the "From " line
* header_pos: The byte position of the line following the "From " line
* which is expected to be the first line of the header
* end_pos: The byte position of the "From " line of the next message,
* or the EOF position.
*
* Note: [end_pos] is not correct. The better [end_pos] is the line
* before the next "From " line. But this is not visible to the user.
*)
let chunksize = 4096 in
let blocksize = 2 * chunksize in
let block = String.create blocksize in
let rec scan_blocks ch offset blocklen pos =
let limit = min blocklen chunksize in
try
if pos > limit then raise Not_found;
let r = Pcre.exec ~rex:from_re ~pos block in
let from_pos, after_from_pos = Pcre.get_substring_ofs r 0 in
if from_pos > limit || after_from_pos > blocklen then raise Not_found;
let r = Pcre.exec ~rex:lf_re ~pos:after_from_pos block in
let lf_pos, header_pos = Pcre.get_substring_ofs r 0 in
if header_pos > blocklen then raise Not_found;
let pair = (from_pos+offset, header_pos+offset) in
pair :: scan_blocks ch offset blocklen header_pos
with
Not_found ->
if blocklen = blocksize then begin
(* Get the next block *)
String.blit block chunksize block 0 chunksize;
let n = input_max ch block chunksize chunksize in
scan_blocks ch (offset+chunksize) (chunksize+n) 1
end
else [] (* EOF *)
in
let rec norm_list eof_pos l =
match l with
(from_pos, header_pos) :: (((from_pos', header_pos') :: _) as l') ->
(from_pos, header_pos, from_pos') :: norm_list eof_pos l'
| [from_pos, header_pos] ->
[from_pos, header_pos, eof_pos]
| [] ->
[]
in
let msg_list, eof_pos =
with_in_obj_channel
(new input_channel (open_in_bin mbox_file))
(fun ch ->
let n = input_max ch block 0 blocksize in
let l = scan_blocks ch 0 n 0 in
(l, ch # pos_in)
)
in
norm_list eof_pos msg_list
;;
let extract_header (from_pos, header_pos, end_pos) =
(* Extracts the header for the specified mail from the mailbox *)
let real_ch = open_in_bin mbox_file in
try
seek_in real_ch header_pos;
let stream = new Netstream.input_stream ~len:(end_pos - header_pos)
(new input_channel real_ch) in
let h = Netmime.read_mime_header stream in
close_in real_ch;
h
with error ->
close_in real_ch;
raise error
;;
let extract_message (from_pos, header_pos, end_pos) =
(* Extracts the complete message from the mailbox *)
let real_ch = open_in_bin mbox_file in
try
seek_in real_ch header_pos;
let stream = new Netstream.input_stream ~len:(end_pos - header_pos)
(new input_channel real_ch) in
let h = Netmime.read_mime_message stream in
close_in real_ch;
h
with error ->
close_in real_ch;
raise error
;;
let rec extract_from_mime_stream f stream path =
(* Find the part addressed by [path] within [stream], and call [f]. *)
if path = [] then
f stream
else begin
let h_obj = Netmime.read_mime_header stream in
let mime_type, mime_type_params =
try h_obj#content_type() with Not_found -> ("text/plain", []) in
let multipart = "multipart/" in
let is_multipart_type =
(String.length mime_type >= String.length multipart) &&
(String.sub mime_type 0 (String.length multipart) = multipart) in
if is_multipart_type then begin
let n :: path' = path in
(* --- Divide the message into parts: --- *)
let boundary =
try List.assoc "boundary" mime_type_params
with Not_found -> failwith "missing boundary parameter"
in
let k = ref 1 in
let _ =
Mimestring.read_multipart_body
(fun substream ->
if !k = n then (* Found the right part *)
extract_from_mime_stream f substream path';
incr k
)
(Mimestring.param_value boundary)
stream
in
()
end
end
;;
let extract_part (from_pos, header_pos, end_pos) path =
(* Extracts only the requested part of the message. [path] is a list
* of list positions addressing the part.
*)
let msg = ref None in
let real_ch = open_in_bin mbox_file in
try
seek_in real_ch header_pos;
extract_from_mime_stream
(fun stream ->
msg := Some (Netmime.read_mime_message ~multipart_style:`None stream))
(new Netstream.input_stream ~len:(end_pos - header_pos)
(new input_channel real_ch))
path;
close_in real_ch;
begin match !msg with
| None -> failwith "Message entity not found"
| Some m -> m
end
with error ->
close_in real_ch;
raise error
;;
(**********************************************************************
* GENERIC HTML COMPONENTS
**********************************************************************)
let html_re = Pcre.regexp "[\\<\\>\\&\\\"]" ;;
let text s =
(* This function encodes "<", ">", "&", double quotes, but no other
* characters
*)
Pcre.substitute ~rex:html_re
~subst:(function
"<" -> "<"
| ">" -> ">"
| "&" -> "&"
| "\"" -> """
| x -> x)
s
;;
let i18n_text s =
(* [s] is a mail header string that optionally contains RFC 2047-style
* encoded words. These are converted to HTML, if possible. The returned
* charset is always UTF-8.
*)
let words = Mimestring.scan_encoded_text_value s in
let html_words =
List.map
(fun w ->
try
let data = Mimestring.get_decoded_word w in
let charset = Mimestring.get_charset w in
let enc = Netconversion.encoding_of_string charset in
Netconversion.recode_string ~in_enc:enc ~out_enc:`Enc_utf8 data
with
Failure s ->
("[Error: Cannot decode word]")
)
words
in
text(String.concat "" html_words)
;;
let begin_page (cgi : cgi) title =
(* Output the beginning of the page with the passed [title]. *)
let out = cgi # out_channel # output_string in
out "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \
\"http://www.w3.org/TR/html4/strict.dtd\">\n";
out "<html>\n";
out "<head>\n";
out ("<title>" ^ text title ^ "</title>\n");
out "</head>\n";
out "<body>\n";
out ("<h1>" ^ text title ^ "</h1>\n")
;;
let end_page (cgi : cgi) =
let out = cgi # out_channel # output_string in
out "</body>\n";
out "</html>\n"
;;
(**********************************************************************
* LIST OF MESSAGES
*
* This page lists the messages found in the mailbox.
**********************************************************************)
let display_list_page (cgi : cgi) =
let out = cgi # out_channel # output_string in
begin_page cgi "List of Messages";
(* Output a table with three columns: subject, sender, date. The subject
* is a hyperlink, and when you follow it, you can see the whole message
*)
let messages = scan_mailbox() in
out "<table>\n";
out "<tr><th>Subject</th><th>From</th><th>Date of submission</th></tr>\n";
List.iter
(fun (from_pos, header_pos, end_pos as msg) ->
(* Create the arguments for the hyperlink: *)
let args =
[ new simple_argument "entity" "view-message";
new simple_argument "from_pos" (string_of_int from_pos);
new simple_argument "header_pos" (string_of_int header_pos);
new simple_argument "end_pos" (string_of_int end_pos)
]
in
let href = cgi # url
~with_query_string: (`Args args) () in
(* Extract the header for [msg], and display the three requested
* header fields.
*)
let h = extract_header msg in
(* [h] is a [mime_header] object, see module [Netmime] *)
let subject =
i18n_text (try h # field "subject" with Not_found -> "(No subject)") in
let sender =
i18n_text (try h # field "from" with Not_found -> "(No sender)") in
let date =
(try h # field "date" with Not_found -> "(No date)") in
out (sprintf "<tr><td><a href=\"%s\">%s</a></td>\
<td>%s</td><td>%s</td></tr>\n"
href
subject
sender
date);
)
messages;
out "</table>\n";
end_page cgi
;;
(**********************************************************************
* VIEW MESSAGE
*
* Display the whole message with all parts
**********************************************************************)
let split_type t =
(* Split a mime type like "text/html" into its two parts *)
try
let k = String.index t '/' in
(String.sub t 0 k), (String.sub t (k+1) (String.length t - k - 1))
with
Not_found -> t, ""
;;
let allowed_html_elements =
[ "tt"; "i"; "b"; "big"; "small"; "u"; "s"; "strike"; "em"; "strong";
"dfn"; "code"; "samp"; "kbd"; "var"; "cite"; "abbr"; "acronym";
"sup"; "sub"; "span"; "bdo"; "br"; "a"; "img"; (* no object *)
(* no script *) "map"; "q"; (* no applet *) "font"; "basefont";
(* no iframe *) "input"; "select"; "textarea"; "label"; "button";
"p"; "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "ul"; "ol"; "dir"; "menu";
"pre"; "dl"; "div"; "noscript"; "blockquote"; "form"; "hr"; "table";
"fieldset"; "address"; "center"; "noframes"; "isindex";
(* no body *) "area"; (* no link *) "param"; "ins"; "del"; "dt";
"dd"; "li"; "optgroup"; "option"; "legend"; "caption"; "thead";
"tbody"; "tfoot"; "colgroup"; "col"; "tr"; "th"; "td";
(* no head *) (* no title *) (* no base *) (* no meta *)
(* no style *) (* no html *) (* no frameset *) (* no frame *)
]
;;
let harmful_html_elements = (* Remove them completely *)
[ "object"; "script"; "applet"; "iframe"; "style"; "title" ]
;;
let allowed_html_attributes =
[ "abbr"; "accept-charset"; "accept"; "accesskey"; "align"; "alink";
"alt"; (* no archive *) "axis"; "background"; "bgcolor"; "border";
"cellpadding"; "char"; "charoff"; "charset"; "checked"; "cite";
"class"; (* no classid *) "clear"; (* no code *) (* no codebase *)
(* no codetype *) "color"; "cols"; "colspan"; "compact"; "content";
"coords"; (* no data *) "datetime"; (* no declare *) (* no defer *)
"dir"; "disabled"; "enctype"; "face"; "for"; "frame"; "frameborder";
"headers"; "height"; "hreflang"; "hspace"; "http-equiv"; "id";
"ismap"; "label"; "lang"; (* no language *) "link"; "longdesc";
"marginheight"; "marginwidth"; "maxlength"; "media"; "method";
"multiple"; "name"; "nohref"; "noresize"; "noshade"; "nowrap";
(* no object *) (* no onXXX *) (* no profile *) "prompt"; "readonly";
"rel"; "rev"; "rows"; "rowspan"; "rules"; "scheme"; "scope"; "scrolling";
"selected"; "shape"; "size"; "span"; "standby"; "start"; "style";
"summary"; "tabindex"; "target"; "text"; "title"; "type"; "usemap";
"valign"; "value"; "valuetype"; "version"; "vlink"; "vspace"; "width";
]
;;
let restricted_html_attributes = [ "action"; "href"; "src" ]
let http_re = Pcre.regexp "^\\s*http:.*$" ;;
let ftp_re = Pcre.regexp "^\\s*ftp:.*$" ;;
let mailto_re = Pcre.regexp "^\\s*mailto:.*$" ;;
let unrestricted_uris = [ http_re; ftp_re; mailto_re ] ;;
let cid_uri_re = Pcre.regexp "^\\s*cid:(.*)$";;
let clean_tree mk_cid_href html =
(* Transfrom the HTML tree:
* - Remove all potentially dangerous elements and attributes
* - Convert cid: URIs
*)
let elements = Hashtbl.create 50 in
let atts = Hashtbl.create 50 in
List.iter (fun e -> Hashtbl.add elements e ()) allowed_html_elements;
List.iter (fun a -> Hashtbl.add atts a ()) allowed_html_attributes;
let rec recurse html =
match html with
Nethtml.Element (name, attlist, subtrees) ->
if Hashtbl.mem elements name then begin
(* The element is ok. Look at the attribute list *)
let attlist' =
List.flatten
(List.map
(fun (aname,aval) ->
if Hashtbl.mem atts aname then
[ aname,aval ]
else
if List.mem aname restricted_html_attributes then begin
if List.exists
(fun rex -> Pcre.pmatch ~rex aval)
unrestricted_uris
then
[ aname,aval ]
else
if Pcre.pmatch ~rex:cid_uri_re aval then begin
(* Convert this attribute *)
let [| _; cid |] =
Pcre.extract ~rex:cid_uri_re aval in
try
let href = mk_cid_href cid in (* or Not_found *)
[ aname, href ]
with
Not_found -> []
end
else
[] (* drop *)
end
else
[] (* unknown: drop *)
)
attlist
)
in
let subtrees' = List.flatten(List.map recurse subtrees) in
[ Nethtml.Element (name,attlist',subtrees') ]
end
else begin
if List.mem name harmful_html_elements then
[]
else
List.flatten(List.map recurse subtrees)
end
| Nethtml.Data s ->
[ Nethtml.Data s ]
in
recurse html
;;
let cid_re = Pcre.regexp "^\\s*\\<(.*)\\>\\s*$";;
let display_message_page (cgi : cgi) =
let out = cgi # out_channel # output_string in
let print_header h =
let subject =
i18n_text (try h # field "subject" with Not_found -> "(No subject)") in
let sender =
i18n_text (try h # field "from" with Not_found -> "(No sender)") in
let receiver =
i18n_text (try h # field "to" with Not_found -> "(No receiver)") in
let date =
(try h # field "date" with Not_found -> "(No date)") in
out "<table>\n";
out (sprintf "<tr><td>Subject:</td><td>%s</td></tr>\n" subject);
out (sprintf "<tr><td>Date:</td><td>%s</td></tr>\n" date);
out (sprintf "<tr><td>From:</td><td>%s</td></tr>\n" sender);
out (sprintf "<tr><td>To:</td><td>%s</td></tr>\n" receiver);
out "</table>\n";
out "<br />\n";
in
let print_text_body params simple_body =
try
let charset =
try Mimestring.param_value(List.assoc "charset" params)
with Not_found -> "us-ascii" in
let enc = Netconversion.encoding_of_string charset in
let data = Netconversion.recode_string ~in_enc:enc ~out_enc:`Enc_utf8
simple_body#value in
let html_data = text data in
out "<pre>\n";
out html_data;
out "</pre>\n";
with
Failure s ->
out ("[Cannot decode this part: " ^ s ^ "]")
| Netconversion.Malformed_code ->
out ("[Cannot decode this part: Bad character encoding]")
in
let print_html_body cid_map params simple_body =
try
let charset =
try Mimestring.param_value(List.assoc "charset" params)
with Not_found -> "us-ascii" in
let enc = Netconversion.encoding_of_string charset in
let data = Netconversion.recode_string ~in_enc:enc ~out_enc:`Enc_utf8
simple_body#value in
(* Now parse [data] as HTML text: *)
let html_tree =
Nethtml.parse
~dtd:Nethtml.relaxed_html40_dtd
(new input_string data) in
(* Throw out all dangerous stuff (scripts), and replace links to
* cid:xxx by the right self url
*)
let base_args =
[ new simple_argument "entity" "view-part";
cgi # argument "from_pos";
cgi # argument "header_pos";
cgi # argument "end_pos";
] in
let mk_cid_href cid =
try
let path = Hashtbl.find cid_map cid in
let args = (new simple_argument "path" path) :: base_args in
cgi # url
~with_query_string: (`Args args) ()
with
Not_found -> ""
in
let html_tree' =
List.flatten (List.map (clean_tree mk_cid_href) html_tree) in
(* Finally write the tree: *)
let outch = (cgi#output :> out_obj_channel) in
out "<div>\n";
Nethtml.write ~dtd:Nethtml.relaxed_html40_dtd outch html_tree';
out "</div>\n";
with
Failure s ->
out ("[Cannot decode this part: " ^ s ^ "]")
| Netconversion.Malformed_code ->
out ("[Cannot decode this part: Bad character encoding]")
in
let print_image path =
let args =
[ new simple_argument "entity" "view-part";
cgi # argument "from_pos";
cgi # argument "header_pos";
cgi # argument "end_pos";
new simple_argument "path" (String.concat "."
(List.map string_of_int path));
]
in
let href = cgi # url ~with_query_string:(`This args) () in
out (sprintf "<img src=\"%s\">\n" href)
in
let print_link mime_type path =
let inline_args =
[ new simple_argument "entity" "view-part";
cgi # argument "from_pos";
cgi # argument "header_pos";
cgi # argument "end_pos";
new simple_argument "path" (String.concat "."
(List.map string_of_int path));
]
in
let attachment_args =
( new simple_argument "attachment" "yes" ) :: inline_args in
let inline_href = cgi # url
~with_query_string: (`This inline_args) () in
let attachment_href = cgi # url
~with_query_string: (`This attachment_args) () in
out (sprintf "Content-type: %s<BR>\n" mime_type);
out (sprintf "<a href=\"%s\">View</a>\n" inline_href);
out (sprintf "<a href=\"%s\">Save</a>\n" attachment_href);
in
let rec collect_content_ids cid_map path (header,cbody) =
begin try
let cid_s = header # field "content-id" in (* or Not_found *)
let [| _; cid |] = Pcre.extract ~rex:cid_re cid_s in (* or Not_found *)
let path_s = String.concat "." (List.map string_of_int path) in
Hashtbl.add cid_map cid path_s
with
Not_found -> ()
end;
match cbody with
`Parts l ->
let k = ref 0 in
List.iter
(fun p ->
collect_content_ids cid_map (path @ [!k]) p;
incr k)
l
| _ ->
()
in
let rec print_complex_message (cmsg : Netmime.complex_mime_message) cid_map path =
let (header,body) = cmsg in
if path = [] then
print_header header
else
out (sprintf "<h2>Message entity %s</h2>\n"
(String.concat "." (List.map string_of_int path)));
match body with
`Body simple_body ->
let mime_type, params =
try header # content_type()
with Not_found ->
if path = [] then
("text/plain", [])
else
("application/octet-stream", [])
in
let major_type, minor_type = split_type mime_type in
let disp, _ =
try header # content_disposition()
with Not_found -> "inline", []
in
if disp = "inline" then begin
match major_type, minor_type with
| "text", "html" ->
print_html_body cid_map params simple_body
| "text", _ ->
print_text_body params simple_body
| "image", ("gif"|"jpeg"|"png") ->
print_image path
| _, _ ->
print_link mime_type path
end
else
print_link mime_type path
| `Parts parts ->
(* It is guaranteed that the header HAS a content-type *)
let mime_type, _ = header # content_type() in
out (sprintf "<b>Multipart type: %s </b>\n" mime_type);
let n = ref 1 in
List.iter
(fun part ->
if !n > 1 then out "<hr>\n";
print_complex_message part cid_map (path @ [!n]);
incr n
)
parts
in
begin_page cgi "Message";
let from_pos = int_of_string (cgi # argument_value "from_pos") in
let header_pos = int_of_string (cgi # argument_value "header_pos") in
let end_pos = int_of_string (cgi # argument_value "end_pos") in
let msg = extract_message (from_pos,header_pos,end_pos) in
let cid_map = Hashtbl.create 50 in
collect_content_ids cid_map [] msg;
print_complex_message msg cid_map [];
end_page cgi
;;
(**********************************************************************
* VIEW MESSAGE PART
*
* This is for fragments of the message that need to be downloaded
* separately. For example, images.
**********************************************************************)
let dot_re = Pcre.regexp "\\.";;
let display_part_fragment (cgi : cgi) =
let from_pos = int_of_string (cgi # argument_value "from_pos") in
let header_pos = int_of_string (cgi # argument_value "header_pos") in
let end_pos = int_of_string (cgi # argument_value "end_pos") in
let attachment = cgi # argument_value "attachment" = "yes" in
let path =
List.map int_of_string
(Pcre.split ~rex:dot_re (cgi # argument_value "path")) in
let msg_hdr, msg_body =
match extract_part (from_pos,header_pos,end_pos) path with
| (hdr, `Body body) -> (hdr,body)
| _ -> assert false
in
if attachment then begin
cgi # set_header
~content_type:"application/octet-stream"
~filename:("part-" ^ cgi # argument_value "path")
()
end
else begin
cgi # set_header
~content_type:(try msg_hdr # field "content-type"
with Not_found -> "application/octet-stream")
()
end;
let ch = msg_body # open_value_rd() in
cgi # out_channel # output_channel ch;
ch # close_in()
;;
(**********************************************************************
* REQUEST BROKER
**********************************************************************)
let process (cgi:cgi) =
(* Set a default header: This might be overridden later, but if an
* early error happens, we have a header nethertheless.
*)
cgi # set_header ~content_type:"text/html; charset=utf-8" ();
(* Get the [entity] argument. It determines which part of the
* mailbox has been requested. If it does not exist, it defaults to
* "list". *)
let entity = cgi # argument_value ~default:"list" "entity" in
let display = match entity with
| "list" -> display_list_page
| "view-message" -> display_message_page
| "view-part" -> display_part_fragment
| _ -> failwith "Unknown entity"
in
display cgi;
(* Commit everything: *)
cgi # out_channel # commit_work()
let () =
let buffered _ ch = new Netchannels.buffered_trans_channel ch in
Netcgi_cgi.run ~output_type:(`Transactional buffered) process
(* ======================================================================
* History:
*
* $Log$
* Revision 1.3 2004/07/31 13:15:46 stolpmann
* Updated: End_of_file is caught in input_max
*
* Revision 1.2 2002/11/01 21:29:27 stolpmann
* Fix: The ~len argument of input_stream is now correct
*
* Revision 1.1 2002/02/02 18:57:53 stolpmann
* Initial revision.
*)
