Skip to content
This repository
tag: v1765
Fetching contributors…

Cannot retrieve contributors at this time

file 177 lines (163 sloc) 6.336 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
(*
Copyright © 2011, 2012 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(*
@author Laurent Le Brun
@author Cédric Soulas
@author Frederic Ye
@author David Rajchenbach-Teller
**)

#<Debugvar:TESTING>
#<Debugvar:HTTP_CLIENT_DEBUG>

open Http_common

let http : NetAddr.protocol = HttpTools.http
let http_version = "HTTP/1.0"

let client_name = Printf.sprintf "Opa-webclient/%s" version

let parse_response str =
  try
    let pos, res = Request.parse_request_full_response str in
    `Success (res, String.sub str pos (String.length str - pos))
  with Trx_runtime.SyntaxError (pos, str) -> `Failure (Printf.sprintf "Http_client: parse response error: %s (pos:%d)" str pos)

exception Timeout

let place_request (sched: Scheduler.t) ~hostname ~port ~path
    ?client_certificate ?verify_params
    ?(secure=false) ~request_kind ?(auth="")
    ?(more_headers=[]) ?(data="")
    ?(client_name=client_name)
    ?(timeout=Time.seconds 36)
    ?err_cont ~success ~failure () =
  let err_cont =
    match err_cont with
    | Some err_cont -> err_cont
    | None -> (fun _ -> failure `Timeout)
  in
  try
  (* check *)
  let has_port =
    String.contains hostname ':'
  in
  let path =
    if path = "" then (
      Logger.warning "[Http_client.get] the Request_URI canNOT be null.";
      "/"
      (* Quote from http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html :
(...)
Note that the absolute path cannot be empty; if none is present in the original URI, it MUST be given as "/"
(...)
*)
    ) else path
  in
  match
    try `Success (Network.inet_addr_of_name hostname) with Network.Unknown_machine s -> `Unknown_machine s
  with
  | (`Unknown_machine _s) as e -> failure e
  | `Success machine ->
      let secure_mode =
        if secure then Network.Secured (client_certificate, verify_params)
        else Network.Unsecured
      in
      let port_spec = Network.make_port_spec ~protocol:http machine port in
      let command = Printf.sprintf "%s %s %s%s%sHost: %s%sUser-Agent: %s%s%s%s%s"
        request_kind
        path
        http_version
        Base.crlf
        (if auth = "" then "" else (Printf.sprintf "Authorization: %s%s" auth Base.crlf))
        (if port = 80 then hostname else Printf.sprintf "%s:%d" hostname port)
        Base.crlf
        client_name
        Base.crlf
        (List.fold_left (
fun acc h -> Printf.sprintf "%s%s%s" acc h Base.crlf
) "" more_headers)
Base.crlf
        data
      in
      let start conn =
        Scheduler.write ~timeout ~err_cont sched conn command (
          fun _ -> Scheduler.read_all ~timeout ~err_cont sched conn (
            fun (_, buf) ->
              #<If:TESTING $minlevel 0>
              Logger.info "[http_client] received\n %s" command;
              #<End>;
              match parse_response (FBuffer.contents buf) with
              | `Success (((_, status), header), body) ->
                  begin
                    match Requestdef.ResponseHeader.get_string `Content_Length header with
                    | Some s ->
                        begin
                          let len = String.length body in
                          match try Some (int_of_string s == len) with Failure _ -> None
                          with
                          | Some true -> success (status, header, body)
                          | Some false ->
                              if (len = 0) && ("HEAD" = request_kind) then
                                success (status, header, body)
                              else
                                failure (`Cannot_parse_response (Printf.sprintf "(incorrect size %s, expected %d)" s (String.length body)))
                          | None -> failure (`Cannot_parse_response (Printf.sprintf "(invalid size %S, expected an integer)" s))
                        end
                    | _ -> success (status, header, body)
                  end
              | `Failure s -> failure (`Cannot_parse_response s)
          )
        )
      in
      #<If:TESTING $minlevel 0>
        Printf.printf "%s\n" command;
      #<End>;
      #<If:HTTP_CLIENT_DEBUG>
      Logger.info "[http_client] %s" command;
      #<End>;
      if has_port then
        Logger.warning "[Http_client] hostname contains ':' but it shouldn't, please check";
      Network.connect sched port_spec secure_mode ~err_cont start
  with
  | exn -> err_cont exn

let default_failure = function
  | `Unknown_machine m -> Logger.error "Unknown machine %s" m
  | `Cannot_parse_response s -> Logger.error "Cannot parse response %s" s
  | `Timeout -> Logger.error "Timeout exceeded"

let get (sched: Scheduler.t) hostname port path
    ?client_certificate ?verify_params
    ?(secure=false) ?(auth="")
    ?(more_headers=[]) ?err_cont ?(failure=default_failure) cont =
  place_request sched ~hostname ~port ~path
    ~request_kind:"GET"
    ?client_certificate ?verify_params
    ~secure ~auth
    ~more_headers
    ~client_name:client_name
    ?err_cont
    ~success:(fun (_, x, y) -> cont (x, y))
    ?failure
    ()

let post (sched: Scheduler.t) hostname port path
    ?client_certificate ?verify_params
    ?(secure=false) ?(auth="") mime_type
    ?(length=(-1)) ?err_cont ?(failure=default_failure) data cont =
  let length = if length = (-1) then String.length data else length in
  let more_headers = [
    Printf.sprintf "Content-Length: %d" length;
    Printf.sprintf "Content-Type: %s" mime_type;
  ] in
  place_request sched ~hostname ~port ~path
    ~request_kind:"POST"
    ?client_certificate ?verify_params
    ~secure ~auth
    ~more_headers ~data
    ~client_name:client_name
    ?err_cont
    ~success:(fun (_, x, y) -> cont (x, y))
    ?failure
    ()
Something went wrong with that request. Please try again.