package ldp_curl

  1. Overview
  2. Docs
Library to build LDP applications using Curl

Install

Dune Dependency

Authors

Maintainers

Sources

ocaml-ldp-0.1.0.tar.bz2
md5=a5400f9f16b8140dac263e026515d317
sha512=f6e8410363be8948f5c59704c4c635d398249e8378c0184323fccddac145f7e3c59b90da2b3a0e195478b279ec07a007af49daee1e18a53f2072d0b25c1f6bc3

doc/src/ldp_curl/ldp_curl.ml.html

Source file ldp_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
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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
(*********************************************************************************)
(*                OCaml-LDP                                                      *)
(*                                                                               *)
(*    Copyright (C) 2016-2023 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program 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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

module type P =
  sig
    val dbg : string -> unit Lwt.t
    val cert : string option
    val key : string option
  end

let reader_of_string str counter n =
  let len = String.length str in
  if !counter >= len then
    (
     ""
    )
  else
    if !counter + n < len then
      (
       let s = String.sub str !counter n in
       counter := !counter + n;
       s
      )
    else
      (
       let s = String.sub str !counter (len - !counter) in
       counter := !counter + n ;
       s
      )

module Make (P:P) : Ldp.Http.Requests =
  struct
    let () = Curl.global_init Curl.CURLINIT_GLOBALALL
    (*let () = Curl_lwt.set_debug true*)
    let dbg = P.dbg

    include Ldp.Cookies.Make ()

    module IO = Cohttp_lwt__String_io
    module Response = Cohttp.Response.Make (IO)
    module Body = Cohttp_lwt.Body

    open Lwt.Infix

    (* from cohttp_lwt *)
    let read_response ~closefn ic oc meth =
      Response.read ic >>= begin function
        | `Invalid reason ->
            Lwt.fail (Failure ("Failed to read response: " ^ reason))
        | `Eof -> Lwt.fail (Failure "Client connection was closed")
        | `Ok res -> begin
              let has_body = match meth with
                | `HEAD | `DELETE -> `No
                | _ -> Response.has_body res
              in
              match has_body with
              | `Yes | `Unknown ->
                  let reader = Response.make_body_reader res ic in
                  let stream = Body.create_stream Response.read_body_chunk reader in
                  Lwt.async (fun () -> Lwt_stream.closed stream >|= closefn);
                  let gcfn st = closefn () in
                  Gc.finalise gcfn stream;
                  let body = Body.of_stream stream in
                  Lwt.return (res, body)
              | `No -> closefn (); Lwt.return (res, `Empty)
            end
      end
        |> fun t ->
        Lwt.on_cancel t closefn;
      Lwt.on_failure t (fun _exn -> closefn ());
      t

    let rec perform conn meth =
      let%lwt () = P.dbg
         (Printf.sprintf "%s %s" (Cohttp.Code.string_of_method meth)
          (Curl.get_effectiveurl conn))
      in
      let b = Buffer.create 256 in
      Curl.set_writefunction conn (fun s -> Buffer.add_string b s; String.length s);
      let%lwt curl_code = Curl_lwt.perform conn in
      let str = Buffer.contents b in
      let code = Curl.get_responsecode conn in
      match curl_code, code with
      | Curl.CURLE_OK, 301
      | Curl.CURLE_OK, 302 ->
          begin
            let%lwt(resp, _) = read_response
              ~closefn: (fun () -> Curl.cleanup conn)
                (Cohttp__String_io.open_in str)
                ()
                meth
            in
            let url = Curl.get_redirecturl conn in
            Curl.set_url conn url ;
            perform conn meth
          end
      | _ -> Lwt.return (curl_code, str)

    let call ?body ?headers meth iri =
      let headers =
        match headers with
          None -> Cohttp.Header.init ()
        | Some h -> h
      in
      (* set empty Expect field:
        http://www.iandennismiller.com/posts/curl-http1-1-100-continue-and-multipartform-data-post.html
      *)
      let headers = Cohttp.Header.add headers "Expect" "" in
      let headers =
        match cookies_by_iri iri with
            [] -> headers
          | cookies ->
            (*List.iter
              (fun (k, v) -> prerr_endline (Printf.sprintf "setting cookie: %s => %s" k v))
              cookies;*)
            let (k, v) = Cohttp.Cookie.Cookie_hdr.serialize cookies in
            Cohttp.Header.add headers k v
      in
      let conn = Curl.init () in
      Curl.set_header conn true ;
      Curl.set_url conn (Iri.to_uri iri) ;

      Curl.set_sslverifypeer conn true;
      Curl.set_sslverifyhost conn Curl.SSLVERIFYHOST_HOSTNAME;

      begin
        match P.cert, P.key with
          Some cert, Some key ->
            Curl.set_sslcert conn cert ;
            Curl.set_sslkey conn key
        | _ ->
            ()
      end;
      (* uncomment this not to verify host *)
            Curl.set_sslverifypeer conn false;
            Curl.set_sslverifyhost conn Curl.SSLVERIFYHOST_NONE;

      begin
        match String.uppercase_ascii (Cohttp.Code.string_of_method meth) with
        | "PUT" -> Curl.set_put conn true
        | "POST" -> Curl.set_post conn true
        | met -> Curl.set_customrequest conn met
      end;
      let%lwt () =
        match body with
          None -> Lwt.return_unit
        | Some b ->
            let%lwt str = Body.to_string b in
            (*let readfunction = reader_of_string str in
            let%lwt () =
              let b = Buffer.create 256 in
              let rec iter () =
                match readfunction 40 with
                   "" -> Lwt_io.(write_line stderr (Buffer.contents b) )
                 | s -> assert (String.length s <= 40); Buffer.add_string b s ; iter ()
              in
              iter ()
            in*)
            Curl.set_upload conn true;
            let len = String.length str in
            Curl.set_infilesize conn len ;
            let counter = ref 0 in
            let readf = reader_of_string in
            Curl.set_readfunction conn (readf str counter);
            Lwt.return_unit
      in
      let headlines =
        List.map
          (fun (h,v) -> Printf.sprintf "%s: %s" h v)
          (Cohttp.Header.to_list headers)
      in
      Curl.set_httpheader conn headlines ;

      let%lwt (resp, body) =
        match%lwt perform conn meth with
          (Curl.CURLE_OK, str) ->
            begin
              (*prerr_endline str;*)
              let code = Curl.get_responsecode conn in
              match code / 100 with
                2 ->
                  read_response
                    ~closefn: (fun () -> Curl.cleanup conn)
                    (Cohttp__String_io.open_in str)
                    ()
                    meth
              | _ ->
                  Curl.cleanup conn ;
                  Ldp.Types.(fail (Request_error (iri, string_of_int code)))
            end
        | (code, _) ->
            Curl.cleanup conn ;
            Ldp.Types.(fail (Request_error (iri, Curl.strerror code)))
      in
      let () =
        let cookies = Cohttp.Cookie.Set_cookie_hdr.extract resp.Cohttp.Response.headers in
        match cookies with
        | [] -> ()
        | _ ->
            remove_expired_cookies () ;
            List.iter (add_cookie iri) (List.map snd cookies) ;
      in
      Lwt.return (resp, body)
  end

let make ?cache ?cert ~dbg () =
  let (cert,privkey) =
    match cert with
      Some (cert,key) -> (Some cert, Some key)
    | None -> (None, None)
  in
  let module P =
  struct
    let dbg = dbg
    let cert = cert
    let key = privkey
  end
  in
  let%lwt cache =
    match cache with
      None -> Lwt.return (module Ldp.Http.No_cache : Ldp.Http.Cache)
    | Some dir -> Ldp.Cache.of_dir dir
  in
  let module C = (val cache: Ldp.Http.Cache) in
  let module H = Ldp.Http.Cached_http (C) (Make(P)) in
  Lwt.return (module H : Ldp.Http.Http)
OCaml

Innovation. Community. Security.