From 94990e9453a74c28088c1d73722f7a93d6d5deba Mon Sep 17 00:00:00 2001
From: joris <joris.giovannangeli@ahrefs.com>
Date: Fri, 15 Apr 2016 17:04:39 +0800
Subject: [PATCH] Curl.Multi: add setopt

---
 curl-helper.c | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 curl.ml       |  7 ++++++
 curl.mli      |  9 +++++++
 curl_lwt.ml   |  4 ++++
 curl_lwt.mli  |  5 ++++
 5 files changed, 102 insertions(+)

diff --git a/curl-helper.c b/curl-helper.c
index 8d93441..ddb2fdc 100644
--- a/curl-helper.c
+++ b/curl-helper.c
@@ -4307,3 +4307,80 @@ CAMLprim value caml_curl_multi_timeout(value v_multi)
 
   CAMLreturn(Val_long(ms));
 }
+
+#define SETMOPT_VAL_(func_name, curl_option, conv_val) \
+static void func_name(CURLM *handle, value option) \
+{ \
+    CAMLparam1(option); \
+    CURLcode result = CURLM_OK; \
+\
+    result = curl_multi_setopt(handle, curl_option, conv_val(option)); \
+\
+    check_mcode(result); \
+\
+    CAMLreturn0; \
+}
+
+#define SETMOPT_VAL(name, conv) SETMOPT_VAL_(handle_multi_##name, CURLMOPT_##name, conv)
+#define SETMOPT_BOOL(name) SETMOPT_VAL(name, Bool_val)
+#define SETMOPT_LONG(name) SETMOPT_VAL(name, Long_val)
+#define SETMOPT_INT64(name) SETMOPT_VAL(name, Int64_val)
+
+SETMOPT_LONG( PIPELINING)
+SETMOPT_LONG( MAXCONNECTS)
+SETMOPT_LONG( MAX_PIPELINE_LENGTH)
+SETMOPT_LONG( MAX_HOST_CONNECTIONS)
+
+typedef struct CURLMOptionMapping CURLMOptionMapping;
+#define OPT(name) { handle_multi_## name, "CURLMOPT_"#name}
+
+struct CURLMOptionMapping
+{
+    void (*optionHandler)(CURLM *, value);
+    char *name;
+};
+
+CURLMOptionMapping implementedMOptionMap[] = {
+  OPT( PIPELINING),
+  OPT( MAXCONNECTS),
+  OPT( MAX_PIPELINE_LENGTH),
+  OPT( MAX_HOST_CONNECTIONS),
+};
+
+CAMLprim value caml_curl_multi_setopt(value v_multi, value option)
+{
+    CAMLparam2(v_multi, option);
+    CAMLlocal1(data);
+    CURLM *handle = Multi_val(v_multi)->handle;
+    CURLMOptionMapping* thisOption = NULL;
+    static value* exception = NULL;
+
+    if (!Is_block(option))
+        failwith("Not a block");
+
+    if (Wosize_val(option) < 1)
+        failwith("Insufficient data in block");
+
+    data = Field(option, 0);
+
+    if (Tag_val(option) < sizeof(implementedMOptionMap)/sizeof(CURLMOptionMapping))
+    {
+      thisOption = &implementedMOptionMap[Tag_val(option)];
+      if (thisOption->optionHandler)
+        thisOption->optionHandler(handle, data);
+      else
+      {
+        if (NULL == exception)
+        {
+          exception = caml_named_value("Curl.NotImplemented");
+          if (NULL == exception) caml_invalid_argument("Curl.NotImplemented");
+        }
+
+        caml_raise_with_string(*exception, thisOption->name);
+      }
+    }
+    else
+      failwith("Invalid CURLMOPT Option");
+
+    CAMLreturn(Val_unit);
+}
diff --git a/curl.ml b/curl.ml
index 684bf4f..f4f8c66 100644
--- a/curl.ml
+++ b/curl.ml
@@ -1301,6 +1301,12 @@ module Multi = struct
 
   type mt
 
+  type curlMultiOption =
+    | CURLMOPT_PIPELINING of int
+    | CURLMOPT_MAXCONNECTS of int
+    | CURLMOPT_MAX_PIPELINE_LENGTH of int
+    | CURLMOPT_MAX_HOST_CONNECTIONS of int
+
   exception Error of string
 
   let () = Callback.register_exception "Curl.Multi.Error" (Error "")
@@ -1329,5 +1335,6 @@ module Multi = struct
 
   external timeout : mt -> int = "caml_curl_multi_timeout"
 
+  external setopt : mt -> curlMultiOption -> unit = "caml_curl_multi_setopt"
 end
 
diff --git a/curl.mli b/curl.mli
index 805dd1b..2369c08 100644
--- a/curl.mli
+++ b/curl.mli
@@ -877,6 +877,12 @@ module Multi : sig
   (** type of Curl multi stack *)
   type mt
 
+  type curlMultiOption =
+    | CURLMOPT_PIPELINING of int
+    | CURLMOPT_MAXCONNECTS of int
+    | CURLMOPT_MAX_PIPELINE_LENGTH of int
+    | CURLMOPT_MAX_HOST_CONNECTIONS of int
+
   (** exception raised on internal errors *)
   exception Error of string
 
@@ -953,4 +959,7 @@ module Multi : sig
   *)
   external timeout : mt -> int = "caml_curl_multi_timeout"
 
+  (** @raise NotImplemented for not implemented option *)
+  val setopt : mt -> curlMultiOption -> unit
+
 end
diff --git a/curl_lwt.ml b/curl_lwt.ml
index 93c909f..44c9fba 100644
--- a/curl_lwt.ml
+++ b/curl_lwt.ml
@@ -90,6 +90,10 @@ let create () =
 (* lwt may not run in parallel so one global is OK'ish *)
 let global = lazy (create ())
 
+let setopt opt =
+  let t = Lazy.force global in
+  M.setopt t.mt opt
+
 let perform h =
   let t = Lazy.force global in
   let (waiter,wakener) = Lwt.wait () in
diff --git a/curl_lwt.mli b/curl_lwt.mli
index 6eb4ff7..7e8a626 100644
--- a/curl_lwt.mli
+++ b/curl_lwt.mli
@@ -8,3 +8,8 @@ val set_debug : bool -> unit
   @return transfer result code
 *)
 val perform : Curl.t -> Curl.curlCode Lwt.t
+
+(**
+   set option on global multi_handle
+*)
+val setopt : Curl.Multi.curlMultiOption -> unit
-- 
2.11.4.GIT