Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 125 lines (101 sloc) 3.95 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 Base
23 open Requestdef
24
25 let version = string_of_int BuildInfos.git_version_counter
26 let crlf = "\r\n"
27 let double_crlf = crlf ^ crlf
28
29 (** {6 Request} *)
30
31 let content_length req =
32 match RequestHeader.get_string `Content_Length req.request_header with
33 | None -> 0
34 | Some v -> int_of_string v
35
36 let string_of_request_line r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
37 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
38
39 let string_of_request r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
40 Printf.sprintf "%s%s%s%s"
fccc685 Initial open-source release
MLstate authored
41 (string_of_request_line r.request_line)
42 (RequestHeader.to_string string_of_request_header r.request_header)
43 crlf
44 (String.sub r.request_message_body 0 (content_length r))
45
46 (* for debug *)
47 let print_request_header req =
48 match req with
49 | Some req -> RequestHeader.iter (
50 fun _k _v ->
51 Logger.log ~color:`cyan "%s" (RequestHeader.to_string string_of_request_header req.request_header)
52 ) req.request_header
53 | _ -> ()
54
55 (** {6 Response} *)
56
57 type status_line =
58 { status_http_version : string
59 ; status : status }
60
61 (* e.g. "HTTP/0.9 302 Found" *)
62 let string_of_status_line sl =
63 let code = status_code sl.status in
64 let phrase = reason_phrase code in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
65 Printf.sprintf "%s %d %s%s" sl.status_http_version code phrase crlf
fccc685 Initial open-source release
MLstate authored
66
67 type res_body =
68 | Result of string
69 | PartialResult of int * string * (int -> res_body)
70 | AuthenticationRequest of res_body
71 (* | AuthenticationRequest of string (\* (string option) * requestDescription * (unit -> ret) *\) *)
72
73 type response =
74 { status_line : status_line
75 ; response_header : ResponseHeader.header
76 ; response_message_body : res_body }
77
78 let reponse_content_length req =
79 match ResponseHeader.get_string `Content_Length req.response_header with
80 | None -> 0
81 | Some v -> int_of_string v
82
83 let rec string_of_body body =
84 match body with
85 | Result s -> s
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
86 | PartialResult (_, s, _) -> Printf.sprintf "partial\n%s" s
fccc685 Initial open-source release
MLstate authored
87 | AuthenticationRequest body ->
88 let s = string_of_body body in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
89 Printf.sprintf "authentification\n%s" s
fccc685 Initial open-source release
MLstate authored
90
91 let string_of_response_header r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
92 Printf.sprintf "%s%s%s"
fccc685 Initial open-source release
MLstate authored
93 (string_of_status_line r.status_line)
94 (ResponseHeader.to_string string_of_response_header r.response_header)
95 crlf
96
97 let string_of_response ?(body_limit=1024) r =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
98 Printf.sprintf "%s%s"
fccc685 Initial open-source release
MLstate authored
99 (string_of_response_header r)
100 (String.sub (string_of_body r.response_message_body) 0 (min (reponse_content_length r) body_limit))
101
102 (* let string_of_response r = *)
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
103 (* Printf.sprintf "%s%s%s%s" *)
fccc685 Initial open-source release
MLstate authored
104 (* (string_of_status_line r.status_line) *)
105 (* (ResponseHeader.to_string string_of_response_header r.response_header) *)
106 (* crlf *)
107 (* (r.response_message_body) *)
108
109 let parse_response response =
110 let str = FBuffer.contents response in
111 try
112 let pos, req = Request.parse_request_response str in
113 req, FBuffer.sub response pos (FBuffer.length response - pos)
114 with
115 | Trx_runtime.SyntaxError (loc, err) ->
116 failwith (Printf.sprintf "Failed to parse http response: %s --> %s" str (Trx_runtime.show_error str loc err))
117
118 let print_response_header resp =
119 ResponseHeader.iter (
120 fun _k _v ->
121 Logger.log ~color:`green "%s" (ResponseHeader.to_string (
122 fun k -> Requestdef.string_of_response_header k) resp.response_header
123 )
124 ) resp.response_header
Something went wrong with that request. Please try again.