Merge branch 'berkeley' into dkijania/terraform_ci

src/app/cli/src/init/client.ml

@@ -1625,6 +1625,34 @@ let generate_libp2p_keypair =
     let%map_open privkey_path = Cli_lib.Flag.privkey_write_path in
     generate_libp2p_keypair_do privkey_path)
 
+let dump_libp2p_keypair_do privkey_path =
+  Cli_lib.Exceptions.handle_nicely
+  @@ fun () ->
+  Deferred.ignore_m
+    (let open Deferred.Let_syntax in
+    let logger = Logger.null () in
+    (* Using the helper only for keypair generation requires no state. *)
+    File_system.with_temp_dir "mina-dump-libp2p-keypair" ~f:(fun tmpd ->
+        match%bind
+          Mina_net2.create ~logger ~conf_dir:tmpd ~all_peers_seen_metric:false
+            ~pids:(Child_processes.Termination.create_pid_table ())
+            ~on_peer_connected:ignore ~on_peer_disconnected:ignore ()
+        with
+        | Ok net ->
+            let%bind () = Mina_net2.shutdown net in
+            let%map me = Secrets.Libp2p_keypair.read_exn' privkey_path in
+            printf "libp2p keypair:\n%s\n" (Mina_net2.Keypair.to_string me)
+        | Error e ->
+            [%log fatal] "failed to dump libp2p keypair: $error"
+              ~metadata:[ ("error", Error_json.error_to_yojson e) ] ;
+            exit 20 ))
+
+let dump_libp2p_keypair =
+  Command.async ~summary:"Print an existing libp2p keypair"
+    (let open Command.Let_syntax in
+    let%map_open privkey_path = Cli_lib.Flag.privkey_read_path in
+    dump_libp2p_keypair_do privkey_path)
+
 let trustlist_ip_flag =
   Command.Param.(
     flag "--ip-address" ~aliases:[ "ip-address" ]
@@ -2367,4 +2395,6 @@ let ledger =
 
 let libp2p =
   Command.group ~summary:"Libp2p commands"
-    [ ("generate-keypair", generate_libp2p_keypair) ]
+    [ ("generate-keypair", generate_libp2p_keypair)
+    ; ("dump-keypair", dump_libp2p_keypair)
+    ]

src/lib/network_pool/snark_pool_diff.ml

@@ -66,7 +66,8 @@ module Make
     | Empty ->
         1
 
-  let max_per_15_seconds = 20
+  (* Effectively disable rate limitting *)
+  let max_per_15_seconds = 100000
 
   let summary = function
     | Add_solved_work (work, { proof = _; fee }) ->

src/lib/rocksdb/key_intf.ml

@@ -0,0 +1,25 @@
+module type S = sig
+  type 'a t
+
+  val to_string : 'a t -> string
+
+  val binable_key_type : 'a t -> 'a t Bin_prot.Type_class.t
+
+  val binable_data_type : 'a t -> 'a Bin_prot.Type_class.t
+end
+
+module type Some_key_intf = sig
+  type 'a unwrapped_t
+
+  type t = Some_key : 'a unwrapped_t -> t
+
+  type with_value = Some_key_value : 'a unwrapped_t * 'a -> with_value
+end
+
+module Some_key (K : sig
+  type 'a t
+end) : Some_key_intf with type 'a unwrapped_t := 'a K.t = struct
+  type t = Some_key : 'a K.t -> t
+
+  type with_value = Some_key_value : 'a K.t * 'a -> with_value
+end

src/lib/rocksdb/serializable.ml

@@ -67,6 +67,8 @@ module GADT = struct
   module type S = sig
     include Database_intf
 
+    module Some_key : Key_intf.Some_key_intf with type 'a unwrapped_t := 'a g
+
     module T : sig
       type nonrec t = t
     end
@@ -79,24 +81,16 @@ module GADT = struct
 
     val get_raw : t -> key:'a g -> Bigstring.t option
 
+    val get_batch : t -> keys:Some_key.t list -> Some_key.with_value option list
+
     module Batch : sig
       include Database_intf with type 'a g := 'a g
 
       val with_batch : T.t -> f:(t -> 'a) -> 'a
     end
   end
 
-  module type Key_intf = sig
-    type 'a t
-
-    val to_string : 'a t -> string
-
-    val binable_key_type : 'a t -> 'a t Bin_prot.Type_class.t
-
-    val binable_data_type : 'a t -> 'a Bin_prot.Type_class.t
-  end
-
-  module Make (Key : Key_intf) : S with type 'a g := 'a Key.t = struct
+  module Make (Key : Key_intf.S) : S with type 'a g := 'a Key.t = struct
     let bin_key_dump (key : 'a Key.t) =
       Bin_prot.Utils.bin_dump (Key.binable_key_type key).writer key
 
@@ -132,10 +126,27 @@ module GADT = struct
     let get_raw t ~(key : 'a Key.t) = Database.get t ~key:(bin_key_dump key)
 
     let get t ~(key : 'a Key.t) =
-      let open Option.Let_syntax in
-      let%map serialized_value = Database.get t ~key:(bin_key_dump key) in
-      let bin_key = Key.binable_data_type key in
-      bin_key.reader.read serialized_value ~pos_ref:(ref 0)
+      let%map.Option serialized_value =
+        Database.get t ~key:(bin_key_dump key)
+      in
+      let bin_data = Key.binable_data_type key in
+      bin_data.reader.read serialized_value ~pos_ref:(ref 0)
+
+    module Some_key = Key_intf.Some_key (Key)
+
+    let get_batch t ~keys =
+      let open Some_key in
+      let skeys = List.map keys ~f:(fun (Some_key k) -> bin_key_dump k) in
+      let serialized_value_opts = Database.get_batch ~keys:skeys t in
+      let f (Some_key k) =
+        Option.map ~f:(fun serialized_value ->
+            let bin_data = Key.binable_data_type k in
+            let value =
+              bin_data.reader.read serialized_value ~pos_ref:(ref 0)
+            in
+            Some_key_value (k, value) )
+      in
+      List.map2_exn keys serialized_value_opts ~f
 
     module Batch = struct
       include Make_Serializer (Database.Batch)

src/lib/transition_frontier/persistent_frontier/database.ml

@@ -219,6 +219,8 @@ let close t = Rocks.close t.db
 open Schema
 open Rocks
 
+type batch_t = Batch.t
+
 let mem db ~key = Option.is_some (get db ~key)
 
 let get_if_exists db ~default ~key =
@@ -315,51 +317,61 @@ let initialize t ~root_data =
       Batch.set batch ~key:Protocol_states_for_root_scan_state
         ~data:(protocol_states root_data |> List.map ~f:With_hash.data) )
 
-let add t ~transition =
+let find_arcs_and_root t ~(arcs_cache : State_hash.t list State_hash.Table.t)
+    ~parent_hashes =
+  let f h = Some_key.Some_key (Arcs h) in
+  let values =
+    get_batch t.db ~keys:(Some_key Root :: List.map parent_hashes ~f)
+  in
+  let populate res parent_hash arc_opt =
+    let%bind.Result () = res in
+    match arc_opt with
+    | Some (Some_key.Some_key_value (Arcs _, (data : State_hash.t list))) ->
+        State_hash.Table.set arcs_cache ~key:parent_hash ~data ;
+        Result.return ()
+    | _ ->
+        Error (`Not_found (`Arcs parent_hash))
+  in
+  match values with
+  | Some (Some_key_value (Root, (old_root : Root_data.Minimal.Stable.V2.t)))
+    :: arcs ->
+      let%map.Result () =
+        List.fold2_exn ~init:(Result.return ()) ~f:populate parent_hashes arcs
+      in
+      old_root
+  | _ ->
+      Error (`Not_found `Old_root_transition)
+
+let add ~arcs_cache ~transition =
   let transition = Mina_block.Validated.forget transition in
   let hash = State_hash.With_state_hashes.state_hash transition in
   let parent_hash =
     With_hash.data transition |> Mina_block.header |> Header.protocol_state
     |> Mina_state.Protocol_state.previous_state_hash
   in
-  let%bind () =
-    Result.ok_if_true
-      (mem t.db ~key:(Transition parent_hash))
-      ~error:(`Not_found (`Parent_transition parent_hash))
-  in
-  let%map parent_arcs =
-    get t.db ~key:(Arcs parent_hash) ~error:(`Not_found (`Arcs parent_hash))
-  in
-  Batch.with_batch t.db ~f:(fun batch ->
-      Batch.set batch ~key:(Transition hash) ~data:(With_hash.data transition) ;
-      Batch.set batch ~key:(Arcs hash) ~data:[] ;
-      Batch.set batch ~key:(Arcs parent_hash) ~data:(hash :: parent_arcs) )
-
-let move_root t ~new_root ~garbage =
+  let parent_arcs = State_hash.Table.find_exn arcs_cache parent_hash in
+  State_hash.Table.set arcs_cache ~key:parent_hash ~data:(hash :: parent_arcs) ;
+  State_hash.Table.set arcs_cache ~key:hash ~data:[] ;
+  fun batch ->
+    Batch.set batch ~key:(Transition hash) ~data:(With_hash.data transition) ;
+    Batch.set batch ~key:(Arcs hash) ~data:[] ;
+    Batch.set batch ~key:(Arcs parent_hash) ~data:(hash :: parent_arcs)
+
+let move_root ~old_root ~new_root ~garbage =
   let open Root_data.Limited in
-  let%bind () =
-    Result.ok_if_true
-      (mem t.db ~key:(Transition (hashes new_root).state_hash))
-      ~error:(`Not_found `New_root_transition)
-  in
-  let%map old_root =
-    get t.db ~key:Root ~error:(`Not_found `Old_root_transition)
-  in
   let old_root_hash = Root_data.Minimal.hash old_root in
-  (* TODO: Result compatible rocksdb batch transaction *)
-  Batch.with_batch t.db ~f:(fun batch ->
-      Batch.set batch ~key:Root ~data:(Root_data.Minimal.of_limited new_root) ;
-      Batch.set batch ~key:Protocol_states_for_root_scan_state
-        ~data:(List.map ~f:With_hash.data (protocol_states new_root)) ;
-      List.iter (old_root_hash :: garbage) ~f:(fun node_hash ->
-          (* because we are removing entire forks of the tree, there is
-           * no need to have extra logic to any remove arcs to the node
-           * we are deleting since there we are deleting all of a node's
-           * parents as well
-           *)
-          Batch.remove batch ~key:(Transition node_hash) ;
-          Batch.remove batch ~key:(Arcs node_hash) ) ) ;
-  old_root_hash
+  fun batch ->
+    Batch.set batch ~key:Root ~data:(Root_data.Minimal.of_limited new_root) ;
+    Batch.set batch ~key:Protocol_states_for_root_scan_state
+      ~data:(List.map ~f:With_hash.data (protocol_states new_root)) ;
+    List.iter (old_root_hash :: garbage) ~f:(fun node_hash ->
+        (* because we are removing entire forks of the tree, there is
+         * no need to have extra logic to any remove arcs to the node
+         * we are deleting since there we are deleting all of a node's
+         * parents as well
+         *)
+        Batch.remove batch ~key:(Transition node_hash) ;
+        Batch.remove batch ~key:(Arcs node_hash) )
 
 let get_transition t hash =
   let%map transition =
@@ -395,11 +407,7 @@ let get_root_hash t =
 
 let get_best_tip t = get t.db ~key:Best_tip ~error:(`Not_found `Best_tip)
 
-let set_best_tip t hash =
-  let%map old_best_tip_hash = get_best_tip t in
-  (* no need to batch because we only do one operation *)
-  set t.db ~key:Best_tip ~data:hash ;
-  old_best_tip_hash
+let set_best_tip data = Batch.set ~key:Best_tip ~data
 
 let rec crawl_successors t hash ~init ~f =
   let open Deferred.Result.Let_syntax in
@@ -411,3 +419,5 @@ let rec crawl_successors t hash ~init ~f =
           ~f:(Result.map_error ~f:(fun err -> `Crawl_error err))
       in
       crawl_successors t succ_hash ~init:init' ~f )
+
+let with_batch t = Batch.with_batch t.db

src/lib/transition_frontier/persistent_frontier/database.mli

@@ -14,6 +14,10 @@ open Frontier_base
 
 type t
 
+type batch_t
+
+val with_batch : t -> f:(batch_t -> 'a) -> 'a
+
 module Error : sig
   type not_found_member =
     [ `Root
@@ -65,21 +69,26 @@ val check :
 
 val initialize : t -> root_data:Root_data.Limited.t -> unit
 
-val add :
+val find_arcs_and_root :
      t
+  -> arcs_cache:State_hash.t list State_hash.Table.t
+  -> parent_hashes:State_hash.t list
+  -> ( Root_data.Minimal.t
+     , [> `Not_found of [> `Arcs of State_hash.t | `Old_root_transition ] ] )
+     result
+
+val add :
+     arcs_cache:State_hash.t list State_hash.Table.t
   -> transition:Mina_block.Validated.t
-  -> ( unit
-     , [> `Not_found of
-          [> `Parent_transition of State_hash.t | `Arcs of State_hash.t ] ] )
-     Result.t
+  -> batch_t
+  -> unit
 
 val move_root :
-     t
+     old_root:Root_data.Minimal.t
   -> new_root:Root_data.Limited.t
   -> garbage:State_hash.t list
-  -> ( State_hash.t
-     , [> `Not_found of [> `New_root_transition | `Old_root_transition ] ] )
-     Result.t
+  -> batch_t
+  -> unit
 
 val get_transition :
      t
@@ -107,10 +116,7 @@ val get_root_hash : t -> (State_hash.t, [> `Not_found of [> `Root ] ]) Result.t
 val get_best_tip :
   t -> (State_hash.t, [> `Not_found of [> `Best_tip ] ]) Result.t
 
-val set_best_tip :
-     t
-  -> State_hash.t
-  -> (State_hash.t, [> `Not_found of [> `Best_tip ] ]) Result.t
+val set_best_tip : State_hash.t -> batch_t -> unit
 
 val crawl_successors :
      t

src/lib/transition_frontier/persistent_frontier/dune

@@ -13,6 +13,7 @@
    base.caml
    sexplib0
    extlib
+   async_unix
    ;;local libraries
    o1trace
    mina_metrics