support keepttl option in set

.gitignore

@@ -10,3 +10,4 @@
 *.exe
 /result*
 /socket/redis.sock
+_opam

src/client.ml

@@ -1118,27 +1118,33 @@ module MakeClient(Mode: Mode) = struct
     let command = "MSETNX" :: (interleave items) in
     send_request connection command >>= return_bool
 
-  let set connection ?ex:(ex=0) ?px:(px=0) ?nx:(nx=false) ?xx:(xx=false) key value =
+  let set connection ?ex:(ex=0) ?px:(px=0) ?nx:(nx=false) ?xx:(xx=false) ?keepttl:(keepttl=false) key value =
     match (nx, xx) with
     | (true, true) ->
       IO.fail (Invalid_argument "SET command can contain only one of NX or XX options.")
     | _ ->
-      let ex = match ex with
-        | 0 -> []
-        | _ -> ["EX"; string_of_int ex] in
-      let px = match px with
-        | 0 -> []
-        | _ -> ["PX"; string_of_int px] in
-      let nx = match nx with
-        | false -> []
-        | true -> ["NX"] in
-      let xx = match xx with
-        | false -> []
-        | true -> ["XX"] in
-      let base_command = [ "SET"; key; value; ] in
-      let args = List.concat [ex; px; nx; xx] in
-      let command = List.concat [base_command; args] in
-      send_request connection command >>= return_ok_or_nil
+      if keepttl && (ex > 0 || px > 0) then
+        IO.fail (Invalid_argument "SET command cannot combine KEEPTTL with EX or PX options.")
+      else
+        let ex = match ex with
+          | 0 -> []
+          | _ -> ["EX"; string_of_int ex] in
+        let px = match px with
+          | 0 -> []
+          | _ -> ["PX"; string_of_int px] in
+        let nx = match nx with
+          | false -> []
+          | true -> ["NX"] in
+        let xx = match xx with
+          | false -> []
+          | true -> ["XX"] in
+        let keepttl = match keepttl with
+          | false -> []
+          | true -> ["KEEPTTL"] in
+        let base_command = [ "SET"; key; value; ] in
+        let args = List.concat [ex; px; nx; xx; keepttl] in
+        let command = List.concat [base_command; args] in
+        send_request connection command >>= return_ok_or_nil
 
   let setex connection key seconds value =
     let seconds = string_of_int seconds in
@@ -2012,27 +2018,33 @@ module MakeClient(Mode: Mode) = struct
           | _ -> assert false
         ) responses
 
-    let set ?ex:(ex=0) ?px:(px=0) ?nx:(nx=false) ?xx:(xx=false) key value =
+    let set ?ex:(ex=0) ?px:(px=0) ?nx:(nx=false) ?xx:(xx=false) ?keepttl:(keepttl=false) key value =
       match (nx, xx) with
       | (true, true) ->
         raise (Invalid_argument "SET command can contain only one of NX or XX options.")
       | _ ->
-        let ex = match ex with
-          | 0 -> []
-          | _ -> ["EX"; string_of_int ex] in
-        let px = match px with
-          | 0 -> []
-          | _ -> ["PX"; string_of_int px] in
-        let nx = match nx with
-          | false -> []
-          | true -> ["NX"] in
-        let xx = match xx with
-          | false -> []
-          | true -> ["XX"] in
-        let base_command = [ "SET"; key; value; ] in
-        let args = List.concat [ex; px; nx; xx] in
-        let command = List.concat [base_command; args] in
-        command
+        if keepttl && (ex > 0 || px > 0) then
+          raise (Invalid_argument "SET command cannot combine KEEPTTL with EX or PX options.")
+        else
+          let ex = match ex with
+            | 0 -> []
+            | _ -> ["EX"; string_of_int ex] in
+          let px = match px with
+            | 0 -> []
+            | _ -> ["PX"; string_of_int px] in
+          let nx = match nx with
+            | false -> []
+            | true -> ["NX"] in
+          let xx = match xx with
+            | false -> []
+            | true -> ["XX"] in
+          let keepttl = match keepttl with
+            | false -> []
+            | true -> ["KEEPTTL"] in
+          let base_command = [ "SET"; key; value; ] in
+          let args = List.concat [ex; px; nx; xx; keepttl] in
+          let command = List.concat [base_command; args] in
+          command
 
     let del keys =
       "DEL" :: keys

src/s.ml

@@ -317,10 +317,11 @@ module type Client = sig
   (** Sets the given keys to their respective values. MSETNX will not perform any operation at all even if just a single key already exists. *)
   val msetnx : connection -> (string * string) list -> bool IO.t
 
-  (** Set key to hold the string value. *)
+  (** Set key to hold the string value.
+      @param keepttl retain the existing TTL on the key (since Redis 6.0). *)
   val set :
     connection ->
-    ?ex:int -> ?px:int -> ?nx:bool -> ?xx:bool ->
+    ?ex:int -> ?px:int -> ?nx:bool -> ?xx:bool -> ?keepttl:bool ->
     string -> string -> bool IO.t
 
   (** Set key to hold the string value and set key to timeout after a given number of seconds. *)
@@ -803,7 +804,7 @@ module type Client = sig
 
     val empty : command
 
-    val set : ?ex:int -> ?px:int -> ?nx:bool -> ?xx:bool -> string -> string -> command
+    val set : ?ex:int -> ?px:int -> ?nx:bool -> ?xx:bool -> ?keepttl:bool -> string -> string -> command
 
     (** Delete a key; returns the number of keys removed. *)
     val del : string list -> command

test/test.ml

@@ -143,7 +143,9 @@ end = struct
     Client.set conn ~ex:20 key value >>=
     io_assert "Can set ex key which is already set" ((=) true) >>= fun () ->
     Client.set conn ~px:200 key value >>=
-    io_assert "Can set ex key which is already set" ((=) true) >>= fun () ->
+    io_assert "Can set px key which is already set" ((=) true) >>= fun () ->
+    Client.set conn ~keepttl:true key value >>=
+    io_assert "Can set key with keepttl" ((=) true) >>= fun () ->
     Client.get conn key >>=
     io_assert "Key and value mismatch" ((=) (Some value)) >>= fun () ->
     Client.getset conn key value >>=
@@ -254,7 +256,15 @@ end = struct
     Client.persist conn key >>=
     io_assert "Can't remove existing timeout on key" ((=) true)  >>= fun () ->
     Client.ttl conn key >>=
-    io_assert "Can't check expiration timeout for key" ((=) None)
+    io_assert "Can't check expiration timeout for key" ((=) None) >>= fun () ->
+    (* Set key with a 100s TTL, then overwrite with keepttl and verify TTL is retained *)
+    Client.set conn ~ex:100 key value >>=
+    io_assert "Can set key with ex" ((=) true) >>= fun () ->
+    Client.set conn ~keepttl:true key value >>=
+    io_assert "Can set key with keepttl" ((=) true) >>= fun () ->
+    Client.ttl conn key >>=
+    io_assert "TTL should be retained after set with keepttl"
+      (function None -> false | Some x -> x > 0 && x <= 100)
 
   let test_case_expireat conn =
     let key = redis_string_bucket () in