Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 631 lines (569 sloc) 23.894 kb
fccc685 Initial open-source release
MLstate authored
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 (** HttpTools:
19
20 Just some support routines for handling HTTP requests and responses.
21
22 *)
23
24 #<Debugvar:HTTP_DEBUG>
25
26 let http = NetAddr.mk_protocol "HTTP"
27
28 module List = Base.List
29 module String = Base.String
30 module Char = Base.Char
31
32 let ug = String.unsafe_get
33 let us = String.unsafe_sub
34
35 (* Local profiling code
36 * To be deleted when no longer required *)
37 let rpt n f a =
38 let rec aux = function 0 -> () | n -> (f a; aux (pred n)) in
39 aux n
40
41 let timefn n f a =
42 let start = Unix.gettimeofday () in
43 rpt n f a;
44 Printf.printf "time: %f\n" ((Unix.gettimeofday()) -. start)
45
46 let verifyfn f pa px lst =
47 List.for_all
48 (fun (a,x) ->
49 let res = f a in
50 if res = x
51 then true
52 else
53 (Logger.debug "Failed: '%s'\nExpected: '%s'\nGot: '%s'"
54 (String.escaped (pa a)) (String.escaped (px x)) (String.escaped (px res));
55 false)) lst
56
57 (** Strip a header comment from a string.
58 Comments can be nested.
59 NOTE: only removes the final comment at the end of the line if it exists.
60 *)
61 let strcom str strlen =
62 let rec aux n p =
63 let ch = ug str p in
64 if p >= 0
65 then
66 if ch = '('
67 then if n <= 1 then p else aux (pred n) (pred p)
68 else if ch = ')' then aux (succ n) (pred p) else aux n (pred p)
69 else 0
70 in
71 let rec aux2 p =
72 let ch = ug str p in
73 if p >= 0
74 then
75 if Charf.is_spacef ch
76 then aux2 (pred p)
77 else
78 if ch = ')'
79 then aux 1 (pred p)
80 else (succ p)
81 else 0
82 in
83 let p = (aux2 (pred strlen)) in
84 us str 0 p,
85 if p = strlen then None else Some (us str p (strlen-p))
86
87 (** Remove leading and trailing spaces from a string.
88 *)
89 let rmldtrsp0 str strlen =
90 let rec aux p =
91 if p < strlen && Charf.is_spacef (ug str p)
92 then aux (succ p)
93 else p in
94 let rec aux2 p =
95 if p >= 0 && Charf.is_spacef (ug str p)
96 then if p <= 0 then 0 else aux2 (pred p)
97 else p in
98 let st = aux 0 and nd = aux2 (pred strlen) in
99 us str st ((nd-st)+1)
100
101 let rmldtrsp str = rmldtrsp0 str (String.length str)
102
103 let rmldtrsp2 (str1,str2) = (rmldtrsp str1, rmldtrsp str2)
104
105 let rmldtrspl sl = List.map rmldtrsp sl
106
107 (* Used by generated mkrp.ml code, provide string up to marker for
108 * parsing http headers. Note that if we can't find the marker
109 * we actually return the whole string (multiline?).
110 *)
111
112 let pos_mark ug mark mlen str strlen n =
113 if mlen <= 0
114 then Some (n,n)
115 else
116 let rec pc0 pos =
117 let rec at m =
118 if m >= mlen
119 then true
120 else
121 if (pos+m) >= strlen
122 then false
123 else
124 if (ug str (pos+m)) = (ug mark m)
125 then at (m+1)
126 else false
127 in
128 if pos >= strlen
129 then None
130 else
131 if at 0
132 then Some (pos, pos+mlen)
133 else pc0 (pos+1) in
134 pc0 n
135
136 let upto_mark_ ug mark mlen str strlen n =
137 if n >= strlen
138 then (n, 0, "")
139 else
140 if mlen >= strlen - n
141 then (strlen, strlen - n, us str n (strlen-n))
142 else
143 match pos_mark ug mark mlen str strlen n with
144 | Some (pos, p2) ->
145 let l = pos - n in
146 let l = min l ((strlen-l)+1) in
147 (p2, l, (us str n l))
148 | None ->
149 (strlen, strlen - n, us str n (strlen-n))
150
151 let upto_mark = upto_mark_ ug
152 let upto_mark_ci = upto_mark_ (fun str n -> Char.lowercase (ug str n))
153
154 (* Stream-based versions *)
155
156 let cmp b mark =
157 let blen = Buffer.length b in
158 let mlen = String.length mark in
159 if blen < mlen
160 then false
161 else
162 let p = ref (blen - mlen) in
163 let m = ref 0 in
164 while !m < mlen && Buffer.nth b (!p) = String.unsafe_get mark (!m) do incr p; incr m done;
165 !m = mlen
166
167 let upto_mark_stream get from mark =
168 let rec aux b =
169 if cmp b mark
170 then Buffer.sub b 0 (Buffer.length b - String.length mark)
171 else
172 try
173 Buffer.add_char b (get from);
174 aux b
175 with End_of_file -> Buffer.contents b
176 in
177 aux (Buffer.create 1024)
178
179 let rec get_char_cps read (str_ref, pos_ref, conn) cont2 =
180 (*#<If>Logger.debug "HttpTools.get_char_cps: pos=%d str='%s'" (!pos_ref) (String.escaped (!str_ref))#<End>;*)
181 let str, pos = !str_ref, !pos_ref in
182 if pos >= String.length str
183 then
184 let k (_, str) =
185 (*#<If>Logger.debug "HttpTools.get_char_cps: read '%s'" (String.escaped str)#<End>;*)
186 str_ref := str; pos_ref := 0;
187 get_char_cps read (str_ref, pos_ref, conn) cont2
188 in
189 read conn k
190 else
191 cont2 (incr pos_ref; str.[pos])
192
193 let upto_mark_stream_cps ?(inclusive=true) buf get from mark cont =
194 (*#<If>Logger.debug "upto_mark_stream_cps: mark='%s'" (String.escaped mark)#<End>;*)
195 let rec aux b =
196 if cmp b mark
197 then
198 let str =
199 if inclusive
200 then Buffer.contents b
201 else Buffer.sub b 0 ((Buffer.length b) - (String.length mark)) in
202 (*#<If>Logger.debug "HttpTools.upto_mark_stream_cps: returning '%s'" (String.escaped str)#<End>;*)
203 cont str
204 else
205 try get from (fun c -> Buffer.add_char b c; aux b);
206 with End_of_file -> cont (Buffer.contents b)
207 in
208 Buffer.clear buf;
209 aux buf
210
211 let upto_stream_cps ?(inclusive=true) buf read (str_ref, pos_ref, conn) mark cont =
212 (*#<If>Logger.debug "upto_stream_cps: mark='%s'" (String.escaped mark)#<End>;*)
213 (*#<If>Logger.debug "upto_stream_cps: pos=%d str='%s'" (!pos_ref) (String.escaped (!str_ref))#<End>;*)
214 try
215 upto_mark_stream_cps ~inclusive buf (get_char_cps read) (str_ref, pos_ref, conn) mark cont
216 with exn ->
217 (*#<If>Logger.debug "upto_stream_cps: exn='%s'" (Printexc.to_string exn)#<End>;*)
218 raise exn
219
220 let read_upto_stream_cps ?(inclusive=true) buf (str_ref, pos_ref, conn) mark sched ?err_cont ?timeout cont =
221 let read = Scheduler.read sched ?err_cont ?timeout in
222 upto_stream_cps ~inclusive buf read (str_ref, pos_ref, conn) mark cont
223
224 let fixed_stream_cps buf read (str_ref, pos_ref, conn) count cont =
225 let rec aux b cnt =
226 if cnt >= count
227 then
228 let str = Buffer.contents b in
229 (*#<If>Logger.debug "HttpTools.fixed_stream_cps: returning '%s'" (String.escaped str)#<End>;*)
230 cont str
231 else
232 let strlen = String.length (!str_ref) in
233 if !pos_ref >= strlen
234 then
235 let aux2 (_, s) =
236 (*#<If>Logger.debug "HttpTools.fixed_stream_cps: read '%s'" (String.escaped s)#<End>;*)
237 let len = String.length s in
238 if cnt + len < count
239 then (Buffer.add_string b s;
240 str_ref := ""; pos_ref := 0;
241 aux b (cnt + len))
242 else (Buffer.add_string b (String.unsafe_sub s 0 (count - cnt));
243 str_ref := String.unsafe_sub s (count - cnt) (len - (count - cnt));
244 pos_ref := 0;
245 aux b count)
246 in
247 (try read conn aux2
248 with End_of_file ->
249 if Buffer.length b > 0
250 then
251 let str = Buffer.contents b in
252 (*#<If>Logger.debug "HttpTools.fixed_stream_cps: returning '%s'" (String.escaped str)#<End>;*)
253 cont str
254 else raise End_of_file)
255 else
256 let len = strlen - (!pos_ref) in
257 if cnt + len < count
258 then (Buffer.add_string b (String.unsafe_sub (!str_ref) (!pos_ref) len);
259 str_ref := ""; pos_ref := 0;
260 aux b (cnt + len))
261 else (Buffer.add_string b (String.unsafe_sub (!str_ref) (!pos_ref) (count - cnt));
262 pos_ref := (!pos_ref) + (count - cnt);
263 aux b count)
264 in
265 Buffer.clear buf;
266 aux buf 0
267
268 let read_fixed_stream_cps buf (str_ref, pos_ref, conn) count sched ?err_cont ?timeout cont =
269 let read = Scheduler.read sched ?err_cont ?timeout in
270 fixed_stream_cps buf read (str_ref, pos_ref, conn) count cont
271
272 let buf_clean (b,pos) =
273 #<If$minlevel 10>Logger.debug "buf_clean: blen=%d pos=%d" (Buffer.length b) (!pos)#<End>;
274 let blen = Buffer.length b in
275 if !pos >= blen
276 then (#<If$minlevel 2>Logger.debug "buf_clean: clear"#<End>; Buffer.clear b; pos := 0)
277 else
278 let tq x = (x lsr 1) + (x lsr 2) in
279 if blen >= 1024 && !pos >= (tq blen)
280 then
281 let str = Buffer.sub b !pos (blen-(!pos)) in
282 Buffer.clear b;
283 Buffer.add_string b str;
284 #<If$minlevel 2>Logger.debug "buf_clean: remove %d shift %d" (blen - Buffer.length b) (String.length str)#<End>;
285 pos := 0
286
287 let cmp2 b pos mark =
288 let mlen = String.length mark in
289 if pos < mlen - 1
290 then false
291 else
292 let p = ref pos in
293 let m = ref (mlen - 1) in
294 while !m >= 0 && Buffer.nth b (!p) = String.unsafe_get mark (!m) do decr p; decr m done;
295 !m < 0
296
297 exception CallbackAbort
298
299 (* We can't optionalize payload because ocaml_parser can't handle optional types. *)
300 let get_callback ?callback payload ?(blocksize=4096) ?err_cont start pos buf () =
301 let cb_start = ref (!pos) in
302 match callback with
303 | Some cb ->
304 (fun () ->
305 if !pos - !cb_start > blocksize
306 then (cb_start := !pos;
307 if cb payload (!pos - start) buf
308 then true
309 else ((match err_cont with
310 | Some err_fn -> err_fn CallbackAbort
311 | None -> raise CallbackAbort);
312 false))
313 else true)
314 | None ->
315 (fun () -> true)
316
317 let upto_mark_stream_cps2 ?(inclusive=true) sched conn (buf,pos) mark
318 ?callback payload ?blocksize ?err_cont ?timeout cont =
319 #<If>Logger.debug "upto_mark_stream_cps2(%d): mark='%s'" conn.Scheduler.conn_id (String.escaped mark)#<End>;
320 buf_clean (buf,pos);
321 let start = (!pos) in
322 let mlen = String.length mark in
323 let ch = String.unsafe_get mark (mlen - 1) in
324 #<If$minlevel 2>Logger.debug "upto_mark_stream_cps2: start=%d buflen=%d" start (Buffer.length buf)#<End>;
325 let call_callback = get_callback ?callback payload ?blocksize ?err_cont start pos buf () in
326 let rec aux () =
327 (*#<If$minlevel 10>Logger.debug "upto_mark_stream_cps2: pos=%d buflen=%d" (!pos) (Buffer.length buf)#<End>;*)
328 if (!pos) >= Buffer.length buf
329 then
330 try
331 Scheduler.read_more2 ?err_cont ?timeout sched conn buf
332 (fun (n,_buf) ->
333 (*#<If$minlevel 10>match oc_opt with
334 | Some oc -> (output_string oc (Buffer.sub _buf !pos n); Pervasives.flush oc)
335 | None -> ()#<End>;*)
336 #<If$minlevel 2>
337 Logger.debug "upto_mark_stream_cps2(%d): read %d" conn.Scheduler.conn_id n;
338 let s = Buffer.sub _buf !pos n in
339 Logger.debug "upto_mark_stream_cps2: buf='%s'..'%s'"
340 (String.escaped (String.limit 128 s))
341 (if String.length s < 128 then "" else (String.escaped (String.sub s (String.length s - 128) 128)))
342 #<End>;
343 if n <= 0 then raise End_of_file else aux ())
344 with
345 | End_of_file -> (Logger.debug "upto_mark_stream_cps2(%d): End_of_file Remaining='%s'"
346 conn.Scheduler.conn_id (String.limit 128 (Buffer.sub buf start ((!pos)-start)));
347 cont (buf,start,(!pos)-start))
de6e027 @Aqua-Ye [enhance] httpServer: switched http server response to full cps
Aqua-Ye authored
348 | exn -> (Logger.debug "upto_mark_stream_cps2(%d): exn=%s Remaining='%s'"
fccc685 Initial open-source release
MLstate authored
349 conn.Scheduler.conn_id (Printexc.to_string exn)
350 (String.limit 128 (Buffer.sub buf start ((!pos)-start)));
351 raise exn)
352 else
353 (let blen = Buffer.length buf in
354 (*let posstart = !pos in*)
355 while (!pos) < blen && Buffer.nth buf (!pos) <> ch do incr pos done;
356 if call_callback ()
357 then
358 (*Logger.debug "skipped %d" (!pos - posstart);*)
359 if (!pos) >= blen
360 then aux ()
361 else
362 (if cmp2 buf (!pos) mark
363 then
364 (incr pos;
365 let res =
366 if inclusive
367 then (buf,start,(!pos)-start)
368 else (buf,start,(!pos)-start-(String.length mark)) in
369 #<If$minlevel 2>Logger.debug "HttpTools.upto_mark_stream_cps2(%d): returning pos=%d '%s'"
370 conn.Scheduler.conn_id
371 (!pos) (String.escaped (String.limit 80 (Buffer.sub buf start ((!pos)-start))))#<End>;
372 cont res)
373 else (incr pos; aux ()))
374 else ())
375 in
376 aux ()
377
378 let upto_mark_stream_cps3 ?inclusive sched conn (buf,pos) mark ?callback payload ?blocksize ?err_cont ?timeout cont =
379 upto_mark_stream_cps2 ?inclusive sched conn (buf,pos) mark ?callback payload ?blocksize ?err_cont ?timeout
380 (fun (buf,start,len) -> cont (Buffer.sub buf start len))
381
d1b6eda @nrs135 [feature] libnet: Partially functorised stream parser, instantiated on ...
nrs135 authored
382 (* TODO: Expand this to the other stream parser functions *)
383 module type BUF_SIG =
384 sig
385 type t
386 val length : t -> int
387 val sub : t -> int -> int -> string
388 val clear : t -> unit
389 val reset : t -> unit
390 val add_string : t -> string -> unit
391 val read_more :
392 Scheduler.t -> Scheduler.connection_info -> ?read_max:int -> ?timeout:Time.t ->
393 t -> ?size_max:int -> ?err_cont:(exn -> unit) -> (int * t -> unit) -> unit
394 end
395
396 module type STREAM_PARSER_SIG =
397 sig
398 module B : BUF_SIG
399 val fixed_stream_cps2 :
400 (*?oc_opt:out_channel option ->*) Scheduler.t -> Scheduler.connection_info -> (B.t * int ref) -> int ->
401 ?callback:('a -> int -> B.t -> bool) -> 'a -> ?blocksize:int ->
402 ?err_cont:(exn -> unit) -> ?timeout:Time.t -> (B.t * int * int -> unit) -> unit
403 end
404
405 module StreamParserF(B: BUF_SIG) : STREAM_PARSER_SIG with module B = B =
406 struct
407
408 module B = B
409
410 let buf_clean (b,pos) =
411 #<If$minlevel 10>Logger.debug "buf_clean: blen=%d pos=%d" (B.length b) (!pos)#<End>;
412 let blen = B.length b in
413 if !pos >= blen
414 then (#<If$minlevel 2>Logger.debug "buf_clean: clear"#<End>; B.clear b; pos := 0)
415 else
416 let tq x = (x lsr 1) + (x lsr 2) in
417 if blen >= 1024 && !pos >= (tq blen)
fccc685 Initial open-source release
MLstate authored
418 then
d1b6eda @nrs135 [feature] libnet: Partially functorised stream parser, instantiated on ...
nrs135 authored
419 let str = B.sub b !pos (blen-(!pos)) in
420 B.clear b;
421 B.add_string b str;
422 #<If$minlevel 2>Logger.debug "buf_clean: remove %d shift %d" (blen - B.length b) (String.length str)#<End>;
423 pos := 0
424
425 let fixed_stream_cps2 sched conn (buf,pos) count ?callback payload ?blocksize ?err_cont ?timeout cont =
426 let conn_id = conn.Scheduler.conn_id in
427 buf_clean (buf,pos);
428 let start = !pos in
429 let call_callback = get_callback ?callback payload ?blocksize ?err_cont start pos buf () in
430 pos := B.length buf;
431 let rec aux () =
432 #<If$minlevel 2>Logger.debug "fixed_stream_cps2: conn_id:%d pos=%d start=%d count=%d buflen=%d"
433 conn_id !pos start count (B.length buf)#<End>;
434 if call_callback ()
435 then begin
436 if !pos - start >= count
437 then
438 (if !pos - start > count then pos := start + count;
439 (*#<If>Logger.debug "HttpTools.fixed_stream_cps2: returning pos=%d '%s'"
440 !pos (String.escaped (B.sub buf start count))#<End>;*)
441 cont (buf,start,count))
442 else
443 let err_cont = Option.default (fun exn -> Logger.debug "fixed_stream_cps2(A): conn_id=%d exn=%s"
444 conn_id (Printexc.to_string exn)) err_cont in
445 (#<If$minlevel 2>Logger.debug "fixed_stream_cps2(read_more2): pos=%d buflen=%d" !pos (B.length buf)#<End>;
446 try B.read_more ?timeout sched conn buf
447 ~err_cont:(function
448 | End_of_file -> (Logger.debug "fixed_stream_cps2: got End_of_file";
449 cont (buf,start,(!pos)-start))
450 | exn -> (Logger.debug "fixed_stream_cps2(B): conn_id=%d exn=%s"
451 conn_id (Printexc.to_string exn);
452 err_cont exn))
453 (fun (n,_buf) ->
454 (*#<If$minlevel 10>match oc_opt with
455 | Some oc -> (output_string oc (B.sub buf !pos n); Pervasives.flush oc)
456 | None -> ()#<End>;*)
457 #<If$minlevel 2>Logger.debug "fixed_stream_cps2: conn_id=%d read %d" conn_id n;
458 (*Logger.debug "fixed_stream_cps2: buf='%s'" (String.escaped (B.contents buf))*)
459 #<End>;
460 if n <= 0
461 then (Logger.debug "fixed_stream_cps2: raising End_of_file"; raise End_of_file)
462 else (pos := !pos + n; aux ()))
463 with exn -> (Logger.debug "fixed_stream_cps2(C): conn_id=%d exn=%s"
464 conn_id (Printexc.to_string exn); cont (buf,start,(!pos)-start)))
465 end
466 else ()
467 in
468 aux ()
469
470 end
471
472 module Buf_ : BUF_SIG with type t = Buf.t =
473 struct include Buf let read_more = Scheduler.read_more4 end
474 module StreamParserBuf : STREAM_PARSER_SIG with module B = Buf_ = StreamParserF(Buf_)
475 let fixed_stream_cps2_buf = StreamParserBuf.fixed_stream_cps2
476
477 module Buffer_ : BUF_SIG with type t = Buffer.t =
478 struct include Buffer let read_more = Scheduler.read_more2 end
479 module StreamParserBuffer : STREAM_PARSER_SIG with module B = Buffer_ = StreamParserF(Buffer_)
480 let fixed_stream_cps2 = StreamParserBuffer.fixed_stream_cps2
fccc685 Initial open-source release
MLstate authored
481
482 let fixed_stream_cps3 sched conn (buf,pos) count ?callback payload ?blocksize ?err_cont ?timeout cont =
483 fixed_stream_cps2 sched conn (buf,pos) count ?callback payload ?blocksize ?err_cont ?timeout
484 (fun (buf,start,len) -> cont (Buffer.sub buf start len))
485
486 let putback2 str (b, p) =
487 #<If$minlevel 1>Logger.debug "HttpTools.putback2 %d to (buflen=%d,pos=%d)" (String.length str) (Buffer.length b) (!p)#<End>;
488 (*#<If$minlevel 2>Logger.debug "HttpTools.putback2 '%s' to '%s'" (String.escaped str) (String.escaped (!s))#<End>;*)
489 buf_clean (b, p);
490 let blen = Buffer.length b in
491 if !p = 0 && blen = 0
492 then Buffer.add_string b str
493 else
494 (* TODO: this is very inefficient, we need to hack into Buffer and
495 * write a Buffer.blit_in or Buffer.prepend
496 *)
497 let bufstr = Buffer.sub b !p (blen - !p) in
498 Buffer.clear b;
499 Buffer.add_string b str;
500 Buffer.add_string b bufstr;
501 p := 0
502
503 let buflst = ref ([]:Buffer.t list)
504 let bufcnt = ref 0
505
506 let collect_bufs needed =
507 let target = !bufcnt lsr 1 in
508 #<If$minlevel 10>Logger.debug "collect_bufs: needed=%d target=%d bufcnt=%d" needed target !bufcnt#<End>;
509 if target >= 2 && needed <= target
510 then
511 let rec aux () =
512 if !bufcnt > target
513 then (Buffer.reset (List.hd (!buflst));
514 buflst := List.tl (!buflst);
515 decr bufcnt;
516 aux ())
517 else
518 #<If$minlevel 2>Logger.debug "collect_bufs: reduced to %d" !bufcnt#<End>
519 in
520 aux ()
521
522 let get_buf ?(hint=4096) () =
523 match !buflst with
524 | [] -> (#<If$minlevel 2>Logger.debug "get_buf(%d): new" !bufcnt#<End>; Buffer.create hint)
525 | b::t -> (#<If$minlevel 2>Logger.debug "get_buf(%d): old" !bufcnt#<End>; buflst := t; decr bufcnt; Buffer.clear b; b)
526
527 let free_buf b =
528 if Buffer.length b <= (10*1024*1024)
529 then (#<If$minlevel 2>Logger.debug "free_buf(%d): return" !bufcnt#<End>; buflst := b::(!buflst); incr bufcnt)
530 else (#<If$minlevel 2>Logger.debug "free_buf(%d): reset" !bufcnt#<End>; Buffer.reset b)
531
532 let upto mark read conn cont = upto_mark_stream_cps (Buffer.create 1024) (get_char_cps read) conn mark cont
533
534 let putback str (s, p, _) =
535 (*#<If>Logger.debug "HttpTools.putback '%s' to '%s'" (String.escaped str) (String.escaped (!s))#<End>;*)
536 if !p = 0
537 then s := str^(!s)
538 else
539 if !p >= String.length (!s)
540 then (s := str; p := 0)
541 else
542 let strlen = String.length str in
543 if !p >= strlen
544 then (String.unsafe_blit str 0 (!s) ((!p)-strlen) strlen; p := (!p) - strlen)
545 else (String.unsafe_blit str (strlen - (!p)) (!s) 0 (!p);
546 s := (String.unsafe_sub str 0 (strlen-(!p)))^(!s);
547 p := 0)
548
549 let skip_ is_ s l n = let rec sl p = if p >= l then l else if is_ (ug s p) then sl (p+1) else p in sl n
550 let skip_sptab = skip_ Charf.is_sptabf
551 let skip_lws = skip_ Charf.is_spacef
552
553 (* field value can span multiple lines with newline + space *)
554 let upto_mark_lws_ ug mark mlen str strlen n =
555 let pos = skip_sptab str strlen n in
556 let pos0 = pos in
557 match pos_mark ug mark mlen str strlen pos with
558 | Some (pos_, pos) ->
559 let len0 = pos_ - pos0 in
560 let str0 = String.sub str pos0 len0 in
561 if pos >= strlen
562 then (strlen,len0,str0)
563 else if ug str pos <> ' ' && ug str pos <> '\t'
564 then (pos,len0,str0)
565 else
566 let rec uhc str1 len1 pos =
567 let pos = skip_sptab str strlen pos in
568 let pos0 = pos in
569 match pos_mark ug mark mlen str strlen pos with
570 | Some (pos_, pos) ->
571 let l = pos_ - pos0 in
572 let len1 = len1 + l + 1 in
573 let str1 = (String.sub str pos0 l)::str1 in
574 if pos >= strlen
575 then (strlen,len1,String.rev_sconcat " " str1)
576 else if ug str pos <> ' ' && ug str pos <> '\t'
577 then (pos,len1,String.rev_sconcat " " str1)
578 else uhc str1 len1 pos
579 | None ->
580 let l = strlen - pos0 in
581 let len1 = len1 + l + 1 in
582 let str1 = (String.sub str pos0 l)::str1 in
583 (strlen,len1,String.rev_sconcat " " str1)
584 in
585 uhc [str0] len0 pos
586 | None ->
587 (strlen, strlen - n, us str n (strlen-n))
588
589 let upto_mark_lws = upto_mark_lws_ ug
590 let upto_mark_lws_ci = upto_mark_lws_ (fun str n -> Char.lowercase (ug str n))
591
592 (* Had to move this in here because of dependencies. *)
593
de6e027 @Aqua-Ye [enhance] httpServer: switched http server response to full cps
Aqua-Ye authored
594 let content_compress sched gzip deflate compression_level cache_response content content_len cont =
595 match content with
596 | Rcontent.ContentString str ->
597 Compression.compress_content sched gzip deflate compression_level cache_response str content_len
598 (function (compressed, str) -> cont (compressed, Rcontent.ContentString str))
599 | Rcontent.ContentBuffer buf ->
600 Compression.compress_content sched gzip deflate compression_level cache_response
601 (Buffer.contents buf) content_len
602 (function (compressed, str) -> cont (compressed, Rcontent.ContentString str))
603 | Rcontent.ContentFBuffer buf ->
604 Compression.compress_content sched gzip deflate compression_level cache_response
605 (FBuffer.contents buf) content_len
606 (function compressed, str -> cont (compressed, Rcontent.ContentString str))
607 | Rcontent.ContentFile (file,ic_opt,oc_opt,fstat_opt,unlinkable) ->
608 Compression.compress_file sched gzip deflate compression_level cache_response file fstat_opt content_len
609 (function compressed, file, fstat_opt -> cont (compressed, Rcontent.ContentFile (file,ic_opt,oc_opt,fstat_opt,unlinkable)))
610 | Rcontent.ContentNone ->
611 cont (false, Rcontent.ContentNone)
fccc685 Initial open-source release
MLstate authored
612
613 let make_ssl_cert ssl_cert ssl_key ssl_pass =
614 if ssl_cert <> "" then
615 if ssl_key <> "" then
616 Some (SslAS.make_ssl_certificate ssl_cert ssl_key ssl_pass)
617 else begin
618 Logger.log "Error : ssl-cert option MUST be used with ssl-key option";
619 exit 1
620 end
621 else
622 None
623
624 let make_ssl_verify ssl_ca_file ssl_ca_path ssl_client_cert_path ssl_client_ca_file ssl_accept_fun ssl_always =
625 if ssl_ca_file <> "" || ssl_ca_path <> "" || ssl_client_cert_path <> "" then
626 Some (SslAS.make_ssl_verify_params ~client_ca_file:ssl_client_ca_file
627 ~accept_fun:ssl_accept_fun ~always:ssl_always
628 ssl_ca_file ssl_ca_path ssl_client_cert_path)
629 else
630 None
Something went wrong with that request. Please try again.