(* TODO: Put these functions in some libs *)
+let optval = function | Some v -> v | None -> assert false
+
let is_space c = c = ' ' || c = '\t' || c = '\r' || c = '\n'
let rev_string_of_chars cl =
| _ -> 0 (* should never happen if guarded with is_hex *)
let is_ctl_char c =
- (* Note that this considers '\t', '\n' and '\r' as control chars. *)
+ (* Note that this considers '\t', '\n' and '\r' as control chars. *)
let code = Char.code c in
code < 32 || code > 127
(match c with
| '\r' -> s.cursor <- Header_CR
| '\n' -> s.cursor <- Done
- | _ -> s.cursor <- In_field_name [ c ]
+ | _ -> s.cursor <- In_field_name [ c ]
)
| Header_CR ->
if c = '\n' then s.cursor <- Done
| ' ' | '\t' ->
(* compress whitespace *)
let nclist = if starts_with_space clist then clist else c :: clist in
- s.cursor <- In_field_value (name, nclist)
+ s.cursor <- In_field_value (name, nclist)
| _ -> s.cursor <- In_field_value (name, c :: clist)
)
| In_field_value_CR (name, clist) ->
| In_field_value_LF (name, clist) ->
(match c with
| ' ' | '\t' ->
- (* header has line-wrapped; compress whitespace *)
+ (* header has line-wrapped; compress whitespace *)
let nclist = if starts_with_space clist then clist else c :: clist in
- s.cursor <- In_field_value (name, nclist)
+ s.cursor <- In_field_value (name, nclist)
| _ ->
(* end-of-header line; strip trailing whitespace if any *)
- s.headers <- (add_header name
+ s.headers <- (add_header name
(rev_string_of_chars (strip_leading_spaces clist))
s.headers);
(match c with
type cursor =
| Start
| In_method of char list
- | In_method_SP
- | In_method_CR
+ | Method_SP
| In_uri of char list
| Uri_SP
| Uri_CR
| Start -> "Start"
| In_method cl ->
Printf.sprintf "In-method \"%s\"" (rev_string_of_chars cl)
- | In_method_SP -> "In-method-SP"
- | In_method_CR -> "In-method-CR"
+ | Method_SP -> "Method-SP"
| In_uri cl ->
Printf.sprintf "In-uri \"%s\"" (rev_string_of_chars cl)
| Uri_CR -> "Uri-CR"
type state =
{
mutable cursor: cursor;
- mutable meth: meth option;
- mutable uri: string option;
- mutable version: version option;
- mutable headers: header_fields;
+ mutable s_meth: meth option;
+ mutable s_uri: string option;
+ mutable s_version: version option;
+ mutable s_headers: header_fields;
}
type error =
| Unsupported_version of string
+ | Incomplete_request_line
| Parse_error of cursor * char
| Internal_error of string
let string_of_error = function
| Unsupported_version s ->
Printf.sprintf "Unsupported version in request: \"%s\"" s
+ | Incomplete_request_line ->
+ Printf.sprintf "Incomplete request line"
| Parse_error (cursor, c) ->
Printf.sprintf "Request parse error in state %s at char '%C'"
(string_of_cursor cursor) c
let init_state () =
{
cursor = Start;
- meth = None;
- uri = None;
- version = Some HTTP09;
- headers = [];
+ s_meth = None;
+ s_uri = None;
+ s_version = Some HTTP09;
+ s_headers = [];
}
let is_done s = s.cursor = Done
+ (* From http://tools.ietf.org/html/rfc1945#section-4:
+ Simple-Request = "GET" SP Request-URI CRLF ; HTTP/0.9
+ Request-Line = Method SP Request-URI SP HTTP-Version CRLF ; HTTP/{1.0,1.1}
+ *)
+
let parse_char s c =
let raise_bad_char () = raise_error (Parse_error (s.cursor, c)) in
match s.cursor with
else if not (is_space c) then raise_bad_char ()
| In_method cl ->
(match c with
- | c when is_space c ->
+ | '\r' | '\n' -> raise_error Incomplete_request_line
+ | ' ' | '\t' ->
let meth = match rev_string_of_chars cl with
| "GET" -> Get
| "PUT" -> Put
| "OPTIONS" -> Options
| m -> Extension m
in
- s.meth <- Some meth;
- (match c with
- | '\r' -> s.cursor <- In_method_CR
- | '\n' -> s.cursor <- Done (* HTTP 0.9 *)
- | _ -> s.cursor <- In_method_SP
- )
+ s.s_meth <- Some meth;
+ s.cursor <- Method_SP
| _ ->
s.cursor <- In_method (c :: cl)
)
- | In_method_CR ->
- if c = '\n' then s.cursor <- Done (* HTTP 0.9 *)
- else raise_bad_char ()
- | In_method_SP ->
+ | Method_SP ->
(match c with
- | '\r' | '\n' -> s.cursor <- Done (* HTTP 0.9 *)
+ | '\r' | '\n' -> raise_error Incomplete_request_line
| ' ' | '\t' -> ()
| _ -> s.cursor <- In_uri [ c ]
)
| In_uri cl ->
if is_space c then begin
- s.uri <- Some (rev_string_of_chars cl);
+ s.s_uri <- Some (rev_string_of_chars cl);
(match c with
| ' ' | '\t' -> s.cursor <- Uri_SP
| '\r' -> s.cursor <- Uri_CR
| In_version cl ->
if is_space c then begin
(match rev_string_of_chars cl with
- | "HTTP/1.0" -> s.version <- Some HTTP10
- | "HTTP/1.1" -> s.version <- Some HTTP11
+ | "HTTP/1.0" -> s.s_version <- Some HTTP10
+ | "HTTP/1.1" -> s.s_version <- Some HTTP11
| v -> raise_error (Unsupported_version v)
);
(match c with
| In_headers hs ->
Headers.parse_char hs c;
if Headers.is_done hs then begin
- s.headers <- List.rev hs.Headers.headers;
+ s.s_headers <- List.rev hs.Headers.headers;
s.cursor <- Done
end
| Done -> raise_error (Internal_error "parse called on finished request!")
+
+ type t =
+ {
+ version: version;
+ meth: meth;
+ uri: string;
+ headers: header_fields;
+ }
+
+ type parse_result =
+ | Result of t
+ | Parse_incomplete of state
+
+ let get_parse_result state =
+ match state.cursor with
+ | Done -> Some { version = optval state.s_version;
+ meth = optval state.s_meth;
+ uri = optval state.s_uri;
+ headers = state.s_headers
+ }
+ | _ -> None
+
+ let parse state str =
+ let len = String.length str in
+ let i = ref 0 in
+ while get_parse_result state = None && !i < len do
+ parse_char state str.[!i];
+ incr i
+ done;
+ match get_parse_result state with
+ | Some v -> Result v
+ | None -> Parse_incomplete state
end
type state =
{
mutable cursor: cursor;
- mutable version: version option;
- mutable status_code: int option;
- mutable reason_phrase: string option;
- mutable headers: header_fields;
+ mutable s_version: version option;
+ mutable s_status_code: int option;
+ mutable s_reason_phrase: string option;
+ mutable s_headers: header_fields;
}
type error =
let init_state () =
{
cursor = Start;
- version = None;
- status_code = None;
- reason_phrase = None;
- headers = [];
+ s_version = None;
+ s_status_code = None;
+ s_reason_phrase = None;
+ s_headers = [];
}
let is_done s = s.cursor = Done
+ (* From http://tools.ietf.org/html/rfc1945#section-4:
+ Simple-Response = [ Entity-Body ] ; HTTP/0.9
+ Status-Line = HTTP-Version SP Status-Code SP Reason-Phrase CRLF ; HTTP/{1.0,1.1}
+
+ So, we can only be parsing a full status line.
+ *)
+
let parse_char s c =
let raise_bad_char () = raise_error (Parse_error (s.cursor, c)) in
match s.cursor with
(match c with
| ' ' | '\t' ->
(match rev_string_of_chars cl with
- | "HTTP/1.0" -> s.version <- Some HTTP10
- | "HTTP/1.1" -> s.version <- Some HTTP11
+ | "HTTP/1.0" -> s.s_version <- Some HTTP10
+ | "HTTP/1.1" -> s.s_version <- Some HTTP11
| v -> raise_error (Unsupported_version v)
);
s.cursor <- Version_SP
let nsc = 10 * sc + (digit_value c) in
(match c with
| ' ' | '\t' ->
- s.status_code <- Some nsc;
+ s.s_status_code <- Some nsc;
s.cursor <- Status_code_SP
| '\r' ->
- s.status_code <- Some nsc;
+ s.s_status_code <- Some nsc;
s.cursor <- Resp_line_CR
| '\n' ->
- s.status_code <- Some nsc;
+ s.s_status_code <- Some nsc;
s.cursor <- In_headers (Headers.init_state ())
| _ when is_digit c ->
if nd >= 3 then raise_error (Unsupported_status_code nsc)
(match c with
| ' ' | '\t' -> ()
| '\r' | '\n' ->
- s.reason_phrase <- Some (rev_string_of_chars clist);
+ s.s_reason_phrase <- Some (rev_string_of_chars clist);
s.cursor <- (if c = '\r'
then Resp_line_CR
else In_headers (Headers.init_state ()))
| In_headers hs ->
Headers.parse_char hs c;
if Headers.is_done hs then begin
- s.headers <- List.rev hs.Headers.headers;
+ s.s_headers <- List.rev hs.Headers.headers;
s.cursor <- Done
end
| Done -> raise_error (Internal_error "parse called on finished request!")
+
+ type t =
+ {
+ version: version;
+ status_code: int;
+ reason_phrase: string;
+ headers: header_fields;
+ }
+
+ type parse_result =
+ | Result of t
+ | Parse_incomplete of state
+
+ let get_parse_result state =
+ match state.cursor with
+ | Done -> Some { version = optval state.s_version;
+ status_code = optval state.s_status_code;
+ reason_phrase = optval state.s_reason_phrase;
+ headers = state.s_headers
+ }
+ | _ -> None
+
+ let parse state str =
+ let len = String.length str in
+ let i = ref 0 in
+ while get_parse_result state = None && !i < len do
+ parse_char state str.[!i];
+ incr i
+ done;
+ match get_parse_result state with
+ | Some v -> Result v
+ | None -> Parse_incomplete state
end
mutable remaining_length: int64;
max_payload_length: int64;
mutable body: Buffer.t;
- mutable trailers: header_fields
+ mutable headers: header_fields
}
let is_done s = s.cursor = Done
| [] -> (* should never happen *) false
with Not_found -> false
- let get_content_length hdrs =
+ let get_content_length resp =
try
- match lookup_header "Content-Length" hdrs with
+ match lookup_header "Content-Length" resp.Response_header.headers with
| v :: _ -> (try `Some (Int64.of_string v) with Failure _ -> `Error)
| [] -> (* should never happen *) `None
- with Not_found -> `None
+ with Not_found -> if resp.Response_header.version = HTTP09 then `HTTP09 else `None
let content_type_is_multipart_byteranges hdrs =
try
remaining_length = -1L;
max_payload_length = max_payload_length;
body = Buffer.create 512;
- trailers = []
+ headers = []
}
let init_from_response ?(max_payload_length=Int64.of_int (10*1024*1024)) resp =
let hdrs = resp.Response_header.headers in
let chunked = transfer_encoding_uses_chunked hdrs in
- let content_length = get_content_length hdrs in
+ let content_length = get_content_length resp in
let multipart_body = content_type_is_multipart_byteranges hdrs in
let default = init_default_state max_payload_length in
match resp.Response_header.status_code, content_length, chunked, multipart_body with
- | Some sc, _, _, _
+ | sc, _, _, _
(* http://tools.ietf.org/html/rfc2616#section-4.4, Item 1. *)
when sc/100 = 1 || sc = 204 || sc = 304 -> No_payload
+ | _, `HTTP09, _, _ -> Payload default (* Connection: close *)
| _, `Some 0L, _, _ -> No_payload
| _, `Some l, _, _ -> Payload { default with
content_length = Length l;
let raise_bad_char () = raise_error (Parse_error (s.cursor, c)) in
match s.cursor with
| In_body ->
+ Buffer.add_char s.body c;
if s.remaining_length > 0L then begin
- Buffer.add_char s.body c;
s.remaining_length <- Int64.pred s.remaining_length;
if s.remaining_length = 0L then s.cursor <- Done
end
-
- | In_trailer hs ->
- Headers.parse_char hs c;
- if Headers.is_done hs then begin
- s.trailers <- List.rev hs.Headers.headers;
- s.cursor <- Done
- end
-
| Start_chunk_length ->
if is_hex c then begin
s.remaining_length <- Int64.of_int (hex_value c);
| Chunk_CR ->
if c = '\n' then s.cursor <- Start_chunk_length
else raise_bad_char ()
+ | In_trailer hs ->
+ Headers.parse_char hs c;
+ if Headers.is_done hs then begin
+ s.headers <- List.rev hs.Headers.headers;
+ s.cursor <- Done
+ end
| Done -> raise_error (Internal_error "parse called on finished request!")
+
+ type t =
+ {
+ content: Buffer.t;
+ trailers: header_fields
+ }
+
+ type parse_result =
+ | Result of t
+ | Parse_incomplete of state
+
+ let get_parse_result state =
+ match state.cursor with
+ | Done -> Some { content = state.body;
+ trailers = state.headers
+ }
+ | _ -> None
+
+ let parse state str =
+ let len = String.length str in
+ let i = ref 0 in
+ while get_parse_result state = None && !i < len do
+ parse_char state str.[!i];
+ incr i
+ done;
+ match get_parse_result state with
+ | Some v -> Result v
+ | None -> Parse_incomplete state
+
+ let connection_closed state =
+ if state.content_length = Connection_close then
+ state.cursor <- Done
end
projects / xenclient / toolstack.git / commitdiff