Fixes from testing to request parsing.

diff --git a/libs/http/http.ml b/libs/http/http.ml
index baea3ed92efcfc1ba39bf6b15252ed4351a6ee2e..c874258f0d8def2b4aa5a24a2c03429f492f8a4b 100644 (file)
--- a/libs/http/http.ml
+++ b/libs/http/http.ml
@@ -285,6 +285,7 @@ module Request_header = struct
                mutable s_uri: string option;
                mutable s_version: version option;
                mutable s_headers: header_fields;
+               mutable num_bytes_parsed: int
        }
 
        type error =
@@ -315,9 +316,12 @@ module Request_header = struct
                s_uri = None;
                s_version = Some HTTP09;
                s_headers = [];
+               num_bytes_parsed = 0
        }
 
        let is_done s = s.cursor = Done
+       let num_bytes_parsed state =
+               if state.cursor = Start then 0 else state.num_bytes_parsed
 
        (* From http://tools.ietf.org/html/rfc1945#section-4:
           Simple-Request  = "GET" SP Request-URI CRLF                  ; HTTP/0.9
@@ -437,7 +441,8 @@ module Request_header = struct
                let i = ref 0 in
                while get_parse_result state = None && !i < len do
                        parse_char state str.[!i];
-                       incr i
+                       incr i;
+                       state.num_bytes_parsed <- state.num_bytes_parsed + 1
                done;
                match get_parse_result state with
                | Some v -> Result (v, (String.sub str !i (len - !i)))
@@ -479,6 +484,7 @@ module Response_header = struct
                mutable s_status_code: int option;
                mutable s_reason_phrase: string option;
                mutable s_headers: header_fields;
+               mutable num_bytes_parsed: int
        }
 
        type error =
@@ -512,9 +518,12 @@ module Response_header = struct
                s_status_code = None;
                s_reason_phrase = None;
                s_headers = [];
+               num_bytes_parsed = 0
        }
 
        let is_done s = s.cursor = Done
+       let num_bytes_parsed state =
+               if state.cursor = Start then 0 else state.num_bytes_parsed
 
        (* From http://tools.ietf.org/html/rfc1945#section-4:
           Simple-Response = [ Entity-Body ]                               ; HTTP/0.9
@@ -627,7 +636,8 @@ module Response_header = struct
                let i = ref 0 in
                while get_parse_result state = None && !i < len do
                        parse_char state str.[!i];
-                       incr i
+                       incr i;
+                       state.num_bytes_parsed <- state.num_bytes_parsed + 1
                done;
                match get_parse_result state with
                | Some v -> Result (v, (String.sub str !i (len - !i)))
@@ -675,10 +685,13 @@ module Payload = struct
                mutable remaining_length: int64;
                max_payload_length: int64;
                mutable body: Buffer.t;
-               mutable headers: header_fields
+               mutable headers: header_fields;
+               mutable num_bytes_parsed: int64
        }
 
        let is_done s = s.cursor = Done
+       let num_bytes_parsed state = state.num_bytes_parsed
+
 
        type error =
                | Parse_error of cursor * char
@@ -739,7 +752,8 @@ module Payload = struct
                remaining_length = -1L;
                max_payload_length = max_payload_length;
                body = Buffer.create 512;
-               headers = []
+               headers = [];
+               num_bytes_parsed = 0L
        }
 
        let default_max_payload_length = Int64.of_int (10*1024*1024)
@@ -752,24 +766,30 @@ module Payload = struct
                let content_length = get_content_length version hdrs in
                let multipart_body = content_type_is_multipart_byteranges hdrs in
                let default = init_default_state max_payload_length in
+
                match version, meth, content_length, chunked, multipart_body with
                | HTTP09, _, _, _, _
-               | _, Request_header.Connect, _, _, _  (* The caller really needs to handle this specially. *)
-               | _, _, `HTTP09, _, _
-               | _, _, `Some 0L, _, _ -> No_payload
-               | _, _, `Some l, _, _  -> Payload { default with
-                                                     content_length = Length l;
-                                                     remaining_length = l
-                                                 }
-               | _, _, `Error, _, _   -> Error "Invalid Content-Length"
-               | _, _, _, true, _     -> Payload { default with
-                                                     cursor = Start_chunk_length;
-                                                     content_length = Chunked
-                                                 }
-               | _, _, _, _, true     -> Error "multipart/byteranges is currently unsupported"
+               | _, Request_header.Connect, _, _, _  -> No_payload
+
+               (* We need to check Transfer-Encoding before Content-Length.
+                  http://tools.ietf.org/html/rfc2616#section-4.4, Item 3.
+               *)
+               | _, _, _, true, false          -> Payload { default with
+                                                              cursor = Start_chunk_length;
+                                                              content_length = Chunked
+                                                          }
+               | _, _, `HTTP09, _, false
+               | HTTP11, _, `None, _, false    -> No_payload
+               | _, _, `Some 0L, _, false      -> No_payload
+               | _, _, `Some l, _, false       -> Payload { default with
+                                                              content_length = Length l;
+                                                              remaining_length = l
+                                                          }
+               | _, _, `Error, _, false        -> Error "Invalid Content-Length"
+               | _, _, _, _, true              -> Error "multipart/byteranges is unsupported"
 
                (* Default to assuming that the payload is terminated by a Connection:close. *)
-               | _                    -> Payload default
+               | _                             -> Payload default
 
        let init_from_response ?(max_payload_length=default_max_payload_length) resp =
                let version = resp.Response_header.version in
@@ -779,11 +799,20 @@ module Payload = struct
                let content_length = get_content_length version hdrs in
                let multipart_body = content_type_is_multipart_byteranges hdrs in
                let default = init_default_state max_payload_length in
+
                match status_code, content_length, chunked, multipart_body with
                | sc, _, _, _
                        (* http://tools.ietf.org/html/rfc2616#section-4.4, Item 1. *)
                        when sc/100 = 1 || sc = 204 || sc = 304 -> No_payload
 
+               (* We need to check Transfer-Encoding before Content-Length.
+                  http://tools.ietf.org/html/rfc2616#section-4.4, Item 3.
+               *)
+               | _, _, true, _     -> Payload { default with
+                                                  cursor = Start_chunk_length;
+                                                  content_length = Chunked
+                                              }
+
                | _, `HTTP09, _, _  -> Payload default (* Connection: close *)
                | _, `Some 0L, _, _ -> No_payload
                | _, `Some l, _, _  -> Payload { default with
@@ -792,18 +821,13 @@ module Payload = struct
                                               }
                | _, `Error, _, _   -> Error "Invalid Content-Length"
 
-               | _, _, true, _     -> Payload { default with
-                                                  cursor = Start_chunk_length;
-                                                  content_length = Chunked
-                                              }
-
                | _, _, _, true     -> Error "multipart/byteranges is currently unsupported"
 
                (* Default to assuming that the payload is terminated by a Connection:close. *)
                | _ ->                 Payload default
 
        let parse_char s c =
-               Printf.printf "parsing %C in state %s...\n" c (string_of_cursor s.cursor);
+               dbg "parsing %C in state %s...\n" c (string_of_cursor s.cursor);
                let raise_bad_char () = raise_error (Parse_error (s.cursor, c)) in
                match s.cursor with
                | In_body ->
@@ -893,7 +917,8 @@ module Payload = struct
                let i = ref 0 in
                while get_parse_result state = None && !i < len do
                        parse_char state str.[!i];
-                       incr i
+                       incr i;
+                       state.num_bytes_parsed <- Int64.succ state.num_bytes_parsed
                done;
                match get_parse_result state with
                | Some v -> Result (v, (String.sub str !i (len - !i)))

diff --git a/libs/http/http.mli b/libs/http/http.mli
index 5c47ed059c694358c9b9fead73c67b0713c650db..a957d11f31bc327f21c05c03272e058cdaf53840 100644 (file)
--- a/libs/http/http.mli
+++ b/libs/http/http.mli
@@ -24,6 +24,7 @@ module Request_header : sig
 
        type state
        val init_state : unit -> state
+       val num_bytes_parsed : state -> int
 
        type t =
        {
@@ -45,6 +46,7 @@ end
 module Response_header : sig
        type state
        val init_state : unit -> state
+       val num_bytes_parsed : state -> int
 
        type t =
        {
@@ -65,6 +67,8 @@ end
 
 module Payload : sig
        type state
+       val num_bytes_parsed : state -> int64
+
        type payload_type =
                | No_payload
                | Payload of state

diff --git a/libs/http/tests/test_http.ml b/libs/http/tests/test_http.ml
index c75413a62630af765606c38c17dc77d914fbd490..30d4bd723b14614943dacb08e22ce91bce357867 100644 (file)
--- a/libs/http/tests/test_http.ml
+++ b/libs/http/tests/test_http.ml
@@ -19,8 +19,8 @@ let do_requests = ref false
 let do_responses = ref false
 
 let parse_args () =
-       let options = [("-requests", Arg.Set do_requests, " parse request stream");
-                      ("-responses", Arg.Set do_responses, " parse response stream")
+       let options = [("-q", Arg.Set do_requests, " parse request stream");
+                      ("-p", Arg.Set do_responses, " parse response stream")
                      ] in
        let file = ref None in
        let usage = Printf.sprintf "Usage: %s [options] file" Sys.argv.(0) in
@@ -41,7 +41,7 @@ let read_whole_file ic =
        let rec do_read () =
                try
                        let line = input_line ic in
-                       Buffer.add_string buf line;
+                       Buffer.add_string buf line; Buffer.add_char buf '\n';
                        do_read ()
                with End_of_file ->
                        Buffer.contents buf
@@ -82,8 +82,10 @@ let parse_requests inp =
                                        input := ""
                                )
                        );
+                       state := Request_header.init_state ()
                | Request_header.Parse_incomplete st ->
-                       Printf.printf "Request incomplete!\n";
+                       if Request_header.num_bytes_parsed st > 0 then
+                               Printf.printf "Request incomplete!\n";
                        input := "";
                        state := st
        done
@@ -122,9 +124,11 @@ let parse_responses inp =
                                        );
                                        input := ""
                                )
-                       )
+                       );
+                       state := Response_header.init_state ()
                | Response_header.Parse_incomplete st ->
-                       Printf.printf "Response incomplete!\n";
+                       if Response_header.num_bytes_parsed st > 0 then
+                               Printf.printf "Response incomplete!\n";
                        input := "";
                        state := st
        done