22 |
open TcpBufferedSocket |
open TcpBufferedSocket |
23 |
|
|
24 |
let verbose = ref false |
let verbose = ref false |
25 |
|
|
26 |
let html_escaped s = |
let html_escaped s = |
27 |
String2.convert false (fun b escaped c -> |
String2.convert false (fun b escaped c -> |
28 |
if escaped then |
if escaped then |
69 |
|
|
70 |
|
|
71 |
let debug = ref false |
let debug = ref false |
72 |
|
|
73 |
type auth = |
type auth = |
74 |
| No_auth |
| No_auth |
75 |
| Read_auth |
| Read_auth |
76 |
| Write_auth |
| Write_auth |
77 |
|
|
78 |
|
|
79 |
type header = |
type header = |
80 |
Unknown of string * string |
Unknown of string * string |
81 |
| Referer of Url.url |
| Referer of Url.url |
82 |
| Authorization of auth |
| Authorization of auth |
83 |
|
|
84 |
|
|
85 |
exception ProcessForked |
exception ProcessForked |
86 |
exception ThreadForked |
exception ThreadForked |
96 |
} |
} |
97 |
|
|
98 |
type full_header = string * string (* * string * (string * string) list) *) |
type full_header = string * string (* * string * (string * string) list) *) |
99 |
|
|
100 |
type form_arg = { |
type form_arg = { |
101 |
arg_name : string; |
arg_name : string; |
102 |
arg_value : string; |
arg_value : string; |
104 |
arg_headers : full_header list; |
arg_headers : full_header list; |
105 |
} |
} |
106 |
|
|
107 |
type version = |
type version = |
108 |
HTTP1_0 |
HTTP1_0 |
109 |
| HTTP1_1 |
| HTTP1_1 |
110 |
| HTTP |
| HTTP |
111 |
|
|
112 |
type request = { |
type request = { |
113 |
sock : TcpBufferedSocket.t; |
sock : TcpBufferedSocket.t; |
114 |
request : string; |
request : string; |
117 |
options : options; |
options : options; |
118 |
headers : full_header list; |
headers : full_header list; |
119 |
form_args : form_arg list; |
form_args : form_arg list; |
120 |
|
|
121 |
mutable reply_head : string; |
mutable reply_head : string; |
122 |
mutable reply_headers : (string * string) list; |
mutable reply_headers : (string * string) list; |
123 |
mutable reply_content : string; |
mutable reply_content : string; |
135 |
default : handler; |
default : handler; |
136 |
} |
} |
137 |
|
|
138 |
|
|
139 |
let escaped s = |
let escaped s = |
140 |
String2.convert () (fun b _ c -> |
String2.convert () (fun b _ c -> |
141 |
match c with |
match c with |
142 |
'\r' -> Buffer.add_string b "\\r" |
'\r' -> Buffer.add_string b "\\r" |
143 |
| '\n' -> Buffer.add_string b "\\n\n" |
| '\n' -> Buffer.add_string b "\\n\n" |
144 |
| _ -> Buffer.add_char b c) s |
| _ -> Buffer.add_char b c) s |
145 |
|
|
146 |
|
|
147 |
let default_options = { |
let default_options = { |
148 |
(* authorization = No_auth;*) |
(* authorization = No_auth;*) |
149 |
referer = None; |
referer = None; |
170 |
in |
in |
171 |
let line, tail = iter line tail in |
let line, tail = iter line tail in |
172 |
let len = String.length line in |
let len = String.length line in |
173 |
|
|
174 |
let sep = String.index line ':' in |
let sep = String.index line ':' in |
175 |
let name = String.sub line 0 sep in |
let name = String.sub line 0 sep in |
176 |
let rec iter sep = |
let rec iter sep = |
181 |
in |
in |
182 |
let value = iter (sep+1) in |
let value = iter (sep+1) in |
183 |
(* |
(* |
184 |
let head, args = |
let head, args = |
185 |
try |
try |
186 |
Http_lexer.get_value (Lexing.from_string value) |
Http_lexer.get_value (Lexing.from_string value) |
187 |
with _ -> "", [] |
with _ -> "", [] |
188 |
in |
in |
189 |
*) |
*) |
190 |
parse_headers tail ((name, (value (* , head, args *) )) :: headers) |
parse_headers tail ((name, (value (* , head, args *) )) :: headers) |
191 |
|
|
192 |
(* |
(* |
193 |
|
|
194 |
let content_type_str = "Content-Type" |
let content_type_str = "Content-Type" |
195 |
|
|
196 |
*) |
*) |
197 |
|
|
198 |
let split_head s = |
let split_head s = |
199 |
let rec iter pos1 res = |
let rec iter pos1 res = |
200 |
try |
try |
203 |
let line = String.sub s pos1 (pos2 - pos1) in |
let line = String.sub s pos1 (pos2 - pos1) in |
204 |
if line = "" then List.rev res else |
if line = "" then List.rev res else |
205 |
iter (pos3+1) (line :: res) |
iter (pos3+1) (line :: res) |
206 |
with _ -> |
with _ -> |
207 |
let last_line = String.sub s pos1 (String.length s - pos1) in |
let last_line = String.sub s pos1 (String.length s - pos1) in |
208 |
List.rev (if last_line = "" then res else last_line :: res) |
List.rev (if last_line = "" then res else last_line :: res) |
209 |
in |
in |
210 |
iter 0 [] |
iter 0 [] |
211 |
|
|
212 |
let parse_head sock s = |
let parse_head sock s = |
213 |
let h = split_head s in |
let h = split_head s in |
214 |
(* List.iter (fun s -> lprintf "LINE: [%s]\n" (escaped s)) h; *) |
(* List.iter (fun s -> lprintf "LINE: [%s]\n" (escaped s)) h; *) |
215 |
match h with |
match h with |
216 |
[] -> failwith "Http_server: Empty head" |
[] -> failwith "Http_server: Empty head" |
217 |
| ans :: headers -> |
| ans :: headers -> |
218 |
(* get the status line *) |
(* get the status line *) |
219 |
let fin_meth = String.index ans ' ' in |
let fin_meth = String.index ans ' ' in |
220 |
let meth = String.sub ans 0 fin_meth in |
let meth = String.sub ans 0 fin_meth in |
221 |
let fin_file = String.index_from ans (fin_meth + 1) ' ' in |
let fin_file = String.index_from ans (fin_meth + 1) ' ' in |
222 |
let file = String.sub ans (fin_meth+1) (fin_file-fin_meth-1) in |
let file = String.sub ans (fin_meth+2) (fin_file-fin_meth-2) in |
223 |
let version = match ans.[String.length ans - 1] with |
let version = match ans.[String.length ans - 1] with |
224 |
'0' -> HTTP1_0 |
'0' -> HTTP1_0 |
225 |
| '1' -> HTTP1_1 |
| '1' -> HTTP1_1 |
226 |
| _ -> HTTP |
| _ -> HTTP |
229 |
let options = List.fold_left (fun options |
let options = List.fold_left (fun options |
230 |
(name, value (* , head, args *)) -> |
(name, value (* , head, args *)) -> |
231 |
try |
try |
232 |
match String.lowercase name with |
match String.lowercase name with |
233 |
"authorization" -> |
"authorization" -> |
234 |
let _, pass = String2.cut_at value ' ' in |
let _, pass = String2.cut_at value ' ' in |
235 |
let pass = decode64 pass in |
let pass = decode64 pass in |
236 |
let login, pswd = String2.cut_at pass ':' in |
let login, pswd = String2.cut_at pass ':' in |
237 |
{ options with |
{ options with |
238 |
login = login; |
login = login; |
239 |
passwd = pswd } |
passwd = pswd } |
240 |
| "content-length" |
| "content-length" |
241 |
-> |
-> |
242 |
{ options with content_length = int_of_string value } |
{ options with content_length = int_of_string value } |
253 |
(Printexc2.to_string e) name; |
(Printexc2.to_string e) name; |
254 |
end; |
end; |
255 |
options |
options |
256 |
|
|
257 |
) default_options headers in |
) default_options headers in |
258 |
{ |
{ |
259 |
sock = sock; |
sock = sock; |
267 |
request = meth; |
request = meth; |
268 |
form_args = []; |
form_args = []; |
269 |
version = version; |
version = version; |
270 |
|
|
271 |
reply_head = "200 OK"; |
reply_head = "200 OK"; |
272 |
reply_headers = []; |
reply_headers = []; |
273 |
reply_stream = None; |
reply_stream = None; |
285 |
| _ -> Buffer.add_char b c) s |
| _ -> Buffer.add_char b c) s |
286 |
|
|
287 |
(* |
(* |
288 |
|
|
289 |
let complete_multipart_data request ic tail = |
let complete_multipart_data request ic tail = |
290 |
let _, boundary = String2.cut_at tail '=' in |
let _, boundary = String2.cut_at tail '=' in |
291 |
let boundary_len = String.length boundary in |
let boundary_len = String.length boundary in |
302 |
if line = boundary || line = boundary2 then |
if line = boundary || line = boundary2 then |
303 |
get_one_part [] |
get_one_part [] |
304 |
else find_first () |
else find_first () |
305 |
|
|
306 |
and get_one_part previous = |
and get_one_part previous = |
307 |
let rec get_lines lines = |
let rec get_lines lines = |
308 |
try |
try |
313 |
let lines = get_lines [] in |
let lines = get_lines [] in |
314 |
let field = |
let field = |
315 |
match lines with |
match lines with |
316 |
("Content-Disposition", (_, "form-data", ("name", name) :: |
("Content-Disposition", (_, "form-data", ("name", name) :: |
317 |
args)) |
args)) |
318 |
:: other_lines |
:: other_lines |
319 |
-> |
-> |
320 |
begin |
begin |
321 |
match other_lines, args with |
match other_lines, args with |
322 |
[], [] -> |
[], [] -> |
325 |
let line = Stream_in.input_netline ic in |
let line = Stream_in.input_netline ic in |
326 |
if line = boundary || line = boundary2 |
if line = boundary || line = boundary2 |
327 |
|| ( |
|| ( |
328 |
(line = end_boundary || line = end_boundary2) |
(line = end_boundary || line = end_boundary2) |
329 |
&& (end_boundary_found := true; true) |
&& (end_boundary_found := true; true) |
330 |
) |
) |
331 |
then |
then |
332 |
Buffer.contents buf |
Buffer.contents buf |
333 |
else |
else |
334 |
begin |
begin |
335 |
Buffer.add_string buf (convert_nl line); |
Buffer.add_string buf (convert_nl line); |
342 |
arg_headers = lines; |
arg_headers = lines; |
343 |
arg_args = args |
arg_args = args |
344 |
} |
} |
345 |
| _ -> |
| _ -> |
346 |
let tmpfile = Filename.temp_file "http_" "" in |
let tmpfile = Filename.temp_file "http_" "" in |
347 |
if !debug then begin |
if !debug then begin |
348 |
lprintf "WARNING: saving to file %s\n" tmpfile; |
lprintf "WARNING: saving to file %s\n" tmpfile; |
349 |
end; |
end; |
350 |
let oc = open_out tmpfile in |
let oc = open_out tmpfile in |
351 |
let rec iter n empty_line = |
let rec iter n empty_line = |
352 |
if n > !upload_limit then |
if n > !upload_limit then |
353 |
failwith "File too big for upload" |
failwith "File too big for upload" |
354 |
else |
else |
355 |
let line = Stream_in.input_line ic in |
let line = Stream_in.input_line ic in |
356 |
if line = boundary || line = boundary2 || |
if line = boundary || line = boundary2 || |
357 |
line = boundary3 || line = boundary4 |
line = boundary3 || line = boundary4 |
358 |
|| ( |
|| ( |
359 |
(line = end_boundary || line = end_boundary2 |
(line = end_boundary || line = end_boundary2 |
360 |
|| line = end_boundary3 || line = end_boundary4 |
|| line = end_boundary3 || line = end_boundary4 |
361 |
) |
) |
362 |
&& (end_boundary_found := true; true) |
&& (end_boundary_found := true; true) |
363 |
) |
) |
364 |
then |
then |
373 |
if n > 0 && empty_line = "" then output_char oc '\n'; |
if n > 0 && empty_line = "" then output_char oc '\n'; |
374 |
output_string oc line; |
output_string oc line; |
375 |
iter (len + 1 + n) empty_line |
iter (len + 1 + n) empty_line |
376 |
end |
end |
377 |
in |
in |
378 |
iter 0 ""; |
iter 0 ""; |
379 |
Finalizer.add finalizers tmpfile (fun _ -> |
Finalizer.add finalizers tmpfile (fun _ -> |
383 |
arg_headers = lines; |
arg_headers = lines; |
384 |
arg_args = args |
arg_args = args |
385 |
} |
} |
386 |
|
|
387 |
end |
end |
388 |
| (name, (_,value, args)) :: lines -> |
| (name, (_,value, args)) :: lines -> |
389 |
if !debug then begin |
if !debug then begin |
393 |
lprint_nl ""; |
lprint_nl ""; |
394 |
end; |
end; |
395 |
raise Exit |
raise Exit |
396 |
| [] -> |
| [] -> |
397 |
if !debug then lprintf_nl "NO LINES"; |
if !debug then lprintf_nl "NO LINES"; |
398 |
raise Exit |
raise Exit |
399 |
in |
in |
400 |
if !end_boundary_found then field :: previous else |
if !end_boundary_found then field :: previous else |
401 |
get_one_part (field :: previous) |
get_one_part (field :: previous) |
402 |
in |
in |
403 |
let form_args = List.rev (find_first ()) in |
let form_args = List.rev (find_first ()) in |
404 |
{ request with form_args = form_args } |
{ request with form_args = form_args } |
405 |
*) |
*) |
406 |
|
|
413 |
let req = { req with get_url = { req.get_url |
let req = { req with get_url = { req.get_url |
414 |
with Url.args = args }} in |
with Url.args = args }} in |
415 |
f b req |
f b req |
416 |
|
|
417 |
let check_len f len b pos2 = |
let check_len f len b pos2 = |
418 |
lprintf_nl "check_len: len %d rlen %d" len b.rlen; |
lprintf_nl "check_len: len %d rlen %d" len b.rlen; |
419 |
if b.rlen >= len then f b |
if b.rlen >= len then f b |
426 |
else |
else |
427 |
let post_reader = Select.buf_reader buf (check_len (parse_post_args f len request) len ) in |
let post_reader = Select.buf_reader buf (check_len (parse_post_args f len request) len ) in |
428 |
buf.fd_task.Select.reader <- post_reader |
buf.fd_task.Select.reader <- post_reader |
429 |
|
|
430 |
(* |
(* |
431 |
if request.request = "POST" then |
if request.request = "POST" then |
432 |
let value = request.options.content_type in |
let value = request.options.content_type in |
442 |
if nleft > 0 then |
if nleft > 0 then |
443 |
let nread = Stream_in.input ic s 0 (min nleft 1000) in |
let nread = Stream_in.input ic s 0 (min nleft 1000) in |
444 |
Buffer.add_substring buf s 0 nread; |
Buffer.add_substring buf s 0 nread; |
445 |
if nread = nleft then Buffer.contents buf |
if nread = nleft then Buffer.contents buf |
446 |
else |
else |
447 |
if nread = 0 then failwith "Connection close while reading" |
if nread = 0 then failwith "Connection close while reading" |
448 |
else |
else |
449 |
iter (nleft - nread) |
iter (nleft - nread) |
450 |
else Buffer.contents buf |
else Buffer.contents buf |
451 |
in |
in |
452 |
|
|
453 |
let doc = iter request.options.content_length in |
let doc = iter request.options.content_length in |
454 |
*) |
*) |
455 |
let args = Url.cut_args doc in |
let args = Url.cut_args doc in |
460 |
|
|
461 |
let connection_wrapper = ref |
let connection_wrapper = ref |
462 |
(fun f t x -> f t x) |
(fun f t x -> f t x) |
463 |
|
|
464 |
let fd t = t.fd |
let fd t = t.fd |
465 |
exception ForbiddenAddr |
exception ForbiddenAddr |
466 |
|
|
467 |
|
|
468 |
let stream_out_string buf s = |
let stream_out_string buf s = |
469 |
Select.write buf.fd_task s 0 (String.length s) |
Select.write buf.fd_task s 0 (String.length s) |
470 |
|
|
473 |
"Server: http_server (ocaml)\n" ^ |
"Server: http_server (ocaml)\n" ^ |
474 |
"Connection: close\n" ^ |
"Connection: close\n" ^ |
475 |
"Content-Type: text/html; charset=iso-8859-1\n" |
"Content-Type: text/html; charset=iso-8859-1\n" |
476 |
|
|
477 |
let error_404 oc page = |
let error_404 oc page = |
478 |
stream_out_string oc head_404_error; |
stream_out_string oc head_404_error; |
479 |
stream_out_string oc "\n"; |
stream_out_string oc "\n"; |
481 |
|
|
482 |
let head_404_simple_msg = |
let head_404_simple_msg = |
483 |
head_404_error ^ "\n<html><body>erreur 404</body></html>" |
head_404_error ^ "\n<html><body>erreur 404</body></html>" |
484 |
|
|
485 |
let simple_error_404 oc = |
let simple_error_404 oc = |
486 |
error_404 oc |
error_404 oc |
487 |
"<html><body>erreur 404</body></html>" |
"<html><body>erreur 404</body></html>" |
488 |
|
|
489 |
let head_200_html_page = |
let head_200_html_page = |
490 |
"HTTP/1.0 200 OK\n" ^ |
"HTTP/1.0 200 OK\n" ^ |
491 |
"Server: http_server (ocaml)\n" ^ |
"Server: http_server (ocaml)\n" ^ |
492 |
"Connection: close\n" ^ |
"Connection: close\n" ^ |
493 |
"Content-Type: text/html; charset=iso-8859-1\n" |
"Content-Type: text/html; charset=iso-8859-1\n" |
494 |
|
|
495 |
let output_page oc page = |
let output_page oc page = |
496 |
stream_out_string oc head_200_html_page; |
stream_out_string oc head_200_html_page; |
497 |
stream_out_string oc "\n"; |
stream_out_string oc "\n"; |
498 |
stream_out_string oc page; |
stream_out_string oc page; |
499 |
at_write_end oc.fd_task shutdown |
at_write_end oc.fd_task shutdown |
500 |
|
|
501 |
|
|
502 |
let print_request oc request = |
let print_request oc request = |
503 |
error_404 oc ""; |
error_404 oc ""; |
504 |
stream_out_string oc "<html><body>\n"; |
stream_out_string oc "<html><body>\n"; |
518 |
arg.arg_name arg.arg_value); |
arg.arg_name arg.arg_value); |
519 |
List.iter (fun (name, (value,_,_)) -> |
List.iter (fun (name, (value,_,_)) -> |
520 |
stream_out_string oc (Printf.sprintf "ARG HEADER: [%s]=[%s]<br>\n" |
stream_out_string oc (Printf.sprintf "ARG HEADER: [%s]=[%s]<br>\n" |
521 |
name value)) arg.arg_headers; |
name value)) arg.arg_headers; |
522 |
) request.form_args; |
) request.form_args; |
523 |
stream_out_string oc "</html></body>\n"; |
stream_out_string oc "</html></body>\n"; |
524 |
at_write_end oc.fd_task shutdown |
at_write_end oc.fd_task shutdown |
525 |
|
|
526 |
let html_content = "text/html; charset=iso-8859-1" |
let html_content = "text/html; charset=iso-8859-1" |
527 |
let content_types = [ |
let content_types = [ |
528 |
".htm", html_content; |
".htm", html_content; |
546 |
".ogm", "video/ogm"; |
".ogm", "video/ogm"; |
547 |
".fli", "video/fli"; |
".fli", "video/fli"; |
548 |
".flc", "video/fli"; |
".flc", "video/fli"; |
549 |
|
|
550 |
".ps", "application/postscript"; |
".ps", "application/postscript"; |
551 |
".pdf","application/pdf"; |
".pdf","application/pdf"; |
552 |
".txt", "text/plain"; |
".txt", "text/plain"; |
553 |
".gif", "image/gif"; |
".gif", "image/gif"; |
554 |
] |
] |
555 |
|
|
556 |
let content_type_exts = |
let content_type_exts = |
557 |
List.map (fun (a,b) -> (b,a)) content_types |
List.map (fun (a,b) -> (b,a)) content_types |
558 |
|
|
559 |
let content_encodings = [ |
let content_encodings = [ |
560 |
".gz", "x-gzip"; |
".gz", "x-gzip"; |
561 |
".gz", "gzip"; |
".gz", "gzip"; |
564 |
".pgp", "pgp" |
".pgp", "pgp" |
565 |
] |
] |
566 |
|
|
567 |
let content_encoding_exts = |
let content_encoding_exts = |
568 |
List.map (fun (a,b) -> (b,a)) content_encodings |
List.map (fun (a,b) -> (b,a)) content_encodings |
569 |
|
|
570 |
let add_content_type oc file = |
let add_content_type oc file = |
571 |
let exts = Filename2.extensions (String.lowercase file) in |
let exts = Filename2.extensions (String.lowercase file) in |
572 |
(try |
(try |
577 |
let ext = "." ^ ext in |
let ext = "." ^ ext in |
578 |
try |
try |
579 |
let t = List.assoc ext content_types in |
let t = List.assoc ext content_types in |
580 |
stream_out_string oc |
stream_out_string oc |
581 |
(Printf.sprintf "Content-Type: %s\n" t) |
(Printf.sprintf "Content-Type: %s\n" t) |
582 |
with _ -> |
with _ -> |
583 |
(* |
(* |
584 |
lprintf "No content-type for %s" ext; |
lprintf "No content-type for %s" ext; |
585 |
lprint_newline (); |
lprint_newline (); |
602 |
stream_out_string oc |
stream_out_string oc |
603 |
(Printf.sprintf "Content-Encoding: %s\n" |
(Printf.sprintf "Content-Encoding: %s\n" |
604 |
encoding) |
encoding) |
605 |
with _ -> |
with _ -> |
606 |
(* lprintf "No encoding for %s" ext; |
(* lprintf "No encoding for %s" ext; |
607 |
lprint_newline (); |
lprint_newline (); |
608 |
*) |
*) |
611 |
iter exts |
iter exts |
612 |
with _ -> ()) |
with _ -> ()) |
613 |
|
|
614 |
|
|
615 |
let give_doc buf request = |
let give_doc buf request = |
616 |
let t = buf.fd_task.info in |
let t = buf.fd_task.info in |
617 |
let file = request.get_url.Url.file in |
let file = request.get_url.Url.file in |
618 |
try |
try |
619 |
if String2.subcontains file ".." then raise Not_found; |
if String2.subcontains file ".." then raise Not_found; |
620 |
let file = |
let file = |
621 |
Filename.concat t.config.base_ref file in |
Filename.concat t.config.base_ref file in |
622 |
if Unix2.is_directory file then |
if Unix2.is_directory file then |
623 |
raise Not_found |
raise Not_found |
624 |
else |
else |
625 |
let ans = File.to_string file in |
let ans = File.to_string file in |
626 |
stream_out_string buf "HTTP/1.0 200 OK\n"; |
stream_out_string buf "HTTP/1.0 200 OK\n"; |
627 |
stream_out_string buf "Server: http_server (ocaml)\n"; |
stream_out_string buf "Server: http_server (ocaml)\n"; |
635 |
stream_out_string buf ans; |
stream_out_string buf ans; |
636 |
at_write_end buf.fd_task shutdown; |
at_write_end buf.fd_task shutdown; |
637 |
with e -> |
with e -> |
638 |
lprintf_nl "[HTTPSRV]: No such file: %s (%s)" file (Printexc2.to_string e); |
lprintf_nl "[HTTPSRV]: No such file: %s (%s)" file (Printexc2.to_string e); |
639 |
simple_error_404 buf; |
simple_error_404 buf; |
640 |
at_write_end buf.fd_task shutdown |
at_write_end buf.fd_task shutdown |
641 |
*) |
*) |
642 |
|
|
643 |
let need_auth r name = |
let need_auth r name = |
644 |
r.reply_head <- "401 Unauthorized"; |
r.reply_head <- "401 Unauthorized"; |
645 |
r.reply_headers <- [ |
r.reply_headers <- [ |
646 |
"Connection", "close"; |
"Connection", "close"; |
647 |
"WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" name |
"WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" name |
648 |
] |
] |
649 |
|
|
650 |
(* |
(* |
651 |
let simple_give_auth psread pswrite request = |
let simple_give_auth psread pswrite request = |
652 |
try |
try |
658 |
(lprintf " Access: Read"; lprint_newline (); |
(lprintf " Access: Read"; lprint_newline (); |
659 |
Read_auth) |
Read_auth) |
660 |
else raise Not_found |
else raise Not_found |
661 |
with _ -> |
with _ -> |
662 |
lprintf " Access: Forbidden"; lprint_newline (); |
lprintf " Access: Forbidden"; lprint_newline (); |
663 |
No_auth |
No_auth |
664 |
|
|
665 |
let check_auth auth give_auth handler buf request = |
let check_auth auth give_auth handler buf request = |
666 |
let authorization = give_auth request in |
let authorization = give_auth request in |
667 |
match auth, authorization with |
match auth, authorization with |
668 |
No_auth, _ |
No_auth, _ |
669 |
| Read_auth, (Read_auth | Write_auth) |
| Read_auth, (Read_auth | Write_auth) |
670 |
| Write_auth, Write_auth -> handler buf request |
| Write_auth, Write_auth -> handler buf request |
671 |
| _ -> need_auth buf |
| _ -> need_auth buf |
672 |
|
|
673 |
|
|
674 |
let fork_request handler req = handler req |
let fork_request handler req = handler req |
675 |
|
|
676 |
|
|
677 |
let create config = |
let create config = |
678 |
(* |
(* |
679 |
Sys.set_signal Sys.sigpipe Sys.Signal_ignore; |
Sys.set_signal Sys.sigpipe Sys.Signal_ignore; |
680 |
Sys.set_signal Sys.sigchld (Sys.Signal_handle sigchild_handler); |
Sys.set_signal Sys.sigchld (Sys.Signal_handle sigchild_handler); |
685 |
bind fds (Unix.ADDR_INET (Unix.inet_addr_any, config.port)); |
bind fds (Unix.ADDR_INET (Unix.inet_addr_any, config.port)); |
686 |
listen fds 5; |
listen fds 5; |
687 |
let t = |
let t = |
688 |
{ |
{ |
689 |
config = config; |
config = config; |
690 |
fd = fds; |
fd = fds; |
691 |
regaddrs = Str.regexp config.addrs; |
regaddrs = Str.regexp config.addrs; |
698 |
*) |
*) |
699 |
|
|
700 |
open TcpBufferedSocket |
open TcpBufferedSocket |
701 |
|
|
702 |
let manage config sock head = |
let manage config sock head = |
703 |
|
|
704 |
let request = parse_head sock head in |
let request = parse_head sock head in |
705 |
let rec iter reqs = |
let rec iter reqs = |
706 |
match reqs with |
match reqs with |
707 |
(file, handler) :: reqs when file = request.get_url.Url.short_file -> |
(file, handler) :: reqs when file = request.get_url.Url.short_file -> |
708 |
handler sock request |
handler sock request |
709 |
| _ :: reqs -> iter reqs |
| _ :: reqs -> iter reqs |
710 |
| [] -> |
| [] -> |
711 |
config.default sock request |
config.default sock request |
712 |
in |
in |
713 |
iter config.requests; |
iter config.requests; |
731 |
TcpBufferedSocket.set_max_output_buffer sock (len + clen); |
TcpBufferedSocket.set_max_output_buffer sock (len + clen); |
732 |
(* lprintf "HTTPSEND: [%s]\n" (String.escaped s); - log commented out *) |
(* lprintf "HTTPSEND: [%s]\n" (String.escaped s); - log commented out *) |
733 |
TcpBufferedSocket.write_string sock s; |
TcpBufferedSocket.write_string sock s; |
734 |
|
|
735 |
if request.request <> "HEAD" then begin |
if request.request <> "HEAD" then begin |
736 |
(* lprintf "HTTPSEND: [%s]\n" (String.escaped c); - log commented out *) |
(* lprintf "HTTPSEND: [%s]\n" (String.escaped c); - log commented out *) |
737 |
TcpBufferedSocket.write_string sock c; |
TcpBufferedSocket.write_string sock c; |
741 |
set_refill sock refill; |
set_refill sock refill; |
742 |
end; |
end; |
743 |
TcpBufferedSocket.close_after_write sock |
TcpBufferedSocket.close_after_write sock |
744 |
|
|
745 |
|
|
746 |
let request_handler config sock nread = |
let request_handler config sock nread = |
747 |
let b = TcpBufferedSocket.buf sock in |
let b = TcpBufferedSocket.buf sock in |
748 |
let end_pos = b.pos + b.len in |
let end_pos = b.pos + b.len in |
749 |
let new_pos = end_pos - nread in |
let new_pos = end_pos - nread in |
750 |
let new_pos = maxi 0 (new_pos - 1) in |
let new_pos = maxi 0 (new_pos - 1) in |
751 |
(* lprintf "received [%s]\n" (String.escaped |
(* lprintf "received [%s]\n" (String.escaped |
752 |
(String.sub b.buf new_pos nread)); - log commented out *) |
(String.sub b.buf new_pos nread)); - log commented out *) |
753 |
let rec iter i = |
let rec iter i = |
754 |
let end_pos = b.pos + b.len in |
let end_pos = b.pos + b.len in |
766 |
let header = String.sub b.buf b.pos len in |
let header = String.sub b.buf b.pos len in |
767 |
buf_used b len; |
buf_used b len; |
768 |
manage config sock header |
manage config sock header |
769 |
else |
else |
770 |
iter (i+1) |
iter (i+1) |
771 |
else |
else |
772 |
iter (i+1) |
iter (i+1) |
776 |
try |
try |
777 |
iter new_pos |
iter new_pos |
778 |
with e -> |
with e -> |
779 |
lprintf "HTTPSERVER: Exception %s in request_handler\n" |
lprintf "[HTTPSRV]: Exception %s in request_handler\n" |
780 |
(Printexc2.to_string e); |
(Printexc2.to_string e); |
781 |
close sock (Closed_for_exception e) |
close sock (Closed_for_exception e) |
782 |
|
|
783 |
let request_closer sock msg = |
let request_closer sock msg = |
784 |
() |
() |
785 |
|
|
786 |
let handler config t event = |
let handler config t event = |
787 |
match event with |
match event with |
788 |
TcpServerSocket.CONNECTION (s, Unix.ADDR_INET(from_ip, from_port)) -> |
TcpServerSocket.CONNECTION (s, Unix.ADDR_INET(from_ip, from_port)) -> |
789 |
(* check here if ip is OK *) |
(* check here if ip is OK *) |
790 |
let from_ip = Ip.of_inet_addr from_ip in |
let from_ip = Ip.of_inet_addr from_ip in |
791 |
if Ip.matches from_ip config.addrs then |
if Ip.matches from_ip config.addrs then |
792 |
let token = create_token unlimited_connection_manager in |
let token = create_token unlimited_connection_manager in |
793 |
let sock = TcpBufferedSocket.create_simple |
let sock = TcpBufferedSocket.create_simple |
794 |
token "http connection" s in |
token "http connection" s in |
795 |
TcpBufferedSocket.prevent_close sock; |
TcpBufferedSocket.prevent_close sock; |
796 |
TcpBufferedSocket.set_reader sock (request_handler config); |
TcpBufferedSocket.set_reader sock (request_handler config); |
803 |
| _ -> () |
| _ -> () |
804 |
|
|
805 |
let create config = |
let create config = |
806 |
let t = TcpServerSocket.create "http server" config.bind_addr |
let t = TcpServerSocket.create "http server" config.bind_addr |
807 |
config.port (handler config) in |
config.port (handler config) in |
808 |
t |
t |
809 |
|
|
810 |
let add_reply_header r header value = |
let add_reply_header r header value = |
811 |
let rec iter headers add = |
let rec iter headers add = |
812 |
match headers with |
match headers with |
813 |
[] -> if add then [header, value] else [] |
[] -> if add then [header, value] else [] |
818 |
(h, v) :: (iter tail true) |
(h, v) :: (iter tail true) |
819 |
in |
in |
820 |
r.reply_headers <- iter r.reply_headers true |
r.reply_headers <- iter r.reply_headers true |
821 |
|
|
822 |
|
|
823 |
let parse_range range = |
let parse_range range = |
824 |
try |
try |
841 |
String.sub range (dash_pos+1) (slash_pos - dash_pos - 1)) |
String.sub range (dash_pos+1) (slash_pos - dash_pos - 1)) |
842 |
in |
in |
843 |
if slash_pos = len then |
if slash_pos = len then |
844 |
x, Some y, None (* "bytes=x-y" *) |
x, Some y, None (* "bytes=x-y" *) |
845 |
else |
else |
846 |
if slash_pos = star_pos - 1 then |
if slash_pos = star_pos - 1 then |
847 |
x, Some y, None (* "bytes x-y/*" *) |
x, Some y, None (* "bytes x-y/*" *) |
848 |
else |
else |
849 |
(* bytes x-y/len *) |
(* bytes x-y/len *) |
850 |
|
|
851 |
let z = Int64.of_string ( |
let z = Int64.of_string ( |
852 |
String.sub range (slash_pos+1) (len - slash_pos -1) ) |
String.sub range (slash_pos+1) (len - slash_pos -1) ) |
853 |
in |
in |
854 |
x, Some y, Some z |
x, Some y, Some z |
855 |
with |
with |
856 |
| e -> |
| e -> |
857 |
lprintf_nl "[HTTPSRV]: Exception %s for range [%s]" |
lprintf_nl "[HTTPSRV]: Exception %s for range [%s]" |
858 |
(Printexc2.to_string e) range; |
(Printexc2.to_string e) range; |
862 |
let parse_range range = |
let parse_range range = |
863 |
let x, y, z = parse_range range in |
let x, y, z = parse_range range in |
864 |
lprintf "Range parsed: %Ld-%s/%s" x |
lprintf "Range parsed: %Ld-%s/%s" x |
865 |
(match y with None -> "" | Some y -> Int64.to_string y) |
(match y with None -> "" | Some y -> Int64.to_string y) |
866 |
(match z with None -> "*" | Some y -> Int64.to_string y); |
(match z with None -> "*" | Some y -> Int64.to_string y); |
867 |
x, y, z |
x, y, z |
868 |
*) |
*) |
869 |
|
|
870 |
open Int64ops |
open Int64ops |
871 |
|
|
872 |
(* Range: bytes=31371876- *) |
(* Range: bytes=31371876- *) |
873 |
let request_range r = |
let request_range r = |
874 |
List.iter (fun (h, v1) -> |
List.iter (fun (h, v1) -> |
884 |
x, Some (y ++ Int64.one) |
x, Some (y ++ Int64.one) |
885 |
| x, Some y, None -> |
| x, Some y, None -> |
886 |
x, Some (y ++ Int64.one) |
x, Some (y ++ Int64.one) |
887 |
|
|