« back to all changes in this revision
Viewing changes to server/server.ml
- browse files at revision 14
- compare with another revision
- download diff
- download tarball
- view history from revision 14
- Committer: Bazaar Package Importer
- Author(s): Stephane Glondu
- Date: 2009-07-02 10:02:08 UTC
- mfrom: (1.1.9 upstream) (4.1.3 squeeze)
- Revision ID: james.westby@ubuntu.com-20090702100208-n158b1sqwzn0asil
Tags: 1.2.0-2
Fix build on non-native architectures
- files added:
- Makefile.ocamlbuild
- baselib/commandline
- baselib/nocommandline
- debian/patches
- examples/miniforum
- examples/miniforum/static
- examples/miniforum/v0
- examples/miniforum/v1
- examples/miniforum/v2
- files removed:
- baselib/ocsigen_commandline.mli
- xmlp4/ohl-xhtml/experimental
- xmlp4/oldocaml
- xmlp4/oldocaml/exemple
- files modified:
- CHANGES
added
removed
server/server.ml
1
(* Ocsigen
2
* http://www.ocsigen.org
3
* Module server.ml
4
* Copyright (C) 2005
5
* Vincent Balat, Denis Berthod, Nataliya Guts, J�r�me Vouillon
6
* Laboratoire PPS - CNRS Universit� Paris Diderot
7
*
8
* This program is free software; you can redistribute it and/or modify
9
* it under the terms of the GNU Lesser General Public License as published by
10
* the Free Software Foundation, with linking exception;
11
* either version 2.1 of the License, or (at your option) any later version.
12
*
13
* This program is distributed in the hope that it will be useful,
14
* but WITHOUT ANY WARRANTY; without even the implied warranty of
15
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
* GNU Lesser General Public License for more details.
17
*
18
* You should have received a copy of the GNU Lesser General Public License
19
* along with this program; if not, write to the Free Software
20
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
21
*)
22
23
open Lwt
24
open Ocsigen_messages
25
open Ocsigen_lib
26
open Ocsigen_extensions
27
open Ocsigen_http_frame
28
open Ocsigen_headers
29
open Ocsigen_http_com
30
open Ocsigen_senders
31
open Ocsigen_config
32
open Ocsigen_parseconfig
33
open Lazy
34
35
36
exception Ocsigen_unsupported_media
37
exception Ssl_Exception
38
exception Ocsigen_upload_forbidden
39
40
let () = Random.self_init ()
41
42
(* Without the following line, it stops with "Broken Pipe" without raising
43
an exception ... *)
44
let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
45
46
(* Initialize exception handler for Lwt timeouts: *)
47
let _ =
48
Lwt_timeout.set_exn_handler
49
(fun e -> Ocsigen_messages.errlog ("Uncaught Exception after lwt timeout: "^
50
Ocsigen_lib.string_of_exn e))
51
52
external disable_nagle : Unix.file_descr -> unit = "disable_nagle"
53
54
let option_get_default x d = match x with Some x -> x | None -> d
55
let local_addr addr num =
56
Unix.ADDR_INET (option_get_default addr Unix.inet_addr_any, num)
57
let local_addr6 addr num =
58
Unix.ADDR_INET (option_get_default addr Unix.inet6_addr_any, num)
59
60
let sslctx = Ocsigen_http_client.sslcontext
61
62
63
let ip_of_sockaddr = function
64
| Unix.ADDR_INET (ip, port) -> ip
65
| _ -> raise (Ocsigen_Internal_Error "ip of unix socket")
66
67
let port_of_sockaddr = function
68
| Unix.ADDR_INET (ip, port) -> port
69
| _ -> raise (Ocsigen_Internal_Error "port of unix socket")
70
71
72
let get_boundary ctparams = List.assoc "boundary" ctparams
73
(*
74
let (_, res) = Netstring_pcre.search_forward
75
(Netstring_pcre.regexp "boundary=([^;]*);?") cont_enc 0 in
76
Netstring_pcre.matched_group res 1 cont_enc
77
*)
78
79
let find_field field content_disp =
80
let (_, res) = Netstring_pcre.search_forward
81
(Netstring_pcre.regexp (field^"=.([^\"]*).;?")) content_disp 0 in
82
Netstring_pcre.matched_group res 1 content_disp
83
84
type to_write =
85
No_File of string * Buffer.t
86
| A_File of (string * string * string * Unix.file_descr)
87
88
let counter = let c = ref (Random.int 1000000) in fun () -> c := !c + 1 ; !c
89
90
let warn sockaddr s =
91
let ip = Unix.string_of_inet_addr (ip_of_sockaddr sockaddr) in
92
Ocsigen_messages.warning ("While talking to " ^ ip ^ ": " ^ s)
93
94
let dbg sockaddr s =
95
Ocsigen_messages.debug
96
(fun () ->
97
let ip = Unix.string_of_inet_addr (ip_of_sockaddr sockaddr) in
98
"While talking to " ^ ip ^ ": " ^ s)
99
100
(* reading the request *)
101
let get_request_infos
102
meth clientproto url http_frame filenames sockaddr
103
port receiver =
104
105
Lwt.catch
106
(fun () ->
107
108
let (headerhost, _, url, parsed_url, path, params, get_params) =
109
Ocsigen_lib.parse_url url
110
in
111
112
let headerhost =
113
match headerhost with
114
| None -> get_host_from_host_header http_frame
115
| _ -> headerhost
116
in
117
118
(* RFC:
119
1. If Request-URI is an absoluteURI, the host is part of the Request-URI. Any Host header field value in the request MUST be ignored.
120
2. If the Request-URI is not an absoluteURI, and the request includes a Host header field, the host is determined by the Host header field value.
121
3. If the host as determined by rule 1 or 2 is not a valid host on the server, the response MUST be a 400 (Bad Request) error message.
122
*)
123
(* Here we don't trust the port information given by the request.
124
We use the port we are listening on. *)
125
Ocsigen_messages.debug
126
(fun () ->
127
"- host="^(match headerhost with None -> "<none>" | Some h -> h));
128
129
(* Servers MUST report a 400 (Bad Request) error if an HTTP/1.1
130
request does not include a Host request-header. *)
131
132
if clientproto = Ocsigen_http_frame.Http_header.HTTP11 && headerhost = None
133
then raise Ocsigen_Bad_Request;
134
135
let useragent = get_user_agent http_frame in
136
137
let cookies_string = lazy (get_cookie_string http_frame) in
138
139
let cookies =
140
lazy (match (Lazy.force cookies_string) with
141
| None -> Ocsigen_http_frame.Cookievalues.empty
142
| Some s -> parse_cookies s)
143
in
144
145
let ifmodifiedsince = get_if_modified_since http_frame in
146
147
let ifunmodifiedsince = get_if_unmodified_since http_frame in
148
149
let ifnonematch = get_if_none_match http_frame in
150
151
let ifmatch = get_if_match http_frame in
152
153
let client_inet_addr = ip_of_sockaddr sockaddr in
154
155
let ct_string = get_content_type http_frame in
156
157
let ct = Ocsigen_headers.parse_content_type ct_string in
158
159
let cl = get_content_length http_frame in
160
161
let referer = lazy (get_referer http_frame) in
162
163
let accept = lazy (get_accept http_frame) in
164
165
let accept_charset = lazy (get_accept_charset http_frame) in
166
167
let accept_encoding = lazy (get_accept_encoding http_frame) in
168
169
let accept_language = lazy (get_accept_language http_frame) in
170
171
172
173
let find_post_params =
174
lazy
175
(if meth = Http_header.GET || meth = Http_header.HEAD then
176
return ([],[])
177
else
178
match http_frame.Ocsigen_http_frame.content with
179
| None -> return ([], [])
180
| Some body_gen ->
181
try
182
let ((ct, cst), ctparams) = match ct with
183
| None -> (("application", "octet-stream"), [])
184
| Some (c, p) -> (c, p)
185
in
186
let body = Ocsigen_stream.get body_gen in
187
catch
188
(fun () ->
189
let ctlow = String.lowercase ct in
190
let cstlow = String.lowercase cst in
191
if ctlow = "application" &&
192
cstlow = "x-www-form-urlencoded"
193
then
194
catch
195
(fun () ->
196
Ocsigen_stream.string_of_stream body >>= fun r ->
197
Lwt.return
198
((Netencoding.Url.dest_url_encoded_parameters r),
199
[]))
200
(function
201
| Ocsigen_stream.String_too_large ->
202
fail Input_is_too_large
203
| e -> fail e)
204
else
205
if not (ctlow = "multipart" && cstlow = "form-data")
206
then fail Ocsigen_unsupported_media
207
else
208
let bound = get_boundary ctparams in
209
let params = ref [] in
210
let files = ref [] in
211
let create hs =
212
let cd = List.assoc "content-disposition" hs in
213
let st = try
214
Some (find_field "filename" cd)
215
with Not_found -> None in
216
let p_name = find_field "name" cd in
217
match st with
218
| None -> No_File (p_name, Buffer.create 1024)
219
| Some store ->
220
let now =
221
Printf.sprintf
222
"%f-%d"
223
(Unix.gettimeofday ()) (counter ())
224
in
225
match ((Ocsigen_config.get_uploaddir ())) with
226
| Some dname ->
227
let fname = dname^"/"^now in
228
let fd = Unix.openfile fname
229
[Unix.O_CREAT;
230
Unix.O_TRUNC;
231
Unix.O_WRONLY;
232
Unix.O_NONBLOCK] 0o666 in
233
(* Ocsigen_messages.debug "file opened"; *)
234
filenames := fname::!filenames;
235
A_File (p_name, fname, store, fd)
236
| None -> raise Ocsigen_upload_forbidden
237
in
238
let rec add where s =
239
match where with
240
| No_File (p_name, to_buf) ->
241
Buffer.add_string to_buf s;
242
return ()
243
| A_File (_,_,_,wh) ->
244
let len = String.length s in
245
let r = Unix.write wh s 0 len in
246
if r < len then
247
(*XXXX Inefficient if s is long *)
248
add where (String.sub s r (len - r))
249
else
250
Lwt_unix.yield ()
251
in
252
let stop size = function
253
| No_File (p_name, to_buf) ->
254
return
255
(params := !params @
256
[(p_name, Buffer.contents to_buf)])
257
(* � la fin ? *)
258
| A_File (p_name,fname,oname,wh) ->
259
(* Ocsigen_messages.debug "closing file"; *)
260
files :=
261
!files@[(p_name, {tmp_filename=fname;
262
filesize=size;
263
raw_original_filename=oname;
264
original_basename=(Ocsigen_lib.basename oname)})];
265
Unix.close wh;
266
return ()
267
in
268
Multipart.scan_multipart_body_from_stream
269
body bound create add stop >>= fun () ->
270
(*VVV
271
Does scan_multipart_body_from_stream read
272
until the end or only what it needs?
273
If we do not consume here,
274
the following request will be read only when
275
this one is finished ...
276
*)
277
Ocsigen_stream.consume body_gen >>= fun () ->
278
Lwt.return (!params, !files))
279
(fun e -> (*XXX??? Ocsigen_stream.consume body >>= fun _ ->*) fail e)
280
with e -> fail e)
281
282
(* AEFF *) (* IN-MEMORY STOCKAGE *)
283
(* let bdlist = Mimestring.scan_multipart_body_and_decode s 0
284
* (String.length s) bound in
285
* Ocsigen_messages.debug (fun () -> string_of_int (List.length bdlist));
286
* let simplify (hs,b) =
287
* ((find_field "name"
288
* (List.assoc "content-disposition" hs)),b) in
289
* List.iter (fun (hs,b) ->
290
* List.iter (fun (h,v) -> Ocsigen_messages.debug (fun () -> h^"=="^v)) hs) bdlist;
291
* List.map simplify bdlist *)
292
in
293
let ipstring = Unix.string_of_inet_addr client_inet_addr in
294
Lwt.return
295
{ri_url_string = url;
296
ri_url = parsed_url;
297
ri_method = meth;
298
ri_protocol = http_frame.Ocsigen_http_frame.header.Ocsigen_http_frame.Http_header.proto;
299
ri_ssl = Lwt_ssl.is_ssl (Ocsigen_http_com.connection_fd receiver);
300
ri_full_path_string = string_of_url_path path;
301
ri_full_path = path;
302
ri_sub_path = path;
303
ri_sub_path_string = string_of_url_path path;
304
ri_get_params_string = params;
305
ri_host = headerhost;
306
ri_get_params = get_params;
307
ri_initial_get_params = get_params;
308
ri_post_params = lazy (force find_post_params >>= fun (a, b) ->
309
return a);
310
ri_files = lazy (force find_post_params >>= fun (a, b) ->
311
return b);
312
ri_remote_inet_addr = client_inet_addr;
313
ri_remote_ip = ipstring;
314
ri_remote_ip_parsed = lazy (fst (Ocsigen_lib.parse_ip ipstring));
315
ri_remote_port = port_of_sockaddr sockaddr;
316
ri_server_port = port;
317
ri_user_agent = useragent;
318
ri_cookies_string = cookies_string;
319
ri_cookies = cookies;
320
ri_ifmodifiedsince = ifmodifiedsince;
321
ri_ifunmodifiedsince = ifunmodifiedsince;
322
ri_ifnonematch = ifnonematch;
323
ri_ifmatch = ifmatch;
324
ri_content_type = ct;
325
ri_content_type_string = ct_string;
326
ri_content_length = cl;
327
ri_referer = referer;
328
ri_accept = accept;
329
ri_accept_charset = accept_charset;
330
ri_accept_encoding = accept_encoding;
331
ri_accept_language = accept_language;
332
ri_http_frame = http_frame;
333
ri_extension_info = [];
334
ri_client = Ocsigen_extensions.client_of_connection receiver;
335
}
336
)
337
(fun e ->
338
Ocsigen_messages.debug (fun () -> "~~~ Exn during get_request_infos : "^
339
string_of_exn e);
340
Lwt.fail e)
341
342
343
344
let service
345
receiver
346
sender_slot
347
request
348
meth
349
url
350
port
351
sockaddr
352
inputchan =
353
(* sender_slot is here for pipelining:
354
we must wait before sending the page,
355
because the previous one may not be sent *)
356
357
let head = meth = Http_header.HEAD in
358
let clientproto = Http_header.get_proto request.Ocsigen_http_frame.header in
359
360
let handle_service_errors e =
361
(* Exceptions during page generation *)
362
Ocsigen_messages.debug
363
(fun () -> "~~~ Exception during generation/sending: " ^ string_of_exn e);
364
match e with
365
(* EXCEPTIONS WHILE COMPUTING A PAGE *)
366
| Ocsigen_http_error (cookies_to_set, i) ->
367
Ocsigen_messages.debug
368
(fun () -> "-> Sending HTTP error "^(string_of_int i)^" "^
369
Ocsigen_http_frame.Http_error.expl_of_code i);
370
send_error
371
~exn:e
372
sender_slot
373
~clientproto
374
~cookies:cookies_to_set
375
~head
376
~code:i
377
~sender:Ocsigen_http_com.default_sender
378
()
379
| Ocsigen_stream.Interrupted Ocsigen_stream.Already_read ->
380
Ocsigen_messages.warning
381
"Cannot read the request twice. You probably have \
382
two incompatible options in <site> configuration, \
383
or the order of the options in the config file is wrong.";
384
send_error ~exn:e sender_slot ~clientproto ~head
385
~code:500 ~sender:Ocsigen_http_com.default_sender () (* Internal error *)
386
| Ocsigen_extensions.Ocsigen_malformed_url
387
| Unix.Unix_error (Unix.EACCES,_,_)
388
| Ocsigen_upload_forbidden ->
389
Ocsigen_messages.debug2 "-> Sending 403 Forbidden";
390
send_error ~exn:e sender_slot ~clientproto ~head
391
~code:403 ~sender:Ocsigen_http_com.default_sender ()
392
| Http_error.Http_exception (_,_,_) ->
393
send_error sender_slot ~clientproto ~head (* ~keep_alive:false *)
394
~exn:e ~sender:Ocsigen_http_com.default_sender ()
395
| Ocsigen_Bad_Request ->
396
Ocsigen_messages.debug2 "-> Sending 400";
397
send_error ~exn:e sender_slot ~clientproto ~head (* ~keep_alive:false *)
398
~code:400 ~sender:Ocsigen_http_com.default_sender ()
399
| Ocsigen_unsupported_media ->
400
Ocsigen_messages.debug2 "-> Sending 415";
401
send_error ~exn:e sender_slot ~clientproto ~head (* ~keep_alive:false *)
402
~code:415 ~sender:Ocsigen_http_com.default_sender ()
403
| Neturl.Malformed_URL ->
404
Ocsigen_messages.debug2 "-> Sending 400 (Malformed URL)";
405
send_error ~exn:e sender_slot ~clientproto ~head (* ~keep_alive:false *)
406
~code:400 ~sender:Ocsigen_http_com.default_sender () (* Malformed URL *)
407
| e ->
408
Ocsigen_messages.warning
409
("Exn during page generation: " ^ string_of_exn e ^" (sending 500)");
410
Ocsigen_messages.debug2 "-> Sending 500";
411
send_error ~exn:e sender_slot ~clientproto ~head
412
~code:500 ~sender:Ocsigen_http_com.default_sender ()
413
in
414
let finish_request () =
415
(* We asynchronously finish to read the request contents if this
416
is not done yet so that:
417
- we can handle the next request
418
- there is no dead-lock with the client writing the request and
419
the server writing the response.
420
We need to do this once the request has been handled before sending
421
any reply to the client. *)
422
match request.Ocsigen_http_frame.content with
423
Some f ->
424
ignore
425
(Lwt.catch
426
(fun () ->
427
Ocsigen_stream.finalize f (* will consume the stream and
428
unlock the mutex
429
if not already done *)
430
)
431
(function
432
| e ->
433
434
(match e with
435
Ocsigen_http_com.Lost_connection _ ->
436
warn sockaddr "connection abruptly closed by peer \
437
while reading contents"
438
| Ocsigen_http_com.Timeout ->
439
warn sockaddr "timeout while reading contents"
440
| Ocsigen_http_com.Aborted ->
441
warn sockaddr "reading thread aborted"
442
| Http_error.Http_exception (code, mesg, _) ->
443
warn sockaddr (Http_error.string_of_http_exception e)
444
| _ ->
445
Ocsigen_messages.unexpected_exception
446
e "Server.finish_request"
447
);
448
Ocsigen_http_com.abort receiver;
449
(* We unlock the receiver in order to resume the
450
reading loop. As the connection has been aborted,
451
the next read will fail and the connection will be
452
closed properly. *)
453
Ocsigen_http_com.unlock_receiver receiver;
454
Lwt.return ()))
455
| None ->
456
()
457
in
458
459
(* body of service *)
460
if meth <> Http_header.GET &&
461
meth <> Http_header.POST &&
462
meth <> Http_header.HEAD
463
then begin
464
(* VVV Warning: This must be done once and only once.
465
Put this somewhere else to ensure that?
466
*)
467
warn sockaddr ("Bad request: \""^url^"\"");
468
Ocsigen_http_com.wakeup_next_request receiver;
469
finish_request ();
470
(* RFC 2616, sect 5.1.1 *)
471
send_error
472
sender_slot ~clientproto ~head ~code:501
473
~sender:Ocsigen_http_com.default_sender ()
474
end else begin
475
let filenames = ref [] (* All the files sent by the request *) in
476
477
Lwt.finalize (fun () ->
478
(* *** First of all, we read the whole the request
479
(that will possibly create files) *)
480
Lwt.try_bind
481
(fun () ->
482
get_request_infos
483
meth clientproto url request filenames sockaddr
484
port receiver)
485
(fun ri ->
486
(* *** Now we generate the page and send it *)
487
(* Log *)
488
accesslog
489
(Format.sprintf
490
"connection for %s from %s (%s): %s"
491
(match ri.ri_host with
492
| None -> "<host not specified in the request>"
493
| Some h -> h)
494
ri.ri_remote_ip
495
ri.ri_user_agent
496
ri.ri_url_string);
497
498
(* Generation of pages is delegated to extensions: *)
499
Lwt.try_bind
500
(fun () ->
501
Ocsigen_extensions.do_for_site_matching
502
ri.ri_host ri.ri_server_port ri)
503
(fun res ->
504
finish_request ();
505
(* RFC
506
An HTTP/1.1 origin server, upon receiving a conditional request
507
that includes both a Last-Modified date (e.g., in an
508
If-Modified-Since or If-Unmodified-Since header field) and one or
509
more entity tags (e.g., in an If-Match, If-None-Match, or If-Range
510
header field) as cache validators, MUST NOT return a response
511
status of 304 (Not Modified) unless doing so is consistent with all
512
of the conditional header fields in the request.
513
-
514
The result of a request having both an If-Unmodified-Since header
515
field and either an If-None-Match or an If-Modified-Since header
516
fields is undefined by this specification.
517
*)
518
let not_modified =
519
let etagalreadyknown =
520
match res.res_etag with
521
| None -> false
522
| Some e -> List.mem e ri.ri_ifnonematch
523
in
524
match res.res_lastmodified, ri.ri_ifmodifiedsince with
525
| Some l, Some i when l <= i ->
526
ri.ri_ifnonematch = [] || etagalreadyknown
527
| _, None ->
528
etagalreadyknown
529
| _ ->
530
false
531
in
532
let precond_failed =
533
begin match
534
res.res_lastmodified, ri.ri_ifunmodifiedsince
535
with
536
| Some l, Some i -> i < l
537
| _ -> false
538
end
539
||
540
begin match ri.ri_ifmatch, res.res_etag with
541
| None, _ -> false
542
| Some _, None -> true
543
| Some l, Some e -> not (List.mem e l)
544
end
545
in
546
if not_modified then begin
547
Ocsigen_messages.debug2 "-> Sending 304 Not modified ";
548
Ocsigen_stream.finalize res.res_stream >>= fun () ->
549
let empty_result = Ocsigen_http_frame.empty_result () in
550
send
551
sender_slot
552
~clientproto
553
~head
554
~sender:Ocsigen_http_com.default_sender
555
{empty_result with res_code = 304 (* Not modified *)}
556
end else if precond_failed then begin
557
Ocsigen_messages.debug2
558
"-> Sending 412 Precondition Failed \
559
(if-unmodified-since header)";
560
Ocsigen_stream.finalize res.res_stream >>= fun () ->
561
let empty_result = Ocsigen_http_frame.empty_result () in
562
send
563
sender_slot
564
~clientproto
565
~head
566
~sender:Ocsigen_http_com.default_sender
567
{empty_result
568
with res_code = 412 (* Precondition failed *)}
569
end else
570
send
571
sender_slot
572
~clientproto
573
~head
574
~sender:Ocsigen_http_com.default_sender
575
res)
576
(fun e ->
577
finish_request ();
578
match e with
579
| Ocsigen_Is_a_directory ->
580
Ocsigen_messages.debug2 "-> Sending 301 Moved permanently";
581
let empty_result = Ocsigen_http_frame.empty_result () in
582
send
583
sender_slot
584
~clientproto
585
~head
586
~sender:Ocsigen_http_com.default_sender
587
{empty_result with
588
res_code = 301 (* Moved permanently *);
589
res_location = Some ((Neturl.string_of_url
590
(Neturl.undefault_url
591
~path:("/"::(ri.ri_full_path))
592
ri.ri_url))^"/")
593
}
594
| _ ->
595
handle_service_errors e))
596
(fun e ->
597
warn sockaddr ("Bad request: \""^url^"\"");
598
Ocsigen_http_com.wakeup_next_request receiver;
599
finish_request ();
600
handle_service_errors e))
601
(fun () ->
602
(* We remove all the files created by the request
603
(files sent by the client) *)
604
if !filenames <> [] then
605
Ocsigen_messages.debug2 "** Removing files";
606
List.iter
607
(fun a ->
608
try
609
Unix.unlink a
610
with Unix.Unix_error _ as e ->
611
Ocsigen_messages.warning
612
(Format.sprintf "Error while removing file %s: %s"
613
a (string_of_exn e)))
614
!filenames;
615
return ())
616
end
617
618
let linger in_ch receiver =
619
Lwt.catch
620
(fun () ->
621
(* We wait for 30 seconds at most and close the connection
622
after 2 seconds without receiving data from the client *)
623
let abort_fun () = Lwt_ssl.abort in_ch Exit in
624
let long_timeout = Lwt_timeout.create 30 abort_fun in
625
let short_timeout = Lwt_timeout.create 2 abort_fun in
626
Lwt_timeout.start long_timeout;
627
let s = String.create 1024 in
628
629
let rec linger_aux () =
630
Lwt_ssl.wait_read in_ch >>= fun () ->
631
Lwt.try_bind
632
(fun () ->
633
Lwt_timeout.start short_timeout;
634
Lwt_ssl.read in_ch s 0 1024)
635
(fun len ->
636
if len > 0 then linger_aux () else Lwt.return ())
637
(fun e ->
638
begin match e with
639
Unix.Unix_error(Unix.ECONNRESET,_,_)
640
| Ssl.Read_error (Ssl.Error_syscall | Ssl.Error_ssl)
641
| Exit ->
642
Lwt.return ()
643
| _ ->
644
Lwt.fail e
645
end)
646
in
647
(* We start the lingering reads before waiting for the
648
senders to terminate in order to avoid a deadlock *)
649
let linger_thread = linger_aux () in
650
Ocsigen_http_com.wait_all_senders receiver >>= fun () ->
651
Ocsigen_messages.debug2 "** SHUTDOWN";
652
Lwt_ssl.ssl_shutdown in_ch >>= fun () ->
653
Lwt_ssl.shutdown in_ch Unix.SHUTDOWN_SEND;
654
linger_thread >>= fun () ->
655
Lwt_timeout.stop long_timeout;
656
Lwt_timeout.stop short_timeout;
657
Lwt.return ())
658
(fun e ->
659
Ocsigen_messages.unexpected_exception e "Server.linger"; Lwt.return ())
660
661
let try_bind' f g h = Lwt.try_bind f h g
662
663
let handle_connection port in_ch sockaddr =
664
let receiver =
665
Ocsigen_http_com.create_receiver (Ocsigen_config.get_client_timeout ()) Query in_ch
666
in
667
668
let handle_write_errors e =
669
begin match e with
670
Lost_connection e' ->
671
warn sockaddr ("connection abruptly closed by peer ("
672
^ string_of_exn e' ^ ")")
673
| Ocsigen_http_com.Timeout ->
674
warn sockaddr "timeout"
675
| Ocsigen_http_com.Aborted ->
676
warn sockaddr "writing thread aborted"
677
| Ocsigen_stream.Interrupted e' ->
678
warn sockaddr ("interrupted content stream (" ^ string_of_exn e' ^ ")")
679
| _ ->
680
Ocsigen_messages.unexpected_exception e "Server.handle_write_errors"
681
end;
682
Ocsigen_http_com.abort receiver;
683
Lwt.fail Ocsigen_http_com.Aborted
684
in
685
686
let handle_read_errors e =
687
begin match e with
688
| Ocsigen_http_com.Connection_closed ->
689
(* This is the clean way to terminate the connection *)
690
dbg sockaddr "connection closed by peer";
691
Ocsigen_http_com.abort receiver;
692
Ocsigen_http_com.wait_all_senders receiver
693
| Ocsigen_http_com.Keepalive_timeout ->
694
dbg sockaddr "keepalive timeout";
695
Ocsigen_http_com.abort receiver;
696
Ocsigen_http_com.wait_all_senders receiver
697
| Ocsigen_http_com.Lost_connection _ ->
698
warn sockaddr "connection abruptly closed by peer";
699
Ocsigen_http_com.abort receiver;
700
Ocsigen_http_com.wait_all_senders receiver
701
| Ocsigen_http_com.Timeout ->
702
warn sockaddr "timeout";
703
Ocsigen_http_com.abort receiver;
704
Ocsigen_http_com.wait_all_senders receiver
705
| Ocsigen_http_com.Aborted ->
706
warn sockaddr "reading thread aborted";
707
Ocsigen_http_com.wait_all_senders receiver
708
| Http_error.Http_exception (code, mes, _) ->
709
warn sockaddr (Http_error.string_of_http_exception e);
710
Ocsigen_http_com.start_processing receiver (fun slot ->
711
(*XXX We should use the right information for clientproto
712
and head... *)
713
send_error slot
714
~clientproto:Ocsigen_http_frame.Http_header.HTTP10
715
~head:false
716
(* ~keep_alive:false *)
717
~exn:e
718
~sender:Ocsigen_http_com.default_sender ());
719
linger in_ch receiver
720
| _ ->
721
Ocsigen_messages.unexpected_exception e "Server.handle_read_errors";
722
Ocsigen_http_com.abort receiver;
723
Ocsigen_http_com.wait_all_senders receiver
724
end
725
in
726
727
let rec handle_request () =
728
try_bind'
729
(fun () ->
730
Ocsigen_messages.debug2 "** Receiving HTTP message";
731
(if Ocsigen_config.get_respect_pipeline () then
732
(* if we lock this mutex, requests from a same connection will be sent
733
to extensions in the same order they are received on pipeline.
734
It is locked only in server. Ocsigen_http_client has its own mutex.
735
(*VVV use the same? *)
736
*)
737
Ocsigen_http_com.block_next_request receiver
738
else
739
Lwt.return ())
740
>>= fun () ->
741
Ocsigen_http_com.get_http_frame receiver)
742
handle_read_errors
743
(fun request ->
744
let meth, url =
745
match Http_header.get_firstline request.Ocsigen_http_frame.header with
746
| Http_header.Query a -> a
747
| _ -> assert false
748
(*XXX Should be checked in [get_http_frame] *)
749
in
750
Ocsigen_http_com.start_processing receiver (fun slot ->
751
Lwt.catch
752
(fun () ->
753
(*XXX Why do we need the port but not the host name? *)
754
service receiver slot request meth url port sockaddr in_ch)
755
handle_write_errors);
756
if get_keepalive request.Ocsigen_http_frame.header then
757
handle_request ()
758
else (* No keep-alive => no pipeline *)
759
(* We wait for the query to be entirely read and for
760
the reply to be sent *)
761
Ocsigen_http_com.lock_receiver receiver >>= fun () ->
762
Ocsigen_http_com.wait_all_senders receiver)
763
764
in (* body of handle_connection *)
765
handle_request ()
766
767
let rec wait_connection use_ssl port socket =
768
try_bind'
769
(fun () -> Lwt_unix.accept socket)
770
(fun e ->
771
Ocsigen_messages.debug
772
(fun () -> Format.sprintf "Accept failed: %s" (string_of_exn e));
773
wait_connection use_ssl port socket)
774
(fun (s, sockaddr) ->
775
Ocsigen_messages.debug2
776
"\n__________________NEW CONNECTION__________________________";
777
incr_connected ();
778
let relaunch_at_once =
779
get_number_of_connected () < get_max_number_of_connections () in
780
if relaunch_at_once then
781
ignore (wait_connection use_ssl port socket)
782
else
783
ignore
784
(Ocsigen_messages.warning
785
(Format.sprintf "Max simultaneous connections (%d) reached."
786
(get_max_number_of_connections ())));
787
Lwt.catch
788
(fun () ->
789
Lwt_unix.set_close_on_exec s;
790
disable_nagle (Lwt_unix.unix_file_descr s);
791
begin if use_ssl then
792
Lwt_ssl.ssl_accept s !sslctx
793
else
794
Lwt.return (Lwt_ssl.plain s)
795
end >>= fun in_ch ->
796
handle_connection port in_ch sockaddr)
797
(fun e ->
798
Ocsigen_messages.unexpected_exception e
799
"Server.wait_connection (handle connection)";
800
return ()) >>= fun () ->
801
Ocsigen_messages.debug2 "** CLOSE";
802
begin try
803
Lwt_unix.close s
804
with Unix.Unix_error _ as e ->
805
Ocsigen_messages.unexpected_exception e "Server.wait_connection (close)"
806
end;
807
decr_connected ();
808
if not relaunch_at_once then
809
begin
810
debug2 "Ok releasing one connection";
811
ignore (wait_connection use_ssl port socket)
812
end;
813
Lwt.return ())
814
815
816
817
let stop m n =
818
errlog m; exit n
819
820
(** Thread waiting for events on a the listening port *)
821
let listen use_ssl (addr, port) wait_end_init =
822
let listening_socket =
823
try
824
let socket =
825
try
826
let socket = Lwt_unix.socket Unix.PF_INET6 Unix.SOCK_STREAM 0 in
827
Lwt_unix.set_close_on_exec socket;
828
Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
829
Lwt_unix.bind socket (local_addr6 addr port);
830
socket
831
with e ->
832
(*VVV CATCH only the IPv6 exception.
833
Is it:
834
| ENOPROTOOPT (* Protocol not available *) ?
835
| EPROTONOSUPPORT (* Protocol not supported *)???
836
| ...
837
*)
838
Ocsigen_messages.warning
839
("Exception while creating IPv6 socket: "^Ocsigen_lib.string_of_exn e);
840
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
841
Lwt_unix.set_close_on_exec socket;
842
Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
843
Lwt_unix.bind socket (local_addr addr port);
844
socket
845
in
846
Lwt_unix.listen socket 1024;
847
socket
848
with
849
| Unix.Unix_error (Unix.EACCES, _, _) ->
850
stop
851
(Format.sprintf "Fatal - You are not allowed to use port %d." port)
852
7
853
| Unix.Unix_error (Unix.EADDRINUSE, _, _) ->
854
stop (Format.sprintf "Fatal - The port %d is already in use." port) 8
855
| exn ->
856
stop ("Fatal - Uncaught exception: " ^ string_of_exn exn) 100
857
in
858
wait_end_init >>= fun () ->
859
wait_connection use_ssl port listening_socket
860
861
(* fatal errors messages *)
862
let errmsg = function
863
| Dynlink.Error e ->
864
(("Fatal - Dynamic linking error: "^(Dynlink.error_message e)),
865
6)
866
| (Unix.Unix_error _) as e ->
867
(("Fatal - "^(string_of_exn e)),
868
9)
869
| Ssl.Private_key_error ->
870
(("Fatal - bad password"),
871
10)
872
| Ocsigen_config.Config_file_error msg ->
873
(("Fatal - Error in configuration file: "^msg),
874
50)
875
| Simplexmlparser.Xml_parser_error s ->
876
(("Fatal - Error in configuration file: "^s),
877
51)
878
| Ocsigen_loader.Dynlink_error (s, exn) ->
879
(("Fatal - While loading "^s^": "^(string_of_exn exn)),
880
52)
881
| exn ->
882
try
883
((Ocsigen_extensions.get_init_exn_handler () exn),
884
20)
885
with
886
exn ->
887
(("Fatal - Uncaught exception: "^string_of_exn exn),
888
100)
889
890
891
892
893
(* reloading the cmo *)
894
let reload () =
895
896
(* That function cannot be interrupted??? *)
897
Ocsigen_messages.warning "Reloading config file" ;
898
899
(try
900
match parse_config () with
901
| [] -> ()
902
| s::_ ->
903
begin
904
Ocsigen_extensions.start_initialisation ();
905
906
parse_server true s;
907
908
Ocsigen_extensions.end_initialisation ();
909
910
end
911
with e ->
912
Ocsigen_extensions.end_initialisation ();
913
errlog (fst (errmsg e)));
914
915
Ocsigen_messages.warning "Config file reloaded"
916
917
918
919
let _ = try
920
921
let config_servers =
922
923
parse_config ()
924
925
in
926
927
let number_of_servers = List.length config_servers in
928
929
if number_of_servers > 1
930
then ignore (Ocsigen_messages.warning "Multiple servers not supported anymore");
931
932
let ask_for_passwd sslports _ =
933
print_string "Please enter the password for the HTTPS server listening \
934
on port(s) ";
935
print_string (String.concat ", " (List.map (fun (_,p) -> string_of_int p) sslports));
936
print_string ": ";
937
let old_term= Unix.tcgetattr Unix.stdin in
938
let old_echo = old_term.Unix.c_echo in
939
old_term.Unix.c_echo <- false;
940
Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
941
try
942
let r = read_line () in
943
print_newline ();
944
old_term.Unix.c_echo <- old_echo;
945
Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
946
r
947
with exn ->
948
old_term.Unix.c_echo <- old_echo;
949
Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
950
raise exn
951
in
952
953
let run (user, group) (_, ports, sslports) (minthreads, maxthreads) s =
954
955
Ocsigen_messages.open_files ();
956
957
Lwt_unix.run
958
(let wait_end_init = wait () in
959
(* Listening on all ports: *)
960
List.iter
961
(fun i ->
962
ignore (listen false i wait_end_init)) ports;
963
List.iter
964
(fun i ->
965
ignore (listen true i wait_end_init)) sslports;
966
967
let gid = match group with
968
| None -> Unix.getgid ()
969
| Some group -> (try
970
(Unix.getgrnam group).Unix.gr_gid
971
with e -> errlog ("Error: Wrong group"); raise e)
972
in
973
974
let uid = match user with
975
| None -> Unix.getuid ()
976
| Some user -> (try
977
(Unix.getpwnam user).Unix.pw_uid
978
with e -> (errlog ("Error: Wrong user"); raise e))
979
in
980
981
(* A pipe to communicate with the server *)
982
let commandpipe = get_command_pipe () in
983
(try
984
ignore (Unix.stat commandpipe);
985
with Unix.Unix_error _ ->
986
(try
987
let umask = Unix.umask 0 in
988
Unix.mkfifo commandpipe 0o660;
989
Unix.chown commandpipe uid gid;
990
ignore (Unix.umask umask);
991
with e ->
992
Ocsigen_messages.errlog
993
("Cannot create the command pipe: "^(string_of_exn e))));
994
995
(* I change the user for the process *)
996
(try
997
Unix.setgid gid;
998
Unix.setuid uid;
999
with e ->
1000
Ocsigen_messages.errlog ("Error: Wrong user or group"); raise e);
1001
1002
Ocsigen_config.set_user user;
1003
Ocsigen_config.set_group group;
1004
1005
(* Je suis fou :
1006
let rec f () =
1007
print_endline "-";
1008
Lwt_unix.yield () >>= f
1009
in f (); *)
1010
1011
if maxthreads < minthreads
1012
then
1013
raise
1014
(Config_file_error "maxthreads should be greater than minthreads");
1015
1016
ignore (Lwt_preemptive.init minthreads maxthreads Ocsigen_messages.errlog);
1017
1018
(* Now I can load the modules *)
1019
Dynlink.init ();
1020
Dynlink.allow_unsafe_modules true;
1021
1022
Ocsigen_extensions.start_initialisation ();
1023
1024
parse_server false s;
1025
1026
Dynlink.prohibit ["Ocsigen_extensions.R"];
1027
(* As libraries are reloaded each time the config file is read,
1028
we do not allow to register extensions in libraries *)
1029
(* seems it does not work :-( *)
1030
1031
1032
(* Closing stderr, stdout stdin if silent *)
1033
if (Ocsigen_config.get_silent ())
1034
then begin
1035
(* redirect stdout and stderr to /dev/null *)
1036
let devnull = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0 in
1037
Unix.dup2 devnull Unix.stdout;
1038
Unix.dup2 devnull Unix.stderr;
1039
Unix.close devnull;
1040
Unix.close Unix.stdin;
1041
end;
1042
1043
(* detach from the terminal *)
1044
if (Ocsigen_config.get_daemon ())
1045
then ignore (Unix.setsid ());
1046
1047
Ocsigen_extensions.end_initialisation ();
1048
1049
(* Communication with the server through the pipe *)
1050
(try
1051
ignore (Unix.stat commandpipe)
1052
with Unix.Unix_error _ ->
1053
let umask = Unix.umask 0 in
1054
Unix.mkfifo commandpipe 0o660;
1055
ignore (Unix.umask umask);
1056
ignore (Ocsigen_messages.warning "Command pipe created"));
1057
1058
let pipe = Lwt_chan.in_channel_of_descr
1059
(Lwt_unix.of_unix_file_descr
1060
(Unix.openfile commandpipe
1061
[Unix.O_RDWR; Unix.O_NONBLOCK; Unix.O_APPEND] 0o660)) in
1062
1063
let rec f () =
1064
Lwt_chan.input_line pipe >>=
1065
(fun s ->
1066
begin match s with
1067
| "reopen_logs" ->
1068
Ocsigen_messages.open_files ();
1069
Ocsigen_messages.warning "Log files reopened"
1070
| "reload" -> reload ()
1071
| "gc" ->
1072
Gc.compact ();
1073
Ocsigen_messages.warning "Heap compaction requested by user"
1074
| _ -> Ocsigen_messages.warning ("Unknown command: " ^ s)
1075
end; f ())
1076
in ignore (f ());
1077
1078
wakeup wait_end_init ();
1079
1080
warning "Ocsigen has been launched (initialisations ok)";
1081
1082
wait ()
1083
)
1084
in
1085
1086
let set_passwd_if_needed (ssl, ports, sslports) =
1087
if sslports <> []
1088
then
1089
match ssl with
1090
| None
1091
| Some (None, None) -> ()
1092
| Some (None, _) -> raise (Ocsigen_config.Config_file_error
1093
"SSL certificate is missing")
1094
| Some (_, None) -> raise (Ocsigen_config.Config_file_error
1095
"SSL key is missing")
1096
| Some ((Some c), (Some k)) ->
1097
Ssl.set_password_callback !sslctx (ask_for_passwd sslports);
1098
Ssl.use_certificate !sslctx c k
1099
in
1100
1101
let write_pid pid =
1102
match Ocsigen_config.get_pidfile () with
1103
None -> ()
1104
| Some p ->
1105
let spid = (string_of_int pid)^"\n" in
1106
let len = String.length spid in
1107
let f =
1108
Unix.openfile
1109
p
1110
[Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND] 0o640 in
1111
ignore (Unix.write f spid 0 len);
1112
Unix.close f
1113
in
1114
1115
let rec launch = function
1116
[] -> ()
1117
| [h] ->
1118
let user_info, sslinfo, threadinfo = extract_info h in
1119
set_passwd_if_needed sslinfo;
1120
let pid = Unix.fork () in
1121
if pid = 0
1122
then run user_info sslinfo threadinfo h
1123
else begin
1124
ignore
1125
(Ocsigen_messages.console
1126
(fun () -> "Process "^(string_of_int pid)^" detached"));
1127
write_pid pid;
1128
end
1129
| _ -> () (* Multiple servers not supported any more *)
1130
1131
in
1132
1133
if (not (get_daemon ())) &&
1134
number_of_servers = 1
1135
then
1136
let cf = List.hd config_servers in
1137
let (user_info,
1138
((ssl, ports, sslports) as sslinfo),
1139
threadinfo) =
1140
extract_info cf
1141
in
1142
(set_passwd_if_needed sslinfo;
1143
write_pid (Unix.getpid ());
1144
Ocsigen_config.set_ports ports;
1145
Ocsigen_config.set_sslports sslports;
1146
run user_info sslinfo threadinfo cf)
1147
else launch config_servers
1148
1149
with e ->
1150
let msg, errno = errmsg e in
1151
stop msg errno
Loggerhead is a web-based interface for Breezy
Version: 2.0.1