refine "batch" to be able to return an error ('a, `Msg of string).

app/caldav_server.ml

@@ -126,7 +126,7 @@ module Body = Cohttp_lwt.Body
 module KV_mem = Mirage_kv_mem.Make(Pclock)
 module KV_RW = struct
   include KV_mem
-  let batch t f = f t
+  let batch t f = f t >|= fun r -> Ok r
 end
 module Dav_fs = Caldav.Webdav_fs.Make(Pclock)(KV_RW)
 

src/webdav_api.ml

@@ -35,14 +35,14 @@ sig
   val verify_auth_header : state -> Webdav_config.config -> string -> (string, [> `Msg of string | `Unknown_user of string * string ]) result Lwt.t
 
   val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:Cstruct.t ->
-    (Uri.t, [> `Conflict ]) result Lwt.t
+    (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
   val change_user_password : state -> config -> name:string -> password:string -> salt:Cstruct.t -> (unit, [> `Internal_server_error ]) result Lwt.t
   val delete_user : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
-  val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict ]) result Lwt.t
-  val enroll : state -> config -> member:string -> group:string -> (unit, [> `Conflict ]) result Lwt.t
-  val resign : state -> config -> member:string -> group:string -> (unit, [> `Conflict ]) result Lwt.t
-  val replace_group_members : state -> config -> string -> string list -> (unit, [> `Conflict ]) result Lwt.t
+  val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val enroll : state -> config -> member:string -> group:string -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val resign : state -> config -> member:string -> group:string -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val replace_group_members : state -> config -> string -> string list -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
   val delete_group : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
   val initialize_fs : state -> Ptime.t -> config -> unit Lwt.t
@@ -219,8 +219,12 @@ module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) =
                 Lwt.return @@ Error `Internal_server_error
               | Ok () ->
                 update_parent_after_child_write batch file' timestamp >|= fun () -> Ok ()) >>= function
-          | Error _ as e -> Lwt.return e
-          | Ok () ->
+          | Error `Msg msg ->
+            Log.err (fun m -> m "write errored with %s" msg);
+            Lwt.return (Error `Internal_server_error)
+          | Ok (Error _ as e) ->
+            Lwt.return e
+          | Ok (Ok ()) ->
             Fs.etag fs file' >|= function
             | Error _e -> Error `Internal_server_error
             | Ok etag -> Ok etag
@@ -287,12 +291,24 @@ module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) =
 
   let delete fs ~path now =
     Fs.from_string fs path >>= function
-    | Error _ -> Lwt.return false
+    | Error e ->
+      Log.warn (fun m -> m "error %a in delete (from_string) of %s"
+                   Fs.pp_error e path);
+      Lwt.return false
     | Ok f_or_d ->
       Fs.batch fs (fun batch ->
-          Fs.destroy batch f_or_d >>= fun _res ->
-          update_parent_after_child_write batch f_or_d now >|= fun () ->
-          true)
+          Fs.destroy batch f_or_d >>= function
+          | Error we ->
+            Log.warn (fun m -> m "error %a in delete of %s"
+                         Fs.pp_write_error we path);
+            Lwt.return false
+          | Ok () ->
+            update_parent_after_child_write batch f_or_d now >|= fun () ->
+            true) >|= function
+      | Ok b -> b
+      | Error `Msg msg ->
+        Log.err (fun m -> m "error %s during delete batch" msg);
+        false
 
   let statuscode_to_string res =
     Format.sprintf "%s %s"
@@ -1285,7 +1301,11 @@ let enroll fs config ~member ~group =
       Lwt.return (Error `Conflict)
     else
       Fs.batch fs (fun batch ->
-          enroll_unsafe batch config ~member ~group >|= fun () -> Ok ())
+          enroll_unsafe batch config ~member ~group >|= fun () -> Ok ()) >|= function
+      | Ok r -> r
+      | Error `Msg msg ->
+        Log.err (fun m -> m "error in enroll batch: %s" msg);
+        Error `Internal_server_error
 
 let resign_unsafe ?(group_or_user = `Both) =
   let remove_href href (attrs, values) =
@@ -1303,7 +1323,11 @@ let resign fs config ~member ~group =
       Lwt.return (Error `Conflict)
     else
       Fs.batch fs (fun batch ->
-          resign_unsafe batch config ~member ~group >|= fun () -> Ok ())
+          resign_unsafe batch config ~member ~group >|= fun () -> Ok ()) >|= function
+      | Ok r -> r
+      | Error `Msg msg ->
+        Log.err (fun m -> m "error in resign batch: %s" msg);
+        Error `Internal_server_error
 
 let collect_principals fs config principal_dir key =
   Fs.get_property_map fs principal_dir >|= fun prop_map ->
@@ -1335,7 +1359,11 @@ let make_user ?(props = []) fs now config ~name ~password ~salt =
   Fs.batch fs (fun batch ->
       make_principal props' batch now config name >>= fun principal_url ->
       Lwt_list.iter_s (fun group -> enroll_unsafe ~group_or_user:`Group batch config ~member:name ~group) groups >|= fun () ->
-      principal_url)
+      principal_url) >|= function
+  | Ok r -> r
+  | Error `Msg msg ->
+    Log.err (fun m -> m "error in batch of make_user: %s" msg);
+    Error `Internal_server_error
 
 let delete_home_and_calendars fs principal_dir user_calendar_dir =
   Fs.destroy fs principal_dir >>= function
@@ -1371,7 +1399,11 @@ let delete_user fs config name =
             else
               resign_unsafe ~group_or_user:`Group batch config ~member:name ~group)
           groups >>= fun () ->
-        delete_principal batch config name)
+        delete_principal batch config name) >|= function
+    | Ok r -> r
+    | Error `Msg msg ->
+      Log.err (fun m -> m "error in delete_user batch: %s" msg);
+      Error `Internal_server_error
 
 let delete_group_members ?group_or_user fs config group =
   let principal_dir = `Dir [ config.principals ; group ] in
@@ -1391,7 +1423,11 @@ let delete_group fs config name =
   else
     Fs.batch fs (fun batch ->
         delete_group_members ~group_or_user:`User batch config name >>= fun () ->
-        delete_principal batch config name)
+        delete_principal batch config name) >|= function
+    | Ok r -> r
+    | Error `Msg msg ->
+      Log.err (fun m -> m "error in delete_group batch: %s" msg);
+      Error `Internal_server_error
 
 let replace_group_members fs config group new_members =
   existing_principals ~include_groups:`Only fs config >>= fun groups ->
@@ -1405,7 +1441,11 @@ let replace_group_members fs config group new_members =
       Fs.batch fs (fun batch ->
           delete_group_members batch config group >>= fun () ->
           Lwt_list.iter_s (fun member -> enroll_unsafe batch config ~member ~group) new_members >|= fun () ->
-          Ok ())
+          Ok ()) >|= function
+      | Ok r -> r
+      | Error `Msg msg ->
+        Log.err (fun m -> m "error in replace_group_members batch: %s" msg);
+        Error `Internal_server_error
 
 (* TODO find out whether we should modify calendar-home-set of group or members *)
 let make_group fs now config name members =
@@ -1422,7 +1462,11 @@ let make_group fs now config name members =
         | Ok uri ->
           Lwt_list.iter_s (fun member -> enroll_unsafe ~group_or_user:`User batch config ~member ~group:name) members >|= fun () ->
           Ok uri
-        | Error _ as e -> Lwt.return e)
+        | Error _ as e -> Lwt.return e) >|= function
+    | Ok r -> r
+    | Error `Msg msg ->
+      Log.err (fun m -> m "error in make_group batch: %s" msg);
+      Error `Internal_server_error
 
   let generate_salt () = R.generate 15
 

src/webdav_api.mli

@@ -34,14 +34,14 @@ sig
   val verify_auth_header : state -> config -> string -> (string,  [> `Msg of string | `Unknown_user of string * string ]) result Lwt.t
 
   val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:Cstruct.t ->
-    (Uri.t, [> `Conflict ]) result Lwt.t
+    (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
   val change_user_password : state -> config -> name:string -> password:string -> salt:Cstruct.t -> (unit, [> `Internal_server_error ]) result Lwt.t
   val delete_user : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
-  val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict ]) result Lwt.t
-  val enroll : state -> config -> member:string -> group:string -> (unit, [> `Conflict ]) result Lwt.t
-  val resign : state -> config -> member:string -> group:string -> (unit, [> `Conflict ]) result Lwt.t
-  val replace_group_members : state -> config -> string -> string list -> (unit, [> `Conflict ]) result Lwt.t
+  val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val enroll : state -> config -> member:string -> group:string -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val resign : state -> config -> member:string -> group:string -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
+  val replace_group_members : state -> config -> string -> string list -> (unit, [> `Conflict | `Internal_server_error ]) result Lwt.t
   val delete_group : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
   val initialize_fs : state -> Ptime.t -> config -> unit Lwt.t

src/webdav_fs.ml

@@ -61,7 +61,7 @@ sig
 
   val etag : t -> file_or_dir -> (string, error) result Lwt.t
 
-  val batch: t -> (t -> 'a Lwt.t) -> 'a Lwt.t
+  val batch: t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string ]) result Lwt.t
 end
 
 let src = Logs.Src.create "webdav.fs" ~doc:"webdav fs logs"
@@ -71,7 +71,7 @@ let propfile_ext = ".prop"
 
 module type KV_RW = sig
   include Mirage_kv.RW
-  val batch : t -> (t -> 'a Lwt.t) -> 'a Lwt.t
+  val batch : t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string ]) result Lwt.t
 end
 
 module Make (Pclock : Mirage_clock.PCLOCK) (Fs:KV_RW) = struct

src/webdav_fs.mli

@@ -64,12 +64,12 @@ sig
 
   val etag : t -> file_or_dir -> (string, error) result Lwt.t
 
-  val batch: t -> (t -> 'a Lwt.t) -> 'a Lwt.t
+  val batch: t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string]) result Lwt.t
 end
 
 module type KV_RW = sig
   include Mirage_kv.RW
-  val batch : t -> (t -> 'a Lwt.t) -> 'a Lwt.t
+  val batch : t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string ]) result Lwt.t
 end
 
 module Make (Pclock : Mirage_clock.PCLOCK) (Fs: KV_RW) : S with type t = Fs.t

test/test.ml

@@ -1,8 +1,9 @@
 module Xml = Caldav.Webdav_xml
 module KV_mem = Mirage_kv_mem.Make(Pclock)
 module KV_RW = struct
+  open Lwt.Infix
   include KV_mem
-  let batch t f = f t
+  let batch t f = f t >|= fun r -> Ok r
 end
 module Fs = Caldav.Webdav_fs.Make(Pclock)(KV_RW)
 module Dav = Caldav.Webdav_api.Make(Mirage_random_test)(Pclock)(Fs)
@@ -1377,7 +1378,8 @@ let make_user_same_name () =
     | Ok _ ->
       Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
       | Error `Conflict -> Lwt.return_unit
-      | Ok _ -> invalid_arg "expected a conflict")
+      | Error _ -> invalid_arg "expected a conflict, got a different error"
+      | Ok _ -> invalid_arg "expected a conflict, got ok")
 
 let make_user_delete_make () =
   Lwt_main.run (