(* $Id: netmime.ml 1588 2011-04-28 13:59:54Z gerd $ * ---------------------------------------------------------------------- * *) open Netchannels type store = [ `Memory | `File of string ] exception Immutable of string class type mime_header_ro = object method fields : (string * string) list method field : string -> string method multiple_field : string -> string list method content_length : unit -> int method content_type : unit -> (string * (string * Mimestring.s_param)list) method content_disposition : unit -> (string * (string * Mimestring.s_param)list) method content_transfer_encoding : unit -> string end class type mime_header = object inherit mime_header_ro method ro : bool method set_fields : (string * string) list -> unit method update_field : string -> string -> unit method update_multiple_field : string -> string list -> unit method delete_field : string -> unit end class type mime_body_ro = object method value : string method store : store method open_value_rd : unit -> in_obj_channel method finalize : unit -> unit end class type mime_body = object inherit mime_body_ro method ro : bool method set_value : string -> unit method open_value_wr : unit -> out_obj_channel end type complex_mime_message = mime_header * complex_mime_body and complex_mime_body = [ `Body of mime_body | `Parts of complex_mime_message list ] type complex_mime_message_ro = mime_header_ro * complex_mime_body_ro and complex_mime_body_ro = [ `Body of mime_body_ro | `Parts of complex_mime_message_ro list ] (* Check that coercion is possible: *) let _ = fun x -> (x : complex_mime_message :> complex_mime_message_ro) type mime_message = mime_header * [ `Body of mime_body ] type mime_message_ro = mime_header_ro * [ `Body of mime_body_ro ] module CI : sig (* case-insensitive strings *) type t val compare : t -> t -> int val make : string -> t end = struct type t = string let compare (a_ci:t) (b_ci:t) = Pervasives.compare a_ci b_ci let make s = String.lowercase s end module CIMap = Map.Make(CI) (* Maps from case-insensitive strings to any type *) module DL : sig (* doubly-linked lists *) type 'a t type 'a cell val create : unit -> 'a t val is_empty : 'a t -> bool val cell : 'a -> 'a cell val contents : 'a cell -> 'a val first : 'a t -> 'a cell (* or Not_found *) val last : 'a t -> 'a cell (* or Not_found *) val prev : 'a cell -> 'a cell (* or Not_found *) val next : 'a cell -> 'a cell (* or Not_found *) val iter : ('a cell -> unit) -> 'a t -> unit val delete : 'a cell -> unit val insert_after : neo:'a cell -> 'a cell -> unit val add_at_end : neo:'a cell -> 'a t -> unit val replace : neo:'a cell -> 'a cell -> unit val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list end = struct type 'a t = { mutable first : 'a cell option; mutable last : 'a cell option; } and 'a cell = { mutable prev : 'a cell option; mutable next : 'a cell option; mutable list : 'a t option; contents : 'a; } let create() = { first = None; last = None } let is_empty l = l.first = None let cell x = { prev = None; next = None; list = None; contents = x } let contents c = c.contents let first l = match l.first with Some c -> c | None -> raise Not_found let last l = match l.last with Some c -> c | None -> raise Not_found let prev c = match c.prev with Some c' -> c' | None -> raise Not_found let next c = match c.next with Some c' -> c' | None -> raise Not_found let iter f l = match l.first with Some c -> f c; let current = ref c in while (let c0 = ! current in c0.next) <> None do (* Error in camlp4 *) current := next !current; f !current done; () | None -> () let delete c = match c.list with Some l -> ( match c.prev with Some p -> p.next <- c.next | None -> l.first <- c.next ); ( match c.next with Some n -> n.prev <- c.prev | None -> l.last <- c.prev ); c.prev <- None; c.next <- None; c.list <- None | None -> failwith "DL.delete: cannot delete free cell" let insert_after ~neo c = if neo.list <> None then failwith "DL.insert_after: new cell must be free"; match c.list with Some l -> let nx = c.next in c.next <- Some neo; neo.prev <- Some c; ( match nx with Some n -> n.prev <- Some neo; neo.next <- Some n; | None -> l.last <- Some neo; neo.next <- None ); neo.list <- Some l | None -> failwith "DL.insert_after: cannot insert after free cell" let add_at_end ~neo l = if neo.list <> None then failwith "DL.insert_after: new cell must be free"; match l.last with Some n -> n.next <- Some neo; neo.prev <- Some n; neo.next <- None; neo.list <- Some l; l.last <- Some neo | None -> l.last <- Some neo; l.first <- Some neo; neo.prev <- None; neo.next <- None; neo.list <- Some l let replace ~neo c = if neo.list <> None then failwith "DL.replace: new cell must be free"; match c.list with Some l -> ( match c.prev with Some p -> p.next <- Some neo | None -> l.first <- Some neo ); neo.prev <- c.prev; ( match c.next with Some n -> n.prev <- Some neo | None -> l.last <- Some neo ); neo.next <- c.next; neo.list <- Some l; c.prev <- None; c.next <- None; c.list <- None | None -> failwith "DL.replace: cannot replace free cell" let of_list l = let dl = create() in List.iter (fun x -> add_at_end ~neo:(cell x) dl ) l; dl let rec to_list dl = chain_to_list dl.first and chain_to_list chain = match chain with None -> [] | Some c -> c.contents :: chain_to_list c.next end let drop_ws_re = Netstring_str.regexp "^[ \t\r\n]*\\(.*[^ \t\r\n]\\)[ \t\r\n]*$";; let drop_ws s = (* Deletes whitespace at the beginning and at the end of s, and returns * the new string *) match Netstring_str.string_match drop_ws_re s 0 with None -> "" | Some r -> Netstring_str.matched_group r 1 s ;; class basic_mime_header ?(ro=false) h : mime_header = object (self) val ro = ro val mutable hdr_map = lazy (assert false) val mutable hdr_dl = lazy (assert false) initializer self # do_set_fields h method ro = ro method fields = DL.to_list (Lazy.force hdr_dl) method field n = let m = Lazy.force hdr_map in match CIMap.find (CI.make n) m with [] -> raise Not_found | cell :: _ -> snd (DL.contents cell) method multiple_field n = let m = Lazy.force hdr_map in try List.map (fun cell -> snd (DL.contents cell)) (CIMap.find (CI.make n) m) with Not_found -> [] method private immutable() = raise (Immutable "Netmime.basic_mime_header"); method set_fields h = if ro then self#immutable(); self # do_set_fields h method private do_set_fields h = hdr_dl <- lazy (DL.of_list h); hdr_map <- lazy begin (* This seems to be expensive (O(n log n)). Because of this we do it only * on demand; maybe nobody accesses the header at all *) let m = ref CIMap.empty in DL.iter (fun cell -> let (n,v) = DL.contents cell in let n_ci = CI.make n in let current = try CIMap.find n_ci !m with Not_found -> [] in m := CIMap.add n_ci (cell :: current) !m; ) (Lazy.force hdr_dl); CIMap.map List.rev !m end method update_field n v = self # update_multiple_field n [v] method update_multiple_field n vl = if ro then self#immutable(); let n_ci = CI.make n in let m = Lazy.force hdr_map in let dl = Lazy.force hdr_dl in (* Algorithm: First try to replace existing values. * If there are more new values than old values, * at the excess values after the last old value, * or if not possible, at the end. *) let insert_point = ref None in let old_cells = ref(try CIMap.find n_ci m with Not_found -> []) in let new_vals = ref vl in let new_cells = ref [] in while !old_cells <> [] || !new_vals <> [] do match !old_cells, !new_vals with (old_cell :: old_cells'), (new_val :: new_vals') -> (* Only update if the value has changed: *) let (old_n, old_val) = DL.contents old_cell in if old_val = new_val then ( new_cells := old_cell :: !new_cells; insert_point := Some old_cell; ) else ( let new_cell = DL.cell (n, new_val) in DL.replace ~neo:new_cell old_cell; insert_point := Some new_cell; new_cells := new_cell :: !new_cells ); old_cells := old_cells'; new_vals := new_vals'; | [], (new_val :: new_vals') -> let new_cell = DL.cell (n, new_val) in ( match !insert_point with Some p -> DL.insert_after ~neo:new_cell p; | None -> DL.add_at_end ~neo:new_cell dl ); new_vals := new_vals'; insert_point := Some new_cell; new_cells := new_cell :: !new_cells | (old_cell :: old_cells'), [] -> DL.delete old_cell; old_cells := old_cells' | [], [] -> assert false done; let m' = CIMap.add n_ci (List.rev !new_cells) m in hdr_map <- lazy m' method delete_field n = if ro then self#immutable(); let n_ci = CI.make n in let m = Lazy.force hdr_map in let old_cells = try CIMap.find n_ci m with Not_found -> [] in List.iter DL.delete old_cells; let m' = CIMap.remove n_ci m in hdr_map <- lazy m'; method content_length() = int_of_string (drop_ws(self # field "content-length")) method content_type() = Mimestring.scan_mime_type_ep (self#field "content-type") [] method content_disposition() = Mimestring.scan_mime_type_ep (self#field "content-disposition") [] method content_transfer_encoding() = String.lowercase (self # field "content-transfer-encoding") end ;; class complement_mime_header_ro h : mime_header = basic_mime_header ~ro:true h#fields ;; let complement_mime_header_ro h = new complement_mime_header_ro h ;; class memory_mime_body_int ?(ro_first=false) ?(ro=false) v : mime_body = object (self) (* ro_first (not exported): whether ro for the first write access *) val ro' = ro val mutable ro = ro_first val mutable value = v val mutable finalized = false method value = if finalized then self # finalized(); value method store = `Memory method open_value_rd() = if finalized then self # finalized(); new input_string value method finalize() = finalized <- true method ro = ro method set_value s = if finalized then self # finalized(); if ro then self#immutable() else value <- s; ro <- ro' method open_value_wr() = if finalized then self # finalized(); if ro then self#immutable(); ro <- ro'; let b = Netbuffer.create 60 in new output_netbuffer ~onclose:(fun () -> value <- Netbuffer.contents b) b; method private immutable() = raise (Immutable "Netmime.memory_mime_body"); method private finalized() = failwith "Netmime.memory_mime_body: object is finalized"; end ;; class memory_mime_body ?ro = memory_mime_body_int ?ro_first:ro ?ro ;; class file_mime_body_int ?(ro_first=false) ?(ro=false) ?(fin=false) f : mime_body = object (self) (* ro_first (not exported): whether ro for the first write access *) val ro' = ro val mutable ro = ro_first val mutable finalized = false val fin = fin val filename = f val cached_value = Weak.create 1 method ro = ro method store = `File filename method value = if finalized then self # finalized(); match Weak.get cached_value 0 with None -> with_in_obj_channel (new input_channel (open_in_bin filename)) (fun objch -> let v = string_of_in_obj_channel objch in Weak.set cached_value 0 (Some v); v ) | Some v -> v method open_value_rd() = if finalized then self # finalized(); new input_channel (open_in_bin filename) method set_value s = if finalized then self # finalized(); if ro then self#immutable(); ro <- ro'; with_out_obj_channel (new output_channel (open_out_bin filename)) (fun ch -> ch # output_string s); method open_value_wr() = if finalized then self # finalized(); if ro then self#immutable(); ro <- ro'; new output_channel (open_out_bin filename) method private immutable() = raise (Immutable "Netmime.file_mime_body"); method finalize () = if fin && not finalized then begin try Sys.remove filename with _ -> () end; finalized <- true method private finalized() = failwith "Netmime.file_mime_body: object is finalized"; end ;; class file_mime_body ?ro = file_mime_body_int ?ro_first:ro ?ro ;; class complement_mime_body_ro body : mime_body = object(self) val body = body method value = body#value method store = body#store method open_value_rd = body#open_value_rd method finalize = body#finalize method ro = true method set_value _ = raise (Immutable "Netmime.complement_mime_body_ro"); method open_value_wr _ = raise (Immutable "Netmime.complement_mime_body_ro"); end ;; (* FIXME: complement_mime_body_ro should make a copy of the value *) let complement_mime_body_ro body = new complement_mime_body_ro body;; let rec complement_complex_mime_message_ro (h,cb) = (complement_mime_header_ro h, match cb with `Body b -> `Body(complement_mime_body_ro b) | `Parts p -> `Parts(List.map complement_complex_mime_message_ro p) ) ;; let read_mime_header ?(unfold=false) ?(strip=true) ?ro stream = let h = Mimestring.read_header ~downcase:false ~unfold ~strip stream in new basic_mime_header ?ro h ;; type multipart_style = [ `None | `Flat | `Deep ] ;; let decode_mime_body hdr = let encoding = try hdr # content_transfer_encoding() with Not_found -> "7bit" in match encoding with ("7bit"|"8bit"|"binary") -> (fun s -> s) | "base64" -> (fun s -> new output_filter (new Netencoding.Base64.decoding_pipe ~url_variant:false ~accept_spaces:true ()) s) | "quoted-printable" -> (fun s -> new output_filter (new Netencoding.QuotedPrintable.decoding_pipe()) s) | _ -> failwith "Netmime.decode_mime_body: Unknown Content-transfer-encoding" ;; let encode_mime_body ?(crlf = true) hdr = let encoding = try hdr # content_transfer_encoding() with Not_found -> "7bit" in match encoding with ("7bit"|"8bit"|"binary") -> (fun s -> s) | "base64" -> (fun s -> new output_filter (new Netencoding.Base64.encoding_pipe ~linelength:76 ~crlf ()) s) | "quoted-printable" -> (fun s -> new output_filter (new Netencoding.QuotedPrintable.encoding_pipe ~crlf ()) s) | _ -> failwith "Netmime.encode_mime_body: Unknown Content-transfer-encoding" ;; let storage ?ro ?fin : store -> (mime_body * out_obj_channel) = function `Memory -> let body = new memory_mime_body_int ~ro_first:false ?ro "" in let body_ch = body#open_value_wr() in body, body_ch | `File filename -> let body = new file_mime_body_int ~ro_first:false ?ro ?fin filename in let body_ch = body#open_value_wr() in body, body_ch ;; let rec read_mime_message ?unfold ?strip ?ro ?(multipart_style = (`Deep : multipart_style)) ?(storage_style = fun _ -> storage ?ro `Memory) stream = (* First read the header: *) let h_obj = read_mime_header ?ro ?unfold ?strip stream in let mime_type, mime_type_params = try h_obj#content_type() with Not_found -> "", [] 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 (* Now parse the body, (with multiparts or without) *) let body = if is_multipart_type && multipart_style <> `None then begin (* --- Divide the message into parts: --- *) let boundary = try List.assoc "boundary" mime_type_params with Not_found -> failwith "Netmime.read_mime_message: missing boundary parameter" in let multipart_style = (* of the sub parser *) if multipart_style = `Flat then `None else multipart_style in `Parts (Mimestring.read_multipart_body (read_mime_message ?ro ~multipart_style ~storage_style) (Mimestring.param_value boundary) stream ) end else begin (* --- Read the body and optionally decode it: --- *) (* Where to store the body: *) let decoder = decode_mime_body h_obj in let body, body_ch = storage_style h_obj in if with_out_obj_channel (decoder body_ch) (fun body_ch' -> body_ch' # output_channel (stream :> in_obj_channel); body_ch' <> body_ch ) then body_ch # close_out(); `Body body end in (h_obj, body) ;; let rec augment_message (hdr,cbody) = (* Computes the content-transfer-encoding field for multipart messages. * The resulting message uses `Parts_ag(cte,parts) instead of `Parts(parts) * where cte is the content-transfer-encoding field. *) match cbody with `Body _ as b -> (hdr,b) | `Parts p -> let p' = List.map augment_message p in let mp_cte_id = List.fold_left (fun x (hdr,body) -> let cte = match body with `Body _ -> (try hdr#content_transfer_encoding() with Not_found -> "7bit") | `Parts_ag(cte,_) -> cte in let cte_id = match cte with "7bit" | "quoted-printable" | "base64" -> 0 | "8bit" -> 1 | _ -> 2 in max x cte_id ) 0 p' in let mp_cte = match mp_cte_id with 0 -> "7bit" | 1 -> "8bit" | 2 -> "binary" | _ -> assert false in (hdr, `Parts_ag(mp_cte,p')) ;; let rec write_mime_message_int ?(wr_header = true) ?(wr_body = true) ?(nr = 0) ?ret_boundary ?(crlf = true) outch (hdr,cbody) = let eol = if crlf then "\r\n" else "\n" in let mk_boundary parts = (* For performance reasons, gather random data only from the first * `Body *) let rec gather_data parts = match parts with (_,`Body body) :: parts' -> let s = String.make 240 ' ' in (* So it is in the minor heap *) with_in_obj_channel (body # open_value_rd()) (fun ch -> try ignore(ch # input s 0 240) with End_of_file -> () (* When body is empty *) ); [s] | (_,`Parts_ag(_, parts'')) :: parts' -> (try gather_data parts'' with Not_found -> gather_data parts') | [] -> raise Not_found in let data = try gather_data parts with Not_found -> [] in Mimestring.create_boundary ~random:data ~nr () in match cbody with `Body body -> (* Write the header as it is, and append the body *) if wr_header then Mimestring.write_header ~eol ~soft_eol:eol outch hdr#fields; if wr_body then begin let outch' = encode_mime_body ~crlf hdr outch in with_in_obj_channel (body # open_value_rd()) (fun bodych -> outch' # output_channel bodych); if outch' <> outch then outch' # close_out(); end | `Parts_ag(cte,parts) -> if parts = [] then failwith "Netmime.write_mime_message: Cannot write multipart message with empty list of parts"; (* If the header does not include a proper content-type field, repair * this now. *) let hdr' = new basic_mime_header hdr#fields in (* hdr' will contain the repaired header as side effect *) let boundary = try let ctype,params = try hdr # content_type() (* or Not_found *) with Not_found as ex -> raise ex (* falls through to next [try] *) | ex -> failwith ("Netmime.write_mime_message: Cannot parse content-type field: " ^ Netexn.to_string ex) in if String.length ctype < 10 || String.sub ctype 0 10 <> "multipart/" then failwith "Netmime.write_mime_message: The content type of a multipart message must be 'multipart/*'"; try let b = List.assoc "boundary" params in (* or Not_found *) Mimestring.param_value b with Not_found -> (* Add the missing boundary parameter: *) let b = mk_boundary parts in let ctype_field = hdr # field "content-type" ^ ";" ^ eol ^ " boundary=\"" ^ b ^ "\"" in hdr' # update_field "content-type" ctype_field; b with Not_found -> (* Add the missing content-type header: *) let b = mk_boundary parts in let ctype_field = "multipart/mixed;" ^ eol ^ " boundary=\"" ^ b ^ "\"" in hdr' # update_field "content-type" ctype_field; b in (* Now fix the content-transfer-encoding field *) hdr' # update_field "content-transfer-encoding" cte; (* Write now the header fields *) if wr_header then Mimestring.write_header ~eol ~soft_eol:eol outch hdr'#fields; (* Write the parts: *) if wr_body then begin let boundary_string = "--" ^ boundary ^ eol in List.iter (fun part -> outch # output_string boundary_string; write_mime_message_int ~wr_header:true ~wr_body:true ~nr:(nr + 1) ~crlf outch part; outch # output_string eol; ) parts; outch # output_string ("--" ^ boundary ^ "--" ^ eol); end; ( match ret_boundary with None -> () | Some r -> r := boundary ) ;; let write_mime_message ?wr_header ?wr_body ?nr ?ret_boundary ?crlf ch msg = write_mime_message_int ?wr_header ?wr_body ?nr ?ret_boundary ?crlf ch (augment_message msg) ;;