fix #6542

src/lib/coda_base/ledger_transfer.ml

@@ -37,15 +37,20 @@ module From_sparse_ledger (Dest : Base_ledger_intf) : sig
     src:Sparse_ledger.t -> dest:Dest.t -> Dest.t Or_error.t
 end = struct
   let transfer_accounts ~src ~dest =
-    Sparse_ledger.iteri src ~f:(fun _idx account ->
-        let id = Account.identifier account in
-        ignore (Dest.get_or_create_account_exn dest id account) ) ;
-    let src_hash = Sparse_ledger.merkle_root src in
-    let dest_hash = Dest.merkle_root dest in
-    if not (Ledger_hash.equal src_hash dest_hash) then
+    if Dest.depth dest = Sparse_ledger.depth src then (
+      Sparse_ledger.iteri src ~f:(fun _idx account ->
+          let id = Account.identifier account in
+          ignore (Dest.get_or_create_account_exn dest id account) ) ;
+      let src_hash = Sparse_ledger.merkle_root src in
+      let dest_hash = Dest.merkle_root dest in
+      if not (Ledger_hash.equal src_hash dest_hash) then
+        Or_error.errorf
+          "Merkle roots differ after transfer: expected %s, actual %s"
+          (Ledger_hash.to_string src_hash)
+          (Ledger_hash.to_string dest_hash)
+      else Ok dest )
+    else
       Or_error.errorf
-        "Merkle roots differ after transfer: expected %s, actual %s"
-        (Ledger_hash.to_string src_hash)
-        (Ledger_hash.to_string dest_hash)
-    else Ok dest
+        "Ledger depth of src and dest doesn't match: src %d, dest %d"
+        (Sparse_ledger.depth src) (Dest.depth dest)
 end

src/lib/coda_base/sparse_ledger.ml

@@ -617,6 +617,8 @@ let has_locked_tokens_exn ~global_slot ~account_id t =
 let merkle_root t =
   Ledger_hash.of_hash (merkle_root t :> Random_oracle.Digest.t)
 
+let depth t = M.depth t
+
 let handler t =
   let ledger = ref t in
   let path_exn idx =

src/lib/coda_base/sparse_ledger.mli

@@ -16,6 +16,8 @@ end]
 
 val merkle_root : t -> Ledger_hash.t
 
+val depth : t -> int
+
 val next_available_token : t -> Token_id.t
 
 val get_exn : t -> int -> Account.t

src/lib/consensus/proof_of_stake.ml

@@ -419,6 +419,7 @@ module Data = struct
 
     let reset_snapshot (t : t) id ~sparse_ledger ~ledger_depth =
       let open Coda_base in
+      let open Or_error.Let_syntax in
       let module Ledger_transfer =
         Coda_base.Ledger_transfer.From_sparse_ledger (Ledger.Db) in
       let delegatee_table =
@@ -434,8 +435,9 @@ module Data = struct
           let ledger =
             Ledger.Db.create ~directory_name:location ~depth:ledger_depth ()
           in
-          ignore
-          @@ Ledger_transfer.transfer_accounts ~src:sparse_ledger ~dest:ledger ;
+          let%map (_ : Ledger.Db.t) =
+            Ledger_transfer.transfer_accounts ~src:sparse_ledger ~dest:ledger
+          in
           !t.staking_epoch_snapshot
           <- { delegatee_table
              ; ledger= Snapshot.Ledger_snapshot.Ledger_db ledger }
@@ -446,8 +448,9 @@ module Data = struct
           let ledger =
             Ledger.Db.create ~directory_name:location ~depth:ledger_depth ()
           in
-          ignore
-          @@ Ledger_transfer.transfer_accounts ~src:sparse_ledger ~dest:ledger ;
+          let%map (_ : Ledger.Db.t) =
+            Ledger_transfer.transfer_accounts ~src:sparse_ledger ~dest:ledger
+          in
           !t.next_epoch_snapshot
           <- { delegatee_table
              ; ledger= Snapshot.Ledger_snapshot.Ledger_db ledger }
@@ -2657,15 +2660,26 @@ module Hooks = struct
               query_peer.query peer Rpcs.Get_epoch_ledger
                 (Coda_base.Frozen_ledger_hash.to_ledger_hash target_ledger_hash)
             with
-            | Connected {data= Ok (Ok sparse_ledger); _} ->
+            | Connected {data= Ok (Ok sparse_ledger); _} -> (
                 let%bind () =
                   Trust_system.(
                     record trust_system logger peer
                       Actions.(Epoch_ledger_provided, None))
                 in
-                reset_snapshot local_state snapshot_id ~sparse_ledger
-                  ~ledger_depth ;
-                return true
+                match
+                  reset_snapshot local_state snapshot_id ~sparse_ledger
+                    ~ledger_depth
+                with
+                | Ok () ->
+                    return true
+                | Error e ->
+                    [%log faulty_peer_without_punishment]
+                      ~metadata:
+                        [ ("peer", Network_peer.Peer.to_yojson peer)
+                        ; ("error", `String (Error.to_string_hum e)) ]
+                      "Peer $peer failed to serve requested epoch ledger: \
+                       $error" ;
+                    return false )
             | Connected {data= Ok (Error err); _} ->
                 (* TODO figure out punishments here. *)
                 [%log faulty_peer_without_punishment]

src/lib/sparse_ledger_lib/sparse_ledger.ml

@@ -74,6 +74,8 @@ module type S = sig
 
   val merkle_root : t -> hash
 
+  val depth : t -> int
+
   val next_available_token : t -> token_id
 end
 
@@ -126,6 +128,8 @@ end = struct
 
   type index = int [@@deriving sexp, to_yojson]
 
+  let depth {T.depth; _} = depth
+
   let merkle_root {T.tree; _} = hash tree
 
   let next_available_token {T.next_available_token; _} = next_available_token