Skip to content
This repository
Newer
Older
100644 314 lines (282 sloc) 12.818 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* Rcontent: module for handling multiple http content types. *)
19 let eprintf fmt = Format.kfprintf (fun _ -> Format.pp_print_flush Format.err_formatter ()) Format.err_formatter fmt
20 module List = Base.List
21 module String = Base.String
22
23 type content =
24 | ContentString of string
25 | ContentBuffer of Buffer.t
26 | ContentFBuffer of FBuffer.t
27 | ContentFile of string * in_channel option * out_channel option * Unix.stats option * bool
28 | ContentNone
29
30 type content_type = CT_STRING | CT_BUFFER | CT_FBUFFER | CT_FILE | CT_NONE
31
32 let string_of_content_type = function
33 | CT_STRING -> "CT_STRING"
34 | CT_BUFFER -> "CT_BUFFER"
35 | CT_FBUFFER -> "CT_FBUFFER"
36 | CT_FILE -> "CT_FILE"
37 | CT_NONE -> "CT_NONE"
38
39 let content_temporary_files = ((ref []):string list ref)
40
41 let remove_temporary_file file =
42 content_temporary_files := List.filter (fun f -> f <> file) (!content_temporary_files)
43
44 let content_unlink_temporary_files () =
45 List.iter (fun f -> if File.exists f then ((*eprintf "Unlinking: %s\n" f;*) Unix.unlink f)) (!content_temporary_files);
46 content_temporary_files := []
47
48 let create_tmp_file () =
49 let (tmpfile,file) = Filename.open_temp_file ~mode:[Open_binary] "content_" "_tnetnoc" in
50 content_temporary_files := tmpfile::(!content_temporary_files);
51 (tmpfile,file)
52
53 let to_tmp_file f a close =
54 match create_tmp_file () with
55 | (tmpfile,file) ->
56 f file a;
57 if close
58 then (close_out file; ContentFile (tmpfile, None, None, Some (Unix.stat tmpfile),true))
59 else ContentFile (tmpfile, None, Some file, Some (Unix.stat tmpfile),true)
60
61 let get_content_type = function
62 | ContentString _ -> CT_STRING
63 | ContentBuffer _ -> CT_BUFFER
64 | ContentFBuffer _ -> CT_FBUFFER
65 | ContentFile _ -> CT_FILE
66 | ContentNone -> CT_NONE
67
68 let get_content = function
69 | ContentString s -> s
70 | ContentBuffer b -> Buffer.contents b
71 | ContentFBuffer b -> FBuffer.contents b
72 | ContentFile (f,_,None,_,_) -> File.content f
73 | ContentFile (f,_,Some oc,_,_) -> (Pervasives.flush oc; File.content f)
74 | ContentNone -> ""
75
76 let content_make ?(truncate=false) ?(hint=1024) = function
77 | CT_STRING -> ContentString ""
78 | CT_BUFFER -> ContentBuffer (Buffer.create hint)
79 | CT_FBUFFER -> ContentFBuffer (FBuffer.create hint)
80 | CT_FILE ->
81 let (tmpfile, file) = create_tmp_file () in
82 if truncate then Unix.truncate tmpfile hint; (* <-- Be careful with this *)
83 ContentFile (tmpfile,None,Some file,Some (Unix.stat tmpfile),true)
84 | CT_NONE -> ContentNone
85
86 let content_unallocate = function
87 | ContentString _ -> ()
88 | ContentBuffer b -> Buffer.clear b
89 | ContentFBuffer _ -> ()
90 | ContentFile (f,ic_opt,oc_opt,_,unlinkable) ->
91 (try (match ic_opt with Some ic -> close_in ic; | None -> ()) with Sys_error _ -> ());
92 (try (match oc_opt with Some oc -> close_out oc; | None -> ()) with Sys_error _ -> ());
93 content_temporary_files := List.filter (fun _f -> _f <> f) (!content_temporary_files);
94 if unlinkable && File.exists f then ((*eprintf "Unlinking: %s\n" f;*) Unix.unlink f);
95 | ContentNone -> ()
96
97 let content_add ?(evolve=true) ?(max_buffer_size=(10*1024*1024)) str = function
98 | ContentString s ->
99 if evolve
100 then
101 let sstr = s^str in
102 let len = String.length sstr in
103 let b = Buffer.create (len * 10) in
104 Buffer.add_string b sstr; ContentBuffer b
105 else
106 ContentString (s^str)
107 | ContentBuffer b ->
108 (Buffer.add_string b str;
109 if evolve && Buffer.length b >= max_buffer_size
110 then to_tmp_file Buffer.output_buffer b false
111 else ContentBuffer b)
112 | ContentFBuffer b -> ContentFBuffer (FBuffer.add b str)
113 | ContentFile (f,ic_opt,oc_opt,stat_opt,unlinkable) ->
114 let oc_opt =
115 match oc_opt with
116 | Some oc -> Some oc
117 | None -> Some (open_out_gen [Open_binary;Open_append] 0o777 f) in
118 Pervasives.output_string (Option.get oc_opt) str;
119 let stat_opt =
120 match stat_opt with
121 Some stat -> Some { stat with Unix.st_size = stat.Unix.st_size + String.length str }
122 | None -> None in
123 ContentFile (f,ic_opt,oc_opt,stat_opt,unlinkable)
124 | ContentNone -> ContentString str
125
126 let content_add_content ?(max_buffer_size=(10*1024*1024)) from_content to_content =
127 match from_content, to_content with
128 | ContentNone, content -> content
129 | content, ContentNone -> content
130 | _, ContentString ts -> content_add ~max_buffer_size ts from_content
131 | ContentBuffer fb, ContentBuffer tb ->
132 (Buffer.add_buffer fb tb;
133 if Buffer.length fb < max_buffer_size
134 then ContentBuffer fb
135 else to_tmp_file Buffer.output_buffer fb false)
136 | ContentFBuffer fb, ContentFBuffer tb ->
137 ContentFBuffer (FBuffer.union fb tb)
138 | ContentFile (ff,fic_opt,foc_opt,fstat_opt,funlinkable), ContentFile (tf,tic_opt,toc_opt,_,_) ->
139 ((match toc_opt with Some toc -> flush toc | None -> ());
140 let tic_opt = match tic_opt with | Some tic -> (seek_in tic 0; Some tic) | None -> Some (open_in tf) in
141 let foc_opt = match foc_opt with | Some foc -> Some foc | None -> Some (open_out_gen [Open_binary;Open_append] 0o777 ff) in
142 let buf = String.create 4096 in
143 let tic = Option.get tic_opt in
144 let foc = Option.get foc_opt in
145 let n = ref 1 in
146 let cnt = ref 0 in
147 while !n > 0 do
148 n := Pervasives.input tic buf 0 4096;
149 cnt := !cnt + !n;
150 Pervasives.output foc buf 0 !n
151 done;
152 let fstat_opt =
153 match fstat_opt with
154 Some fstat -> Some { fstat with Unix.st_size = fstat.Unix.st_size + !cnt }
155 | None -> None in
156 ContentFile (ff,fic_opt,foc_opt,fstat_opt,funlinkable))
157 | _, _ ->
158 content_add ~max_buffer_size (get_content to_content) from_content
159
160 (*
161 let tstcac () =
162 let rec op = function | [] -> [] | h::t as l -> (List.map (fun e -> h, e) l)@(op t) in
163 let cts = [CT_STRING; CT_BUFFER; CT_FBUFFER; CT_FILE] in
164 let lst = List.map (fun ct1ct2 -> ct1ct2, "abcdef") (op cts) in
165 let mkc ct str = let c = content_make ct in content_add ~evolve:false str c in
166 let mkp (ct1,str1,ct2,str2) = (mkc ct1 str1,mkc ct2 str2) in
167 let tst (ct1,ct2) = let c1, c2 = mkp (ct1,"abc",ct2,"def") in get_content (content_add_content c1 c2) in
168 let res = verifyfn tst (Sl.st2s string_of_content_type) (fun s -> s) lst in
169 content_unlink_temporary_files ();
170 res
171 *)
172
173 let bodystr ?(max_body=50) ?(escaped=false) ?(hex=false) content =
174 let body,dots =
175 match content with
176 | ContentString s ->
177 let len = String.length s in
178 let body = String.sub s 0 (min len max_body) in
179 let dots = len > max_body in
180 (body,dots)
181 | ContentBuffer b ->
182 let len = Buffer.length b in
183 let body = Buffer.sub b 0 (min len max_body) in
184 let dots = len > max_body in
185 (body,dots)
186 | ContentFBuffer b ->
187 let len = FBuffer.length b in
188 let body = FBuffer.sub b 0 (min len max_body) in
189 let dots = len > max_body in
190 (body,dots)
191 | ContentFile (filename,None,_,_,_) ->
192 let buf = String.create (max_body+1) in
193 let ic = open_in filename in
194 let len = input ic buf 0 (max_body+1) in
195 let () = close_in ic in
196 let body = String.sub buf 0 (min len max_body) in
197 let dots = len > max_body in
198 (body,dots)
199 | ContentFile (_,Some ic,_,_,_) ->
200 let buf = String.create (max_body+1) in
201 let () = seek_in ic 0 in
202 let len = input ic buf 0 (max_body+1) in
203 let body = String.sub buf 0 (min len max_body) in
204 let dots = len > max_body in
205 (body,dots)
206 | ContentNone ->
207 ("",false)
208 in
209 let hex = if hex then String.to_hex else fun x -> x in
210 let esc = if escaped then String.escaped else fun x -> x in
211 (esc (hex body))^(if dots then "..." else "")
212
213 let content_length = function
214 | ContentString s -> String.length s
215 | ContentBuffer b -> Buffer.length b
216 | ContentFBuffer b -> FBuffer.length b
217 | ContentFile (_,_,_,Some stat,_) -> stat.Unix.st_size
218 | ContentFile (f,_,_,None,_) -> (Unix.stat f).Unix.st_size
219 | ContentNone -> 0
220
221 let content_is_string = function
222 | ContentString _ -> true
223 | ContentBuffer _ -> true
224 | ContentFBuffer _ -> true
225 | ContentFile _ -> false
226 | ContentNone -> true
227
228 let content_is_buffer = function ContentBuffer _ -> true | _ -> false
229
230 let content_is_fbuffer = function ContentFBuffer _ -> true | _ -> false
231
232 let content_is_file = function
233 | ContentString _ -> false
234 | ContentBuffer _ -> false
235 | ContentFBuffer _ -> false
236 | ContentFile _ -> true
237 | ContentNone -> false
238
239 let content_force_string ?(unallocate=false) = function
240 | ContentString str -> ContentString str
241 | ContentBuffer buf -> ContentString (Buffer.contents buf)
242 | ContentFBuffer buf -> ContentString (FBuffer.contents buf)
243 | (ContentFile (f,_,oc_opt,_,_)) as c ->
244 (match oc_opt with Some oc -> Pervasives.flush oc | None -> ());
245 let str = File.content f in
246 if unallocate then content_unallocate c;
247 ContentString str
248 | ContentNone -> ContentString ""
249
250 let content_from_file ?(unlinkable=false) ?(stat=true) filename =
251 ContentFile (filename,None,None,(if stat then Some (Unix.stat filename) else None),unlinkable)
252
253 let content_force_file ?(close=false) = function
254 | ContentString str -> to_tmp_file output_string str close
255 | ContentBuffer buf -> to_tmp_file Buffer.output_buffer buf close
256 | ContentFBuffer buf -> to_tmp_file FBuffer.output buf close
257 | ContentFile (f,i,None,s,u) -> ContentFile (f,i,None,s,u)
258 | ContentFile (f,i,Some oc,s,u) -> if close then (close_out oc; ContentFile (f,i,None,s,u)) else ContentFile (f,i,Some oc,s,u)
259 | ContentNone -> to_tmp_file (fun _ _ -> ()) "" close
260
261 let content_rename_file ?(force=false) content target =
262 let get_oc () =
263 let mode = [Open_wronly;Open_creat;Open_binary]@(if force then [Open_trunc] else [Open_excl]) in
264 Pervasives.open_out_gen mode 0o640 target
265 in
266 match content with
267 | ContentString str -> let oc = get_oc () in output_string oc str; close_out oc; 1
268 | ContentBuffer buf -> let oc = get_oc () in Buffer.output_buffer oc buf; close_out oc; 1
269 | ContentFBuffer buf -> let oc = get_oc () in FBuffer.output oc buf; close_out oc; 1
270 | ContentFile (file,ic_opt,oc_opt,_,_) ->
271 (try (match ic_opt with Some ic -> close_in ic; | None -> ()) with Sys_error _ -> ());
272 (try (match oc_opt with Some oc -> close_out oc; | None -> ()) with Sys_error _ -> ());
273 remove_temporary_file file;
274 File.mv ~force file target
275 | ContentNone -> let oc = get_oc () in close_out oc; 1
276
277 let content_md5 = function
278 | ContentString str -> Digest.to_hex (Digest.string str)
279 | ContentBuffer buf -> Digest.to_hex (Digest.string (Buffer.contents buf))
280 | ContentFBuffer buf -> Digest.to_hex (Digest.string (FBuffer.contents buf))
281 | ContentFile (file,None,_,_,_) -> Digest.to_hex (Digest.file file)
282 | ContentFile (_,Some ic,_,_,_) -> (seek_in ic 0; Digest.to_hex (Digest.input ic))
283 | ContentNone -> Digest.to_hex (Digest.string "")
284
285 (*
286 let tst _type =
287 let cnt = 3 in
288 let c = content_make _type 100 in
289 let rec aux n c1 = if n <= 0 then c1 else aux (n-1) (content_add "abc" c1) in
290 let c1 = aux cnt c in
291 Printf.printf "%sc1: '%s'\n" _type (escaped (get_content c1));
292 Printf.printf "%sc1 length: %d\n" _type (content_length c1);
293 Printf.printf "%sc1 md5: %s\n" _type (content_md5 c1);
294 Printf.printf "%sc1 bodystr: %s\n" _type (bodystr ~max_body:25 ~hex:true c1);
295 let sc = content_force_string (aux cnt c) in
296 Printf.printf "%sc1: sc='%s'\n" _type (escaped (get_content sc));
297 let fc = content_force_file (aux cnt c) in
298 Printf.printf "%sc1: fc='%s'\n" _type (escaped (get_content fc));
299 let c2 = aux (cnt * 100) c in
300 let compressed, cc = content_compress true true 6 true c2 (content_length c2) in
301 Printf.printf "%sc1: compressed=%b length=%d cc='%s'\n" _type compressed (content_length cc) (escaped (get_content cc));
302 content_unallocate c;
303 content_unallocate c1;
304 content_unallocate fc;
305 content_unallocate cc;
306 if content_is_file c1 then content_unlink_temporary_files ()
307 ;;
308
309 let _ = tst "s";;
310 let _ = tst "b";;
311 let _ = tst "fb";;
312 let _ = tst "f";;
313 let _ = tst "n";;
314 *)
Something went wrong with that request. Please try again.