From 6a17b4f5636ebb54e327fbada3774bb9c18b33dd Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Dec 2022 11:02:49 +0100 Subject: [PATCH 1/4] use mirage-kv 6.0.0 API --- app/caldav_server.ml | 6 +++++- caldav.opam | 2 +- src/webdav_fs.ml | 28 ++++++++++++++++++---------- src/webdav_fs.mli | 9 +++++++-- test/test.ml | 6 +++++- 5 files changed, 36 insertions(+), 15 deletions(-) diff --git a/app/caldav_server.ml b/app/caldav_server.ml index f52acf9..96ef0a1 100644 --- a/app/caldav_server.ml +++ b/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 +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) diff --git a/caldav.opam b/caldav.opam index e81f7a8..fd3f2d8 100644 --- a/caldav.opam +++ b/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"} diff --git a/src/webdav_fs.ml b/src/webdav_fs.ml index 811561b..1d73715 100644 --- a/src/webdav_fs.ml +++ b/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 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 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 diff --git a/src/webdav_fs.mli b/src/webdav_fs.mli index 082e9e7..5fa329e 100644 --- a/src/webdav_fs.mli +++ b/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 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 Lwt.t +end + +module Make (Pclock : Mirage_clock.PCLOCK) (Fs: KV_RW) : S with type t = Fs.t diff --git a/test/test.ml b/test/test.ml index 8ea2953..62fe634 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,6 +1,10 @@ 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 + include KV_mem + let batch t f = f t +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 From 03081f2c3121fc35b98279f34ccbb43f0a4ae21d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 15 Dec 2022 11:14:12 +0100 Subject: [PATCH 2/4] log write error --- src/webdav_api.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/webdav_api.ml b/src/webdav_api.ml index c19f491..443b84a 100644 --- a/src/webdav_api.ml +++ b/src/webdav_api.ml @@ -214,8 +214,9 @@ 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 From c47f1bef7c6efe5f3eb0022d0e31f78d1c74153c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 16 Dec 2022 14:02:25 +0100 Subject: [PATCH 3/4] refine "batch" to be able to return an error ('a, `Msg of string). --- app/caldav_server.ml | 2 +- src/webdav_api.ml | 80 ++++++++++++++++++++++++++++++++++---------- src/webdav_api.mli | 10 +++--- src/webdav_fs.ml | 4 +-- src/webdav_fs.mli | 4 +-- test/test.ml | 6 ++-- 6 files changed, 76 insertions(+), 30 deletions(-) diff --git a/app/caldav_server.ml b/app/caldav_server.ml index 96ef0a1..898da91 100644 --- a/app/caldav_server.ml +++ b/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) diff --git a/src/webdav_api.ml b/src/webdav_api.ml index 443b84a..39ffcdd 100644 --- a/src/webdav_api.ml +++ b/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 diff --git a/src/webdav_api.mli b/src/webdav_api.mli index ad2bb68..d8bda6f 100644 --- a/src/webdav_api.mli +++ b/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 diff --git a/src/webdav_fs.ml b/src/webdav_fs.ml index 1d73715..2b4e38d 100644 --- a/src/webdav_fs.ml +++ b/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 diff --git a/src/webdav_fs.mli b/src/webdav_fs.mli index 5fa329e..b836d31 100644 --- a/src/webdav_fs.mli +++ b/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 diff --git a/test/test.ml b/test/test.ml index 62fe634..2f2cef2 100644 --- a/test/test.ml +++ b/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 ( From 239e0470ac03440c7e028fed5f739b6182a08234 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 16 Dec 2022 17:44:14 +0100 Subject: [PATCH 4/4] mirage unikernel: use git-kv instead of irmin* --- mirage/config.ml | 4 +--- mirage/unikernel.ml | 56 ++++++++++++++++----------------------------- 2 files changed, 21 insertions(+), 39 deletions(-) diff --git a/mirage/config.ml b/mirage/config.ml index a0a3833..f06920d 100644 --- a/mirage/config.ml +++ b/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 ; diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index a2c74ef..f7a1e3f 100644 --- a/mirage/unikernel.ml +++ b/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