Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 124 lines (100 sloc) 3.94 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Laurent Le Brun
20 **)
21
22 open Requestdef
23
24 let version = string_of_int BuildInfos.git_version_counter
25 let crlf = "\r\n"
26 let double_crlf = crlf ^ crlf
27
28 (** {6 Request} *)
29
30 let content_length req =
31 match RequestHeader.get_string `Content_Length req.request_header with
32 | None -> 0
33 | Some v -> int_of_string v
34
35 let string_of_request_line r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
36 Printf.sprintf "%s %s %s%s" (string_of_method r._method) r.request_uri r.http_version crlf
fccc685 Initial open-source release
MLstate authored
37
38 let string_of_request r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
39 Printf.sprintf "%s%s%s%s"
fccc685 Initial open-source release
MLstate authored
40 (string_of_request_line r.request_line)
41 (RequestHeader.to_string string_of_request_header r.request_header)
42 crlf
43 (String.sub r.request_message_body 0 (content_length r))
44
45 (* for debug *)
46 let print_request_header req =
47 match req with
48 | Some req -> RequestHeader.iter (
49 fun _k _v ->
50 Logger.log ~color:`cyan "%s" (RequestHeader.to_string string_of_request_header req.request_header)
51 ) req.request_header
52 | _ -> ()
53
54 (** {6 Response} *)
55
56 type status_line =
57 { status_http_version : string
58 ; status : status }
59
60 (* e.g. "HTTP/0.9 302 Found" *)
61 let string_of_status_line sl =
62 let code = status_code sl.status in
63 let phrase = reason_phrase code in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
64 Printf.sprintf "%s %d %s%s" sl.status_http_version code phrase crlf
fccc685 Initial open-source release
MLstate authored
65
66 type res_body =
67 | Result of string
68 | PartialResult of int * string * (int -> res_body)
69 | AuthenticationRequest of res_body
70 (* | AuthenticationRequest of string (\* (string option) * requestDescription * (unit -> ret) *\) *)
71
72 type response =
73 { status_line : status_line
74 ; response_header : ResponseHeader.header
75 ; response_message_body : res_body }
76
77 let reponse_content_length req =
78 match ResponseHeader.get_string `Content_Length req.response_header with
79 | None -> 0
80 | Some v -> int_of_string v
81
82 let rec string_of_body body =
83 match body with
84 | Result s -> s
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
85 | PartialResult (_, s, _) -> Printf.sprintf "partial\n%s" s
fccc685 Initial open-source release
MLstate authored
86 | AuthenticationRequest body ->
87 let s = string_of_body body in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
88 Printf.sprintf "authentification\n%s" s
fccc685 Initial open-source release
MLstate authored
89
90 let string_of_response_header r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
91 Printf.sprintf "%s%s%s"
fccc685 Initial open-source release
MLstate authored
92 (string_of_status_line r.status_line)
93 (ResponseHeader.to_string string_of_response_header r.response_header)
94 crlf
95
96 let string_of_response ?(body_limit=1024) r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
97 Printf.sprintf "%s%s"
fccc685 Initial open-source release
MLstate authored
98 (string_of_response_header r)
99 (String.sub (string_of_body r.response_message_body) 0 (min (reponse_content_length r) body_limit))
100
101 (* let string_of_response r = *)
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
102 (* Printf.sprintf "%s%s%s%s" *)
fccc685 Initial open-source release
MLstate authored
103 (* (string_of_status_line r.status_line) *)
104 (* (ResponseHeader.to_string string_of_response_header r.response_header) *)
105 (* crlf *)
106 (* (r.response_message_body) *)
107
108 let parse_response response =
109 let str = FBuffer.contents response in
110 try
111 let pos, req = Request.parse_request_response str in
112 req, FBuffer.sub response pos (FBuffer.length response - pos)
113 with
114 | Trx_runtime.SyntaxError (loc, err) ->
115 failwith (Printf.sprintf "Failed to parse http response: %s --> %s" str (Trx_runtime.show_error str loc err))
116
117 let print_response_header resp =
118 ResponseHeader.iter (
119 fun _k _v ->
120 Logger.log ~color:`green "%s" (ResponseHeader.to_string (
121 fun k -> Requestdef.string_of_response_header k) resp.response_header
122 )
123 ) resp.response_header
Something went wrong with that request. Please try again.