From e314ac635d45d18472757c77b9afb9af41fe44cc Mon Sep 17 00:00:00 2001
From: vbotbol <vincent.botbol@tezcore.com>
Date: Tue, 5 Jun 2018 15:27:32 +0200
Subject: [PATCH] Storage: add readonly option

---
 src/lib_storage/context.ml        |  4 ++--
 src/lib_storage/context.mli       |  1 +
 vendors/irmin-lmdb/irmin_lmdb.ml  | 20 ++++++++++++++++----
 vendors/irmin-lmdb/irmin_lmdb.mli |  2 +-
 4 files changed, 20 insertions(+), 7 deletions(-)

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