alternative READFUNCTION2/WRITEFUNCTION2 with an ability to pause tra…

…nsfer

close #39

curl-helper.c

@@ -827,6 +827,42 @@ static size_t cb_WRITEFUNCTION(char *ptr, size_t size, size_t nmemb, void *data)
     return r;
 }
 
+static size_t cb_WRITEFUNCTION2(char *ptr, size_t size, size_t nmemb, void *data)
+{
+    caml_leave_blocking_section();
+
+    CAMLparam0();
+    CAMLlocal2(result, str);
+    Connection *conn = (Connection *)data;
+
+    checkConnection(conn);
+
+    str = ml_copy_string(ptr,size*nmemb);
+
+    result = caml_callback_exn(Field(conn->ocamlValues, Ocaml_WRITEFUNCTION), str);
+
+    size_t r = 0;
+
+    if (!Is_exception_result(result))
+    {
+      if (Is_block(result)) /* Proceed */
+      {
+        r = size * nmemb;
+      }
+      else
+      {
+        if (0 == Int_val(result)) /* Pause */
+          r = CURL_WRITEFUNC_PAUSE;
+        /* else 1 = Abort */
+      }
+    }
+
+    CAMLdrop;
+
+    caml_enter_blocking_section();
+    return r;
+}
+
 static size_t cb_READFUNCTION(void *ptr, size_t size, size_t nmemb, void *data)
 {
     caml_leave_blocking_section();
@@ -860,6 +896,50 @@ static size_t cb_READFUNCTION(void *ptr, size_t size, size_t nmemb, void *data)
     return r;
 }
 
+static size_t cb_READFUNCTION2(void *ptr, size_t size, size_t nmemb, void *data)
+{
+    caml_leave_blocking_section();
+
+    CAMLparam0();
+    CAMLlocal1(result);
+    Connection *conn = (Connection *)data;
+    size_t length;
+
+    checkConnection(conn);
+
+    result = caml_callback_exn(Field(conn->ocamlValues, Ocaml_READFUNCTION),
+                      Val_int(size*nmemb));
+
+    size_t r = CURL_READFUNC_ABORT;
+
+    if (!Is_exception_result(result))
+    {
+      if (Is_block(result)) /* Proceed */
+      {
+        result = Field(result,0);
+
+        length = caml_string_length(result);
+
+        if (length <= size*nmemb)
+        {
+          memcpy(ptr, String_val(result), length);
+          r = length;
+        }
+      }
+      else
+      {
+        if (0 == Int_val(result)) /* Pause */
+          r = CURL_READFUNC_PAUSE;
+        /* else 1 = Abort */
+      }
+    }
+
+    CAMLdrop;
+
+    caml_enter_blocking_section();
+    return r;
+}
+
 static size_t cb_HEADERFUNCTION(char *ptr, size_t size, size_t nmemb, void *data)
 {
     caml_leave_blocking_section();
@@ -1429,21 +1509,26 @@ value caml_curl_easy_reset(value conn)
  **  curl_easy_setopt helper utility functions
  **/
 
-#define SETOPT_FUNCTION(name) \
-static void handle_##name##FUNCTION(Connection *conn, value option) \
+#define SETOPT_FUNCTION_(name,suffix) \
+static void handle_##name##suffix(Connection *conn, value option) \
 { \
     CAMLparam1(option); \
     CURLcode result = CURLE_OK; \
     Store_field(conn->ocamlValues, Ocaml_##name##FUNCTION, option); \
-    result = curl_easy_setopt(conn->handle, CURLOPT_##name##FUNCTION, cb_##name##FUNCTION); \
+    result = curl_easy_setopt(conn->handle, CURLOPT_##name##FUNCTION, cb_##name##suffix); \
     if (result != CURLE_OK) raiseError(conn, result); \
     result = curl_easy_setopt(conn->handle, CURLOPT_##name##DATA, conn); \
     if (result != CURLE_OK) raiseError(conn, result); \
     CAMLreturn0; \
 }
 
+#define SETOPT_FUNCTION(name) SETOPT_FUNCTION_(name,FUNCTION)
+#define SETOPT_FUNCTION2(name) SETOPT_FUNCTION_(name,FUNCTION2)
+
 SETOPT_FUNCTION( WRITE)
+SETOPT_FUNCTION2( WRITE)
 SETOPT_FUNCTION( READ)
+SETOPT_FUNCTION2( READ)
 SETOPT_FUNCTION( HEADER)
 SETOPT_FUNCTION( PROGRESS)
 SETOPT_FUNCTION( DEBUG)
@@ -3559,6 +3644,8 @@ CURLOptionMapping implementedOptionMap[] =
 #else
   HAVENOT(SSL_OPTIONS),
 #endif
+  HAVE(WRITEFUNCTION2),
+  HAVE(READFUNCTION2),
 };
 
 value caml_curl_easy_setopt(value conn, value option)

curl.ml

@@ -332,6 +332,15 @@ type curlSslOption =
   | CURLSSLOPT_NATIVE_CA
   | CURLSSLOPT_AUTO_CLIENT_CERT
 
+type curlWritefuncOpt = string -> [`Full | `Partial of int | `Pause]
+
+type 'a xfer_result = Proceed of 'a | Pause | Abort
+
+type write_result = unit xfer_result
+type read_result = string xfer_result
+
+let proceed = Proceed ()
+
 type curlOption =
   | CURLOPT_WRITEFUNCTION of (string -> int)
   | CURLOPT_READFUNCTION of (int -> string)
@@ -482,6 +491,8 @@ type curlOption =
   | CURLOPT_BUFFERSIZE of int
   | CURLOPT_DOH_URL of string
   | CURLOPT_SSL_OPTIONS of curlSslOption list
+  | CURLOPT_WRITEFUNCTION2 of (string -> write_result)
+  | CURLOPT_READFUNCTION2 of (int -> read_result)
 
 type initOption =
   | CURLINIT_GLOBALALL
@@ -612,9 +623,15 @@ external pause : t -> pauseOption list -> unit = "caml_curl_pause"
 let set_writefunction conn closure =
   setopt conn (CURLOPT_WRITEFUNCTION closure)
 
+let set_writefunction2 conn closure =
+  setopt conn (CURLOPT_WRITEFUNCTION2 closure)
+
 let set_readfunction conn closure =
   setopt conn (CURLOPT_READFUNCTION closure)
 
+let set_readfunction2 conn closure =
+  setopt conn (CURLOPT_READFUNCTION2 closure)
+
 let set_infilesize conn size =
   setopt conn (CURLOPT_INFILESIZE size)
 
@@ -1265,7 +1282,9 @@ class handle =
     method perform = perform conn
     method cleanup = cleanup conn
     method set_writefunction closure = set_writefunction conn closure
+    method set_writefunction2 closure = set_writefunction2 conn closure
     method set_readfunction closure = set_readfunction conn closure
+    method set_readfunction2 closure = set_readfunction2 conn closure
     method set_infilesize size = set_infilesize conn size
     method set_url url = set_url conn url
     method set_proxy proxy = set_proxy conn proxy

curl.mli

@@ -334,7 +334,6 @@ type curlPostRedir =
 | REDIR_POST_302
 | REDIR_POST_303 (** added in libcurl 7.26.0 *)
 
-
 type curlSslOption =
   | CURLSSLOPT_ALLOW_BEAST
   | CURLSSLOPT_NO_REVOKE
@@ -343,6 +342,13 @@ type curlSslOption =
   | CURLSSLOPT_NATIVE_CA
   | CURLSSLOPT_AUTO_CLIENT_CERT
 
+type 'a xfer_result = Proceed of 'a | Pause | Abort
+
+type write_result = unit xfer_result
+type read_result = string xfer_result
+
+val proceed : write_result
+
 type curlOption =
   | CURLOPT_WRITEFUNCTION of (string -> int)
   | CURLOPT_READFUNCTION of (int -> string)
@@ -496,6 +502,8 @@ type curlOption =
   | CURLOPT_BUFFERSIZE of int
   | CURLOPT_DOH_URL of string
   | CURLOPT_SSL_OPTIONS of curlSslOption list
+  | CURLOPT_WRITEFUNCTION2 of (string -> write_result)
+  | CURLOPT_READFUNCTION2 of (int -> read_result)
 
 type initOption =
   | CURLINIT_GLOBALALL
@@ -634,9 +642,17 @@ val pause : t -> pauseOption list -> unit
   and transfer will be aborted. *)
 
 val set_writefunction : t -> (string -> int) -> unit
-val set_readfunction : t -> (int -> string) -> unit
+
+(* Alternative API for the write callback that allows to pause download *)
+val set_writefunction2 : t -> (string -> write_result) -> unit
+
 (** [readfunction n] should return string of length at most [n], otherwise
   transfer will be aborted (as if with exception) *)
+val set_readfunction : t -> (int -> string) -> unit
+
+(* Alternative API for the read callback that allows to pause upload *)
+val set_readfunction2 : t -> (int -> read_result) -> unit
+
 val set_infilesize : t -> int -> unit
 val set_url : t -> string -> unit
 val set_proxy : t -> string -> unit
@@ -852,7 +868,9 @@ class handle :
     method perform : unit
 
     method set_writefunction : (string -> int) -> unit
+    method set_writefunction2 : (string -> write_result) -> unit
     method set_readfunction : (int -> string) -> unit
+    method set_readfunction2 : (int -> read_result) -> unit
     method set_infilesize : int -> unit
     method set_url : string -> unit
     method set_proxy : string -> unit