Shell: experimental leveldb backend

scripts/Dockerfile.binaries.in

@@ -5,7 +5,10 @@ LABEL distro_style="apk" distro="alpine" distro_long="alpine-$alpine_version" ar
 RUN adduser -S tezos && \
     apk update && \
     apk upgrade && \
-    apk add sudo bash libssl1.0 libsodium libev gmp git && \
+    apk add sudo bash libssl1.0 libsodium libev gmp git snappy && \
+    apk add leveldb \
+      --update-cache \
+      --repository http://nl.alpinelinux.org/alpine/edge/testing && \
     rm -f /var/cache/apk/* && \
     echo 'tezos ALL=(ALL:ALL) NOPASSWD:ALL' > /etc/sudoers.d/tezos && \
     chmod 440 /etc/sudoers.d/tezos && \

scripts/Dockerfile.build_deps.in

@@ -2,7 +2,10 @@ FROM ocaml/opam:alpine-$alpine_version_ocaml-$ocaml_version
 
 COPY scripts/install_build_deps.sh scripts/version.sh scripts/
 COPY src/tezos-deps.opam src/
-RUN sudo apk add libsodium-dev && \
+RUN sudo apk add libsodium-dev snappy-dev && \
+    sudo apk add leveldb-dev \
+      --update-cache \
+      --repository http://nl.alpinelinux.org/alpine/edge/testing && \
     opam switch $ocaml_version && \
     opam config exec -- ./scripts/install_build_deps.sh all \
     rm -fr ~/.opam/log/ \

src/.merlin

@@ -20,7 +20,6 @@ S client
 B client
 S attacker
 B attacker
-FLG -open Result
 FLG -w -30
 FLG -w -40
 PKG base64
@@ -48,3 +47,4 @@ PKG sodium
 PKG ssl
 PKG unix
 PKG zarith
+PKG leveldb

src/Makefile.config

@@ -13,7 +13,7 @@ DEVFLAGS := -bin-annot -g
 endif
 
 OCAMLFLAGS = \
-  ${DEVFLAGS} -short-paths -safe-string -w +27-30-40@8 \
+  ${DEVFLAGS} -thread -short-paths -safe-string -w +27-30-40@8 \
   ${INCLUDES} \
   ${EXTRA_OCAMLFLAGS}
 

src/Makefile.files

@@ -313,6 +313,8 @@ NODE_PACKAGES := \
   irmin.unix \
   ocplib-resto.directory \
   ssl \
+  threads.posix \
+  leveldb \
 
 EMBEDDED_NODE_PROTOCOLS := \
   $(patsubst ${SRCDIR}/proto/%/,${SRCDIR}/proto/embedded_proto_%.cmxa, \

src/node/db/raw_store.ml

@@ -7,89 +7,133 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module List = ListLabels
 open Logging.Db
 
-type t = { root : string }
-
-let init root =
-  IO.check_dir root >>=? fun () ->
-  return { root }
-
+type t = LevelDB.db
 type key = string list
 type value = MBytes.t
 
-let file_of_key { root } key =
-  String.concat Filename.dir_sep (root :: key)
-
-let dir_of_key { root } key =
-  let dir = List.rev @@ List.tl (List.rev key) in
-  String.concat Filename.dir_sep (root :: dir)
-
-let known s k =
-  let file = file_of_key s k in
-  Lwt.return (Sys.file_exists file && not (Sys.is_directory file))
-
-let known_dir s k =
-  let file = file_of_key s k in
-  Lwt.return (Sys.file_exists file && Sys.is_directory file)
-
-let read_opt s k =
-  let file = file_of_key s k in
-  if Sys.file_exists file && not (Sys.is_directory file) then
-    Lwt.catch
-      (fun () ->
-         IO.with_file_in file
-           (fun ba -> Lwt.return (Some ba)))
-      (fun e ->
-         warn "warn: can't read %s: %s"
-           file (Printexc.to_string e);
-         Lwt.return_none)
-  else
-    Lwt.return_none
-
 type error += Unknown of string list
 
-let () =
-  Error_monad.register_error_kind
-    `Permanent
-    ~id:"store.unkown_key"
-    ~title:"Unknown key in store"
-    ~description: ""
-    ~pp:(fun ppf key ->
-        Format.fprintf ppf
-          "@[<v 2>Unknown key %s@]"
-          (String.concat "/" key))
-    Data_encoding.(obj1 (req "key" (list string)))
-    (function Unknown key -> Some key | _ -> None)
-    (fun key -> Unknown key)
+let concat = String.concat "/"
+let split = String.split_on_char '/'
+
+let init path =
+  try
+    return (LevelDB.open_db path)
+  with exn ->
+    Lwt.return (error_exn exn)
+
+let close t = LevelDB.close t
+
+let known t key =
+  Lwt.return (LevelDB.mem t (concat key))
+
+let read_opt t key =
+  Lwt.return (map_option ~f:MBytes.of_string (LevelDB.get t (concat key)))
 
 let read t key =
-  read_opt t key >>= function
+  match LevelDB.get t (concat key) with
   | None -> fail (Unknown key)
-  | Some v -> return v
+  | Some k -> return (MBytes.of_string k)
 
 let read_exn t key =
-  read_opt t key >>= function
-  | None -> Lwt.fail Not_found
-  | Some v -> Lwt.return v
+  Lwt.wrap2 LevelDB.get_exn t (concat key) >|= MBytes.of_string
 
-let remove s k =
-  IO.remove_file ~cleanup:true (file_of_key s k)
+let store t k v =
+  LevelDB.put t (concat k) (MBytes.to_string v) ;
+  Lwt.return_unit
 
-let store s k v =
-  let file = file_of_key s k in
-  IO.remove_file ~cleanup:false file >>= fun () ->
-  IO.with_file_out file v
+let remove t k =
+  LevelDB.delete t (concat k) ;
+  Lwt.return_unit
 
-let fold s k ~init ~f =
-  let dir = file_of_key s k in
-  IO.fold dir
-    ~init
-    ~f:(fun file acc ->
-        if IO.is_directory (Filename.concat dir file) then
-          f (`Dir (k @ [file])) acc
-        else
-          f (`Key (k @ [file])) acc)
+let is_prefix s s' =
+  String.(length s <= length s' && compare s (sub s' 0 (length s)) = 0)
+
+let known_dir t k =
+  let ret = ref false in
+  let k = concat k in
+  LevelDB.iter_from begin fun kk _ ->
+    if is_prefix k kk then ret := true ;
+    false
+  end t k ;
+  Lwt.return !ret
+
+let remove_dir t k =
+  let k = concat k in
+  let batch = LevelDB.Batch.make () in
+  LevelDB.iter_from begin fun kk _ ->
+    if is_prefix k kk then begin
+      LevelDB.Batch.delete batch kk ;
+      true
+    end
+    else false
+  end t k ;
+  LevelDB.Batch.write t batch ;
+  Lwt.return_unit
+
+let list_equal l1 l2 len =
+  if len < 0 || len > List.length l1 || len > List.length l2
+  then invalid_arg "list_compare: invalid len" ;
+  let rec inner l1 l2 len =
+    match len, l1, l2 with
+    | 0, _, _ -> true
+    | _, [], _
+    | _, _, [] -> false
+    | _, h1 :: t1, h2 :: t2 ->
+        if h1 <> h2 then false
+        else inner t1 t2 (pred len)
+  in
+  inner l1 l2 len
+
+let is_child ~parent ~child =
+  let plen = List.length parent in
+  let clen = List.length child in
+  clen > plen && list_equal parent child plen
+
+let list_sub l pos len =
+  if len < 0 || pos < 0 || pos + len > List.length l then
+    invalid_arg "list_sub" ;
+  let rec inner (acc, n) = function
+    | [] -> List.rev acc
+    | h :: t ->
+        if n = 0 then List.rev acc
+        else inner (h :: acc, pred n) t in
+  inner ([], len) l
+
+let fold t k ~init ~f =
+  let k_concat = concat k in
+  let base_len = List.length k in
+  let i = LevelDB.Iterator.make t in
+  LevelDB.Iterator.seek i k_concat 0 (String.length k_concat) ;
+  let returned = Hashtbl.create 31 in
+  let rec inner acc =
+    match LevelDB.Iterator.valid i with
+    | false -> Lwt.return acc
+    | true ->
+        let kk = LevelDB.Iterator.get_key i in
+        let kk_split = split kk in
+        match is_child ~child:kk_split ~parent:k with
+        | false -> Lwt.return acc
+        | true ->
+            let cur_len = List.length kk_split in
+            LevelDB.Iterator.next i ;
+            if cur_len = succ base_len then begin
+              (f (`Key kk_split) acc) >>= inner
+            end
+            else begin
+              let dir = list_sub kk_split 0 (succ base_len) in
+              if Hashtbl.mem returned dir then
+                inner acc
+              else begin
+                Hashtbl.add returned dir () ;
+                (f (`Dir dir) acc) >>= inner
+              end
+            end ;
+  in
+  inner init
 
 let fold_keys s k ~init ~f =
   let rec loop k acc =
@@ -101,12 +145,3 @@ let fold_keys s k ~init ~f =
   loop k init
 
 let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
-
-let remove_dir s k =
-  let rec loop k =
-    fold s k ~init:()
-      ~f:(fun file () ->
-          match file with
-          | `Key k -> remove s k
-          | `Dir k -> loop k) in
-  loop  k

src/node/db/raw_store.mli

@@ -12,4 +12,5 @@ open Store_sigs
 include STORE
 
 val init: string -> t tzresult Lwt.t
+val close : t -> unit
 

src/node/db/store.ml

@@ -463,3 +463,4 @@ let init dir =
   Protocol.register s ;
   return s
 
+let close = Raw_store.close

src/node/db/store.mli

@@ -14,6 +14,7 @@ type global_store = t
 
 (** Open or initialize a store at a given path. *)
 val init: string -> t tzresult Lwt.t
+val close : t -> unit
 
 
 (** {2 Net store} ************************************************************)

src/node/shell/node.ml

@@ -112,6 +112,7 @@ let create { genesis ; store_root ; context_root ;
   Validator.activate validator mainnet_net >>= fun mainnet_validator ->
   let mainnet_db = Validator.net_db mainnet_validator in
   let shutdown () =
+    State.close state >>= fun () ->
     P2p.shutdown p2p >>= fun () ->
     Validator.shutdown validator >>= fun () ->
     Lwt.return_unit

src/node/shell/state.ml

@@ -1504,3 +1504,9 @@ let read
   } in
   Net.read_all state >>=? fun () ->
   return state
+
+let close { global_data } =
+  Shared.use global_data begin fun { global_store } ->
+    Store.close global_store ;
+    Lwt.return_unit
+  end

src/node/shell/state.mli

@@ -30,6 +30,8 @@ val read:
   unit ->
   global_state tzresult Lwt.t
 
+val close:
+  global_state -> unit Lwt.t
 
 (** {2 Errors} **************************************************************)
 

src/tezos-deps.opam

@@ -38,6 +38,7 @@ depends: [
   "js_of_ocaml"
   "sodium" {>= "0.3.0" }
   "magic-mime"
+  "leveldb" {>= "1.1.2" }
   "kaputt" # { test }
   "bisect_ppx" # { test }
 ]