Merge branch 'compatible' into feature/rm-token-snapp-features

src/app/cli/src/init/coda_run.ml

@@ -313,13 +313,11 @@ let setup_local_server ?(client_trustlist = []) ?rest_server_port
             ( Mina_commands.verify_payment coda aid tx proof
             |> Participating_state.active_error |> Or_error.join ) )
     ; implement Daemon_rpcs.Get_public_keys_with_details.rpc (fun () () ->
-          return
-            ( Mina_commands.get_keys_with_details coda
-            |> Participating_state.active_error ) )
+          let%map keys = Mina_commands.get_keys_with_details coda in
+          Participating_state.active_error keys )
     ; implement Daemon_rpcs.Get_public_keys.rpc (fun () () ->
-          return
-            ( Mina_commands.get_public_keys coda
-            |> Participating_state.active_error ) )
+          let%map keys = Mina_commands.get_public_keys coda in
+          Participating_state.active_error keys )
     ; implement Daemon_rpcs.Get_nonce.rpc (fun () aid ->
           return
             ( Mina_commands.get_nonce coda aid
@@ -334,36 +332,41 @@ let setup_local_server ?(client_trustlist = []) ?rest_server_port
     ; implement Daemon_rpcs.Clear_hist_status.rpc (fun () flag ->
           Mina_commands.clear_hist_status ~flag coda )
     ; implement Daemon_rpcs.Get_ledger.rpc (fun () lh ->
-          (* getting the ledger may take more time than a heartbeat timeout
-             run in thread to allow RPC heartbeats to proceed
-          *)
-          Async.In_thread.run (fun () -> Mina_lib.get_ledger coda lh) )
+          Mina_lib.get_ledger coda lh )
     ; implement Daemon_rpcs.Get_snarked_ledger.rpc (fun () lh ->
-          Mina_lib.get_snarked_ledger coda lh |> return )
+          Mina_lib.get_snarked_ledger coda lh )
     ; implement Daemon_rpcs.Get_staking_ledger.rpc (fun () which ->
-          ( match which with
-          | Next ->
-              Option.value_map (Mina_lib.next_epoch_ledger coda)
-                ~default:
-                  (Or_error.error_string "next staking ledger not available")
-                ~f:(function
-                | `Finalized ledger ->
-                    Ok ledger
-                | `Notfinalized ->
-                    Or_error.error_string
-                      "next staking ledger is not finalized yet" )
-          | Current ->
-              Option.value_map
-                (Mina_lib.staking_ledger coda)
-                ~default:
-                  (Or_error.error_string "current staking ledger not available")
-                ~f:Or_error.return )
-          |> Or_error.map ~f:(function
-               | Genesis_epoch_ledger l ->
-                   Mina_base.Ledger.to_list l
-               | Ledger_db db ->
-                   Mina_base.Ledger.Db.to_list db )
-          |> Deferred.return )
+          let ledger_or_error =
+            match which with
+            | Next ->
+                Option.value_map (Mina_lib.next_epoch_ledger coda)
+                  ~default:
+                    (Or_error.error_string "next staking ledger not available")
+                  ~f:(function
+                  | `Finalized ledger ->
+                      Ok ledger
+                  | `Notfinalized ->
+                      Or_error.error_string
+                        "next staking ledger is not finalized yet" )
+            | Current ->
+                Option.value_map
+                  (Mina_lib.staking_ledger coda)
+                  ~default:
+                    (Or_error.error_string
+                       "current staking ledger not available" )
+                  ~f:Or_error.return
+          in
+          match ledger_or_error with
+          | Ok ledger -> (
+              match ledger with
+              | Genesis_epoch_ledger l ->
+                  let%map accts = Mina_base.Ledger.to_list l in
+                  Ok accts
+              | Ledger_db db ->
+                  let%map accts = Mina_base.Ledger.Db.to_list db in
+                  Ok accts )
+          | Error err ->
+              return (Error err) )
     ; implement Daemon_rpcs.Stop_daemon.rpc (fun () () ->
           Scheduler.yield () >>= (fun () -> exit 0) |> don't_wait_for ;
           Deferred.unit )

src/app/replayer/replayer.ml

@@ -63,20 +63,21 @@ let json_ledger_hash_of_ledger ledger =
   Ledger_hash.to_yojson @@ Ledger.merkle_root ledger
 
 let create_ledger_as_list ledger =
-  List.map (Ledger.to_list ledger) ~f:(fun acc ->
+  let%map accounts = Ledger.to_list ledger in
+  List.map accounts ~f:(fun acc ->
       Genesis_ledger_helper.Accounts.Single.of_account acc None )
 
 let create_output ~target_fork_state_hash ~target_epoch_ledgers_state_hash
     ~ledger ~staking_epoch_ledger ~staking_seed ~next_epoch_ledger ~next_seed
     (input_genesis_ledger : Runtime_config.Ledger.t) =
-  let genesis_ledger_as_list = create_ledger_as_list ledger in
+  let%bind genesis_ledger_as_list = create_ledger_as_list ledger in
   let target_genesis_ledger =
     { input_genesis_ledger with base = Accounts genesis_ledger_as_list }
   in
-  let staking_epoch_ledger_as_list =
+  let%bind staking_epoch_ledger_as_list =
     create_ledger_as_list staking_epoch_ledger
   in
-  let next_epoch_ledger_as_list = create_ledger_as_list next_epoch_ledger in
+  let%map next_epoch_ledger_as_list = create_ledger_as_list next_epoch_ledger in
   let target_staking_epoch_data : Runtime_config.Epoch_data.Data.t =
     let ledger =
       { input_genesis_ledger with base = Accounts staking_epoch_ledger_as_list }
@@ -98,8 +99,9 @@ let create_output ~target_fork_state_hash ~target_epoch_ledgers_state_hash
   ; target_epoch_data
   }
 
-let create_replayer_checkpoint ~ledger ~start_slot_since_genesis : input =
-  let accounts = create_ledger_as_list ledger in
+let create_replayer_checkpoint ~ledger ~start_slot_since_genesis :
+    input Deferred.t =
+  let%map accounts = create_ledger_as_list ledger in
   let genesis_ledger : Runtime_config.Ledger.t =
     { base = Accounts accounts
     ; num_accounts = None
@@ -268,7 +270,7 @@ let update_epoch_ledger ~logger ~name ~ledger ~epoch_ledger epoch_ledger_hash =
       name
       (Ledger_hash.to_base58_check epoch_ledger_hash) ;
     (* Ledger.copy doesn't actually copy, roll our own here *)
-    let accounts = Ledger.to_list ledger in
+    let%map accounts = Ledger.to_list ledger in
     let epoch_ledger = Ledger.create ~depth:(Ledger.depth ledger) () in
     List.iter accounts ~f:(fun account ->
         let pk = Account.public_key account in
@@ -292,7 +294,7 @@ let update_epoch_ledger ~logger ~name ~ledger ~epoch_ledger epoch_ledger_hash =
                 * (string * Token_id.t)]
             |> Error.raise ) ;
     epoch_ledger )
-  else epoch_ledger
+  else return epoch_ledger
 
 let update_staking_epoch_data ~logger pool ~ledger ~last_block_id
     ~staking_epoch_ledger =
@@ -306,12 +308,12 @@ let update_staking_epoch_data ~logger pool ~ledger ~last_block_id
       ~f:(fun db -> Sql.Epoch_data.get_staking_epoch_data_id db state_hash)
       ~item:"staking epoch id"
   in
-  let%map { epoch_ledger_hash; epoch_data_seed } =
+  let%bind { epoch_ledger_hash; epoch_data_seed } =
     query_db pool
       ~f:(fun db -> Sql.Epoch_data.get_epoch_data db staking_epoch_id)
       ~item:"staking epoch data"
   in
-  let ledger =
+  let%map ledger =
     update_epoch_ledger ~logger ~name:"staking" ~ledger
       ~epoch_ledger:staking_epoch_ledger epoch_ledger_hash
   in
@@ -329,12 +331,12 @@ let update_next_epoch_data ~logger pool ~ledger ~last_block_id
       ~f:(fun db -> Sql.Epoch_data.get_next_epoch_data_id db state_hash)
       ~item:"next epoch id"
   in
-  let%map { epoch_ledger_hash; epoch_data_seed } =
+  let%bind { epoch_ledger_hash; epoch_data_seed } =
     query_db pool
       ~f:(fun db -> Sql.Epoch_data.get_epoch_data db next_epoch_id)
       ~item:"next epoch data"
   in
-  let ledger =
+  let%map ledger =
     update_epoch_ledger ~logger ~name:"next" ~ledger
       ~epoch_ledger:next_epoch_ledger epoch_ledger_hash
   in
@@ -991,9 +993,11 @@ let unquoted_string_of_yojson json =
 let write_replayer_checkpoint ~logger ~ledger ~last_global_slot_since_genesis =
   (* start replaying at the slot after the one we've just finished with *)
   let start_slot_since_genesis = Int64.succ last_global_slot_since_genesis in
-  let replayer_checkpoint =
-    create_replayer_checkpoint ~ledger ~start_slot_since_genesis
-    |> input_to_yojson |> Yojson.Safe.pretty_to_string
+  let%bind replayer_checkpoint =
+    let%map input =
+      create_replayer_checkpoint ~ledger ~start_slot_since_genesis
+    in
+    input_to_yojson input |> Yojson.Safe.pretty_to_string
   in
   let checkpoint_file =
     sprintf "replayer-checkpoint-%Ld.json" start_slot_since_genesis
@@ -1437,13 +1441,15 @@ let main ~input_file ~output_file_opt ~archive_uri ~set_nonces ~repair_nonces
               if Int.equal !error_count 0 then (
                 [%log info] "Writing output to $output_file"
                   ~metadata:[ ("output_file", `String output_file) ] ;
-                let output =
-                  create_output ~target_epoch_ledgers_state_hash
-                    ~target_fork_state_hash:
-                      (State_hash.of_base58_check_exn target_state_hash)
-                    ~ledger ~staking_epoch_ledger ~staking_seed
-                    ~next_epoch_ledger ~next_seed input.genesis_ledger
-                  |> output_to_yojson |> Yojson.Safe.pretty_to_string
+                let%bind output =
+                  let%map output =
+                    create_output ~target_epoch_ledgers_state_hash
+                      ~target_fork_state_hash:
+                        (State_hash.of_base58_check_exn target_state_hash)
+                      ~ledger ~staking_epoch_ledger ~staking_seed
+                      ~next_epoch_ledger ~next_seed input.genesis_ledger
+                  in
+                  output_to_yojson output |> Yojson.Safe.pretty_to_string
                 in
                 return
                 @@ Out_channel.with_file output_file ~f:(fun oc ->

src/lib/merkle_ledger/any_ledger.ml

@@ -181,6 +181,8 @@ module Make_base (Inputs : Inputs_intf) :
 
     let to_list (T ((module Base), t)) = Base.to_list t
 
+    let to_list_sequential (T ((module Base), t)) = Base.to_list_sequential t
+
     let make_space_for (T ((module Base), t)) = Base.make_space_for t
 
     let get_all_accounts_rooted_at_exn (T ((module Base), t)) =

src/lib/merkle_ledger/base_ledger_intf.ml

@@ -44,7 +44,10 @@ module type S = sig
        and type t := t
 
   (** list of accounts in the ledger *)
-  val to_list : t -> account list
+  val to_list : t -> account list Async.Deferred.t
+
+  (** list of accounts via slower sequential mechanism *)
+  val to_list_sequential : t -> account list
 
   (** iterate over all indexes and accounts *)
   val iteri : t -> f:(index -> account -> unit) -> unit
@@ -71,10 +74,10 @@ module type S = sig
     -> init:'accum
     -> f:('accum -> account -> ('accum, 'stop) Base.Continue_or_stop.t)
     -> finish:('accum -> 'stop)
-    -> 'stop
+    -> 'stop Async.Deferred.t
 
   (** set of account ids associated with accounts *)
-  val accounts : t -> account_id_set
+  val accounts : t -> account_id_set Async.Deferred.t
 
   (** Get the public key that owns a token. *)
   val token_owner : t -> token_id -> key option

src/lib/merkle_ledger/database.ml

@@ -154,26 +154,6 @@ module Make (Inputs : Inputs_intf) :
     | None ->
         empty_hash (Location.height ~ledger_depth:mdb.depth location)
 
-  let account_list_bin { kvdb; _ } account_bin_read : Account.t list =
-    let all_keys_values = Kvdb.to_alist kvdb in
-    (* see comment at top of location.ml about encoding of locations *)
-    let account_location_prefix =
-      Location.Prefix.account |> Unsigned.UInt8.to_int
-    in
-    (* just want list of locations and accounts, ignoring other locations *)
-    let locations_accounts_bin =
-      List.filter all_keys_values ~f:(fun (loc, _v) ->
-          let ch = Bigstring.get_uint8 loc ~pos:0 in
-          Int.equal ch account_location_prefix )
-    in
-    List.map locations_accounts_bin ~f:(fun (_location_bin, account_bin) ->
-        account_bin_read account_bin ~pos_ref:(ref 0) )
-
-  let to_list mdb = account_list_bin mdb Account.bin_read_t
-
-  let accounts mdb =
-    to_list mdb |> List.map ~f:Account.identifier |> Account_id.Set.of_list
-
   let set_raw { kvdb; depth; _ } location bin =
     Kvdb.set kvdb
       ~key:(Location.serialize ~ledger_depth:depth location)
@@ -623,6 +603,26 @@ module Make (Inputs : Inputs_intf) :
     let addr = Addr.of_int_exn ~ledger_depth:mdb.depth index in
     set mdb (Location.Account addr) account
 
+  let num_accounts t =
+    match Account_location.last_location_address t with
+    | None ->
+        0
+    | Some addr ->
+        Addr.to_int addr + 1
+
+  let to_list mdb =
+    let num_accounts = num_accounts mdb in
+    Async.Deferred.List.init ~how:`Parallel num_accounts ~f:(fun i ->
+        Async.Deferred.return @@ get_at_index_exn mdb i )
+
+  let to_list_sequential mdb =
+    let num_accounts = num_accounts mdb in
+    List.init num_accounts ~f:(fun i -> get_at_index_exn mdb i)
+
+  let accounts mdb =
+    let%map.Async.Deferred accts = to_list mdb in
+    List.map accts ~f:Account.identifier |> Account_id.Set.of_list
+
   let get_or_create_account mdb account_id account =
     match Account_location.get mdb account_id with
     | Error Account_location_not_found -> (
@@ -639,13 +639,6 @@ module Make (Inputs : Inputs_intf) :
     | Ok location ->
         Ok (`Existed, location)
 
-  let num_accounts t =
-    match Account_location.last_location_address t with
-    | None ->
-        0
-    | Some addr ->
-        Addr.to_int addr + 1
-
   let iteri t ~f =
     match Account_location.last_location_address t with
     | None ->
@@ -680,23 +673,9 @@ module Make (Inputs : Inputs_intf) :
   let foldi t ~init ~f =
     foldi_with_ignored_accounts t Account_id.Set.empty ~init ~f
 
-  module C : Container.S0 with type t := t and type elt := Account.t =
-  Container.Make0 (struct
-    module Elt = Account
-
-    type nonrec t = t
-
-    let fold t ~init ~f =
-      let f' _index accum account = f accum account in
-      foldi t ~init ~f:f'
-
-    let iter = `Define_using_fold
-
-    (* Use num_accounts instead? *)
-    let length = `Define_using_fold
-  end)
-
-  let fold_until = C.fold_until
+  let fold_until t ~init ~f ~finish =
+    let%map.Async.Deferred accts = to_list t in
+    List.fold_until accts ~init ~f ~finish
 
   let merkle_root mdb = get_hash mdb Location.root_hash
 

src/lib/merkle_ledger/null_ledger.ml

@@ -103,7 +103,7 @@ end = struct
   let location_of_account_batch _t accts =
     List.map accts ~f:(fun acct -> (acct, None))
 
-  let accounts _t = Account_id.Set.empty
+  let accounts _t = Async.Deferred.return Account_id.Set.empty
 
   let token_owner _t _tid = None
 
@@ -118,13 +118,15 @@ end = struct
 
   let iteri _t ~f:_ = ()
 
-  let fold_until _t ~init ~f:_ ~finish = finish init
+  let fold_until _t ~init ~f:_ ~finish = Async.Deferred.return @@ finish init
 
   let foldi_with_ignored_accounts _t _ ~init ~f:_ = init
 
   let foldi _t ~init ~f:_ = init
 
-  let to_list _t = []
+  let to_list _t = Async.Deferred.return []
+
+  let to_list_sequential _t = []
 
   let make_space_for _t _tot = ()
 

src/lib/merkle_ledger_tests/dune

@@ -15,6 +15,7 @@
    ppx_inline_test.config
    result
    async_kernel
+   async_unix
    async
    core_kernel
    ;; local libraries