/[mldonkey]/mldonkey/src/utils/net/http_server.ml
ViewVC logotype

Diff of /mldonkey/src/utils/net/http_server.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by spiralvoice, Thu Jul 7 00:25:46 2005 UTC revision 1.15 by spiralvoice, Sun Jul 10 23:19:16 2005 UTC
# Line 22  open BasicSocket Line 22  open BasicSocket
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
# Line 69  let decode64 s = Line 69  let decode64 s =
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
# Line 96  type options = { Line 96  type options = {
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;
# Line 104  type form_arg = { Line 104  type form_arg = {
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;
# Line 117  type request = { Line 117  type request = {
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;
# Line 135  and config = { Line 135  and config = {
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;
# Line 170  let rec parse_headers lines headers = Line 170  let rec parse_headers lines headers =
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 =
# Line 181  let rec parse_headers lines headers = Line 181  let rec parse_headers lines headers =
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
# Line 203  let split_head s = Line 203  let split_head s =
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
# Line 229  let parse_head sock s = Line 229  let parse_head sock s =
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 }
# Line 253  let parse_head sock s = Line 253  let parse_head sock s =
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;
# Line 267  stream_out = Stream_out.create oc; Line 267  stream_out = Stream_out.create oc;
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;
# Line 285  let convert_nl s = Line 285  let convert_nl s =
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
# Line 302  let complete_multipart_data request ic t Line 302  let complete_multipart_data request ic t
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
# Line 313  let complete_multipart_data request ic t Line 313  let complete_multipart_data request ic t
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                [], [] ->                [], [] ->
# Line 325  let complete_multipart_data request ic t Line 325  let complete_multipart_data request ic t
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);
# Line 342  let complete_multipart_data request ic t Line 342  let complete_multipart_data request ic t
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
# Line 373  let complete_multipart_data request ic t Line 373  let complete_multipart_data request ic t
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 _ ->
# Line 383  let complete_multipart_data request ic t Line 383  let complete_multipart_data request ic t
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
# Line 393  let complete_multipart_data request ic t Line 393  let complete_multipart_data request ic t
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    
# Line 413  let parse_post_args f len req b = Line 413  let parse_post_args f len req b =
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
# Line 426  let complete_post_request ( f : handler Line 426  let complete_post_request ( f : handler
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
# Line 442  let complete_post_request ( f : handler Line 442  let complete_post_request ( f : handler
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
# Line 460  let doc = iter request.options.content_l Line 460  let doc = iter request.options.content_l
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    
# Line 473  let head_404_error = Line 473  let head_404_error =
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";
# Line 481  let error_404 oc page = Line 481  let error_404 oc page =
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";
# Line 518  let print_request oc request = Line 518  let print_request oc request =
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;
# Line 546  let content_types = [ Line 546  let content_types = [
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";
# Line 564  let content_encodings = [ Line 564  let content_encodings = [
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
# Line 577  let add_content_type oc file = Line 577  let add_content_type oc file =
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 ();
# Line 602  let add_content_encoding oc file = Line 602  let add_content_encoding oc file =
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    *)    *)
# Line 611  lprint_newline (); Line 611  lprint_newline ();
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";
# Line 635  let give_doc buf request = Line 635  let give_doc buf request =
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
# Line 658  let simple_give_auth psread pswrite requ Line 658  let simple_give_auth psread pswrite requ
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);
# Line 685  Sys.set_signal Sys.sigchld (Sys.Signal_h Line 685  Sys.set_signal Sys.sigchld (Sys.Signal_h
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;
# Line 698  Sys.set_signal Sys.sigchld (Sys.Signal_h Line 698  Sys.set_signal Sys.sigchld (Sys.Signal_h
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;
# Line 731  let manage config sock head = Line 731  let manage config sock head =
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;
# Line 741  let manage config sock head = Line 741  let manage config sock head =
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
# Line 766  let request_handler config sock nread = Line 766  let request_handler config sock nread =
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)
# Line 776  let request_handler config sock nread = Line 776  let request_handler config sock nread =
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);
# Line 803  let handler config t event = Line 803  let handler config t event =
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 []
# Line 818  let add_reply_header r header value = Line 818  let add_reply_header r header value =
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
# Line 841  let parse_range range = Line 841  let parse_range range =
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;
# Line 862  let parse_range range = Line 862  let parse_range 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) ->
# Line 884  let request_range r = Line 884  let request_range r =
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          

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26