Merge pull request #32 from roburio/mirage-kv-6

use mirage-kv 6.0.0 API

app/caldav_server.ml

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

caldav.opam

@@ -30,7 +30,7 @@ depends: [
   "mirage-clock-unix" {with-test & >= "2.0.0"}
   "mirage-kv-mem" {with-test & >= "2.0.0"}
   "fmt" {>= "0.8.7"}
-  "mirage-kv" {>= "3.0.0"}
+  "mirage-kv" {>= "6.0.0"}
   "mirage-clock" {>= "2.0.0"}
   "mirage-random" {>= "2.0.0"}
   "ppx_deriving" {>= "4.3"}

mirage/config.ml

@@ -57,10 +57,8 @@ let main =
     package "uri" ;
     package "caldav" ;
     package ~min:"0.1.3" "icalendar" ;
-    package ~min:"2.10.0" "irmin-git" ;
-    package ~min:"2.10.0" "irmin-mirage-git" ;
-    package ~min:"3.10.0" "git-paf";
     package ~min:"0.8.7" "fmt";
+    package ~min:"0.0.3" "git-kv"
   ] in
   let keys =
     [ Key.v http_port ; Key.v https_port ;

mirage/unikernel.ml

@@ -6,17 +6,26 @@ module Server_log = (val Logs.src_log server_src : Logs.LOG)
 let access_src = Logs.Src.create "http.access" ~doc:"HTTP server access log"
 module Access_log = (val Logs.src_log access_src : Logs.LOG)
 
-let decompose_git_url () =
-  match String.split_on_char '#' (Key_gen.remote ()) with
-  | [ url ] -> url, None
-  | [ url ; branch ] -> url, Some branch
-  | _ ->
-    Logs.err (fun m -> m "expected at most a single # in remote");
-    exit 64
-
 module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KEYS: Mirage_kv.RO) (S: Cohttp_mirage.Server.S) (Zap : Mirage_kv.RO) = struct
+
+  let author = Lwt.new_key ()
+  and user_agent = Lwt.new_key ()
+  and http_req = Lwt.new_key ()
+
   module X509 = Tls_mirage.X509(KEYS)(Clock)
-  module Store = Irmin_mirage_git.KV_RW(Irmin_git.Mem)(Clock)
+  module Store = struct
+    include Git_kv.Make(Clock)
+    let batch t f =
+      let author =
+        Fmt.str "%a (via caldav unikernel)"
+          Fmt.(option ~none:(any "no author") string) (Lwt.get author)
+      and message =
+        Fmt.str "during processing HTTP request %a@.by user-agent %a"
+          Fmt.(option ~none:(any "no HTTP request") string) (Lwt.get http_req)
+          Fmt.(option ~none:(any "none") string) (Lwt.get user_agent)
+      in
+      change_and_push t ~author ~message f
+  end
   module Dav_fs = Caldav.Webdav_fs.Make(Clock)(Store)
   module Dav = Caldav.Webdav_api.Make(R)(Clock)(Dav_fs)
   module Webdav_server = Caldav.Webdav_server.Make(R)(Clock)(Dav_fs)(S)
@@ -87,10 +96,6 @@ module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KE
     S.make ~conn_closed ~callback ()
 
   let start _random _clock ctx keys http zap =
-    let author = Lwt.new_key ()
-    and user_agent = Lwt.new_key ()
-    and http_req = Lwt.new_key ()
-    in
     let dynamic = author, user_agent, http_req in
     let init_http port config store =
       Server_log.info (fun f -> f "listening on %d/HTTP" port);
@@ -107,29 +112,8 @@ module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KE
       Caldav.Webdav_config.config ~do_trust_on_first_use host
     in
     let init_store_for_runtime config =
-      let admin_pass = Key_gen.admin_password () in
-      Irmin_git.Mem.v (Fpath.v "bla") >>= function
-      | Error _ -> assert false
-      | Ok git ->
-        (* TODO maybe source IP address? turns out to be not trivial
-                (unclear how to get it from http/conduit) *)
-        let author () =
-          Fmt.str "%a (via caldav)"
-            Fmt.(option ~none:(any "no author") string) (Lwt.get author)
-        and msg op =
-          let op_str = function
-            | `Set k -> Fmt.str "updating %a" Mirage_kv.Key.pp k
-            | `Remove k -> Fmt.str "removing %a" Mirage_kv.Key.pp k
-            | `Batch -> "batch operation"
-          in
-          Fmt.str "calendar change %s@.during processing HTTP request %a@.by user-agent %a"
-            (op_str op)
-            Fmt.(option ~none:(any "no HTTP request") string) (Lwt.get http_req)
-            Fmt.(option ~none:(any "none") string) (Lwt.get user_agent)
-        in
-        let remote, branch = decompose_git_url () in
-        Store.connect git ?branch ~depth:1 ~ctx ~author ~msg remote >>= fun store ->
-        Dav.connect store config admin_pass
+      Git_kv.connect ctx (Key_gen.remote ()) >>= fun store ->
+      Dav.connect store config (Key_gen.admin_password ())
     in
     let hostname = Key_gen.hostname () in
     match Key_gen.http_port (), Key_gen.https_port () with

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
@@ -214,12 +214,17 @@ module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) =
           let props = Properties.create ~content_type acl timestamp (String.length ics) (Fs.to_string file') in
           Fs.batch fs (fun batch ->
               Fs.write batch file ics props >>= function
-                (* TODO map error to internal server error and log it, as function *)
-              | Error _e -> Lwt.return @@ Error `Internal_server_error
+              | Error e ->
+                Log.err (fun m -> m "writing %s errored: %a" (Fs.to_string file') Fs.pp_write_error e);
+                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
@@ -286,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"
@@ -1284,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) =
@@ -1302,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 ->
@@ -1334,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
@@ -1370,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
@@ -1390,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 ->
@@ -1404,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 =
@@ -1421,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,15 +61,20 @@ sig
 
   val etag : t -> file_or_dir -> (string, error) result Lwt.t
 
-  val batch: t -> ?retries:int -> (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"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let propfile_ext = ".prop" 
+let propfile_ext = ".prop"
 
-module Make (Pclock : Mirage_clock.PCLOCK) (Fs:Mirage_kv.RW) = struct
+module type KV_RW = sig
+  include Mirage_kv.RW
+  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
 
   open Lwt.Infix
 
@@ -188,15 +193,18 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Fs:Mirage_kv.RW) = struct
     Fs.list fs kv_dir >|= function
     | Error e -> Error e
     | Ok files ->
-      let files = List.fold_left (fun acc (step, kind) ->
-          let slen = String.length step
-          and plen = String.length propfile_ext
+      let files = List.fold_left (fun acc (file, kind) ->
+          let is_propfile =
+            let step = Mirage_kv.Key.basename file in
+            let slen = String.length step
+            and plen = String.length propfile_ext
+            in
+            slen >= plen && String.(equal (sub step (slen - plen) plen) propfile_ext)
           in
-          if slen >= plen && String.(equal (sub step (slen - plen) plen) propfile_ext) then
+          if is_propfile then
             acc
           else
-            (* TODO check whether step is the entire path, or dir needs to be included *)
-            let file = dir @ [step] in
+            let file = Mirage_kv.Key.segments file in
             match kind with
             | `Value -> `File file :: acc
             | `Dictionary -> `Dir file :: acc)
@@ -294,5 +302,5 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Fs:Mirage_kv.RW) = struct
     | Some _, Some _ -> Ok ()
     | _ -> Error (`Msg "root user does not have password and salt")
 
-  let batch fs ?retries f = Fs.batch fs ?retries f
+  let batch = Fs.batch
 end

src/webdav_fs.mli

@@ -64,7 +64,12 @@ sig
 
   val etag : t -> file_or_dir -> (string, error) result Lwt.t
 
-  val batch: t -> ?retries:int -> (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: Mirage_kv.RW) : S with type t = Fs.t
+module type KV_RW = sig
+  include Mirage_kv.RW
+  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,6 +1,11 @@
 module Xml = Caldav.Webdav_xml
 module KV_mem = Mirage_kv_mem.Make(Pclock)
-module Fs = Caldav.Webdav_fs.Make(Pclock)(KV_mem)
+module KV_RW = struct
+  open Lwt.Infix
+  include KV_mem
+  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)
 module Properties = Caldav.Properties
 
@@ -1373,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 (