diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index a79080668..0de5440bb 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -202,9 +202,9 @@ let fork_test_chain v ~protocol ~expiration = (*-- Initialisation ----------------------------------------------------------*) -let init ?patch_context ?mapsize root = +let init ?patch_context ?mapsize ?readonly root = GitStore.Repo.v - (Irmin_lmdb.config ?mapsize root) >>= fun repo -> + (Irmin_lmdb.config ?mapsize ?readonly root) >>= fun repo -> Lwt.return { path = root ; repo ; diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index 0ef58eb6e..d389de8f3 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -20,6 +20,7 @@ type context = t val init: ?patch_context:(context -> context Lwt.t) -> ?mapsize:int64 -> + ?readonly:bool -> string -> index Lwt.t diff --git a/vendors/irmin-lmdb/irmin_lmdb.ml b/vendors/irmin-lmdb/irmin_lmdb.ml index a8b1e02d5..556ac2d3d 100644 --- a/vendors/irmin-lmdb/irmin_lmdb.ml +++ b/vendors/irmin-lmdb/irmin_lmdb.ml @@ -56,20 +56,29 @@ let int64_of_string s = with Failure _ -> Error (`Msg (Printf.sprintf "%s is not the representation of an int64" s)) +let bool_of_string s = + try Ok (bool_of_string s) + with Failure _ -> + Error (`Msg (Printf.sprintf "%s is not the representation of a boolean" s)) + let int64_converter = int64_of_string, Fmt.uint64 +let bool_converter = bool_of_string, Fmt.bool module Conf = struct let root = Irmin.Private.Conf.root let mapsize = Irmin.Private.Conf.key "mapsize" int64_converter 40_960_000_000L + let readonly = + Irmin.Private.Conf.key "readonly" bool_converter false end let config - ?(config=Irmin.Private.Conf.empty) ?mapsize file = + ?(config=Irmin.Private.Conf.empty) ?mapsize ?(readonly=false) file = let module C = Irmin.Private.Conf in let config = C.add config Conf.root (Some file) in + let config = C.add config Conf.readonly readonly in Option.value_map mapsize ~default:config ~f:(C.add config Conf.mapsize) let mem db k = @@ -613,6 +622,7 @@ module Make type config = { root : string option ; mapsize : int64 ; + readonly : bool ; (* TODO *) (* ?write_buffer_size:int -> *) (* ?max_open_files:int -> *) @@ -624,13 +634,15 @@ module Make let config c = let root = Irmin.Private.Conf.get c Conf.root in let mapsize = Irmin.Private.Conf.get c Conf.mapsize in - { root ; mapsize } + let readonly = Irmin.Private.Conf.get c Conf.readonly in + { root ; mapsize ; readonly } let v conf = - let { root ; mapsize } = config conf in + let { root ; mapsize ; readonly } = config conf in let root = match root with None -> "irmin.ldb" | Some root -> root in if not (Sys.file_exists root) then Unix.mkdir root 0o755 ; - match Lmdb.opendir ~mapsize ~flags:[NoTLS] root 0o644 with + let flags = Lmdb.NoTLS :: if readonly then [ Lmdb.RdOnly ] else [] in + match Lmdb.opendir ~mapsize ~flags root 0o644 with | Error err -> Lwt.fail_with (Lmdb.string_of_error err) | Ok db -> let db = { db ; root } in diff --git a/vendors/irmin-lmdb/irmin_lmdb.mli b/vendors/irmin-lmdb/irmin_lmdb.mli index 08f06f6f9..34a1a3cbd 100644 --- a/vendors/irmin-lmdb/irmin_lmdb.mli +++ b/vendors/irmin-lmdb/irmin_lmdb.mli @@ -18,6 +18,6 @@ (** Quick-and-dirty LevelDB backend for Irmin. *) val config: - ?config:Irmin.config -> ?mapsize:int64 -> string -> Irmin.config + ?config:Irmin.config -> ?mapsize:int64 -> ?readonly:bool -> string -> Irmin.config module Make : Irmin.S_MAKER