Source file `cohttp_curl.ml`

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
module Sink = struct
  type _ t = String : string t | Discard : unit t

  let string = String
  let discard = Discard
end

module Error = struct
  type t = Curl.curlCode

  let create x = x

  let is_timeout (t : t) =
    match t with Curl.CURLE_OPERATION_TIMEOUTED -> true | _ -> false

  let message t = Curl.strerror t
end

module Source = struct
  type t = Empty | String of string

  let empty = Empty
  let string s = String s

  let to_curl_callback t =
    match t with
    | Empty -> fun _ -> ""
    | String s ->
        let len = String.length s in
        let pos = ref 0 in
        fun max_asked ->
          if !pos >= len then ""
          else
            let chunk_len = min (len - !pos) max_asked in
            let res = String.sub s !pos chunk_len in
            pos := !pos + chunk_len;
            res
end

module Request = struct
  type 'a t = {
    curl : Curl.t;
    body : 'a Sink.t;
    mutable body_buffer : Buffer.t option;
  }

  let curl t = t.curl

  let body (type a) (t : a t) : a =
    match t.body with
    | Discard ->
        assert (t.body_buffer = None);
        ()
    | String ->
        let res =
          Buffer.contents
            (match t.body_buffer with None -> assert false | Some s -> s)
        in
        t.body_buffer <- None;
        res

  let create (type a) ?timeout_ms ?headers method_ ~uri ~(input : Source.t)
      ~(output : a Sink.t) ~on_response : a t =
    let response_header_acc = ref [] in
    let response_body = ref None in
    let h = Curl.init () in
    Curl.setopt h (CURLOPT_URL uri);
    Curl.setopt h (CURLOPT_CUSTOMREQUEST (Http.Method.to_string method_));
    let () =
      match headers with
      | None -> ()
      | Some headers ->
          let buf = Buffer.create 128 in
          let headers =
            Http.Header.fold
              (fun key value acc ->
                Buffer.clear buf;
                Buffer.add_string buf key;
                Buffer.add_string buf ": ";
                Buffer.add_string buf value;
                Buffer.contents buf :: acc)
              headers []
            |> List.rev
          in
          Curl.setopt h (CURLOPT_HTTPHEADER headers)
    in
    Curl.setopt h
      (CURLOPT_HEADERFUNCTION
         (let status_code_ready = ref false in
          let response_http_version = ref None in
          fun header ->
            (match !status_code_ready with
            | false ->
                (match String.split_on_char ' ' header with
                | v :: _ ->
                    response_http_version := Some (Http.Version.of_string v)
                | _ -> (* TODO *) invalid_arg "invalid request");
                status_code_ready := true
            | true -> (
                match header with
                | "\r\n" ->
                    let response =
                      let headers =
                        Http.Header.of_list_rev !response_header_acc
                      in
                      response_header_acc := [];
                      let status =
                        match Curl.getinfo h CURLINFO_HTTP_CODE with
                        | CURLINFO_Long l -> Http.Status.of_int l
                        | _ -> assert false
                      in
                      let version =
                        match !response_http_version with
                        | None -> assert false
                        | Some v -> v
                      in
                      Http.Response.make ~version ~status ~headers ()
                    in
                    on_response response
                | _ ->
                    let k, v =
                      match Stringext.cut header ~on:":" with
                      | None -> invalid_arg "proper abort needed"
                      | Some (k, v) -> (String.trim k, String.trim v)
                    in
                    response_header_acc := (k, v) :: !response_header_acc));
            String.length header));
    Curl.setopt h (CURLOPT_READFUNCTION (Source.to_curl_callback input));
    Curl.setopt h
      (CURLOPT_WRITEFUNCTION
         (match output with
         | Discard -> fun s -> String.length s
         | String ->
             let buf = Buffer.create 128 in
             response_body := Some buf;
             fun s ->
               Buffer.add_string buf s;
               String.length s));
    (match timeout_ms with
    | None -> ()
    | Some tms -> Curl.setopt h (CURLOPT_TIMEOUTMS tms));
    { curl = h; body = output; body_buffer = !response_body }
end

module Private = struct
  module Error = Error
  module Sink = Sink
  module Source = Source
  module Request = Request
end