Alpha: add missing balance updates in operation receipts

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -625,9 +625,15 @@ module Delegate : sig
   val cycle_end:
     context -> Cycle.t -> Nonce.unrevealed list -> context tzresult Lwt.t
 
+  type frozen_balance = {
+    deposit : Tez.t ;
+    fees : Tez.t ;
+    rewards : Tez.t ;
+  }
+
   val punish:
     context -> public_key_hash -> Cycle.t ->
-    (context * Tez.t) tzresult Lwt.t
+    (context * frozen_balance) tzresult Lwt.t
 
   val full_balance:
     context -> public_key_hash -> Tez.t tzresult Lwt.t
@@ -639,12 +645,6 @@ module Delegate : sig
   val frozen_balance:
     context -> public_key_hash -> Tez.t tzresult Lwt.t
 
-  type frozen_balance = {
-    deposit : Tez.t ;
-    fees : Tez.t ;
-    rewards : Tez.t ;
-  }
-
   val frozen_balance_encoding: frozen_balance Data_encoding.t
   val frozen_balance_by_cycle_encoding: frozen_balance Cycle.Map.t Data_encoding.t
 

src/proto_alpha/lib_protocol/src/apply.ml

@@ -322,6 +322,17 @@ let () =
 
 open Apply_operation_result
 
+(**
+   Transaction: source/payer A -> destination B
+   - payer: is the signer of the operation, the one that pays the storage fee.
+   This fee is not going to the baker but it will be burned.
+   - source: is the one who will pay for the fees: space and gas consumption.
+   This amount will go to the baker.
+   - internal: set to true in the case of transaction between smart contracts.
+   Where there is a new storage cost for each smart contract may occurs. The
+   source may not be the same A any more.
+*)
+
 let apply_manager_operation_content :
   type kind.
   ( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t ->
@@ -498,12 +509,13 @@ let precheck_manager_contents
   return ctxt
 
 let apply_manager_contents
-    (type kind) ctxt mode (op : kind Kind.manager contents)
+    (type kind) ctxt mode baker (op : kind Kind.manager contents)
   : (context * kind Kind.manager contents_result) tzresult Lwt.t =
   let Manager_operation
       { source ; fee ; operation ; gas_limit ; storage_limit } = op in
   Lwt.return (Gas.set_limit ctxt gas_limit) >>=? fun ctxt ->
   Lwt.return (Contract.set_storage_limit ctxt storage_limit) >>=? fun ctxt ->
+  let level = Level.current ctxt in
   apply_manager_operation_content ctxt mode
     ~source ~payer:source ~internal:false operation >>= begin function
     | Ok (ctxt, operation_results, internal_operations) -> begin
@@ -524,8 +536,10 @@ let apply_manager_contents
           Manager_operation_result
             { balance_updates =
                 cleanup_balance_updates
-                  [ Contract source, Debited fee ;
+                  [
-                    (* FIXME: add credit to the baker *) ] ;
+                    Contract source, Debited fee ;
+                    Rewards (baker, level.cycle), Credited fee
+                  ] ;
               operation_result ;
               internal_operation_results })
 
@@ -561,12 +575,12 @@ let rec precheck_manager_contents_list
 
 let rec apply_manager_contents_list
   : type kind.
-    Alpha_context.t -> _ -> kind Kind.manager contents_list ->
+    Alpha_context.t -> _ -> _ -> kind Kind.manager contents_list ->
     (context * kind Kind.manager contents_result_list) Lwt.t =
-  fun ctxt mode contents_list ->
+  fun ctxt mode baker contents_list ->
     match contents_list with
     | Single (Manager_operation { operation ; _ } as op) -> begin
-        apply_manager_contents ctxt mode op >>= function
+        apply_manager_contents ctxt mode baker op >>= function
         | Error errors ->
             let result =
               Manager_operation_result {
@@ -584,7 +598,7 @@ let rec apply_manager_contents_list
             Lwt.return (ctxt, Single_result (result))
       end
     | Cons (Manager_operation { operation ; _ } as op, rest) ->
-        apply_manager_contents ctxt mode op >>= function
+        apply_manager_contents ctxt mode baker op >>= function
         | Error errors ->
             let result =
               Manager_operation_result {
@@ -595,7 +609,7 @@ let rec apply_manager_contents_list
             Lwt.return (ctxt, Cons_result (result, mark_skipped rest))
         | Ok (ctxt, (Manager_operation_result
                        { operation_result = Applied _ ; _ } as result)) ->
-            apply_manager_contents_list ctxt mode rest >>= fun (ctxt, results) ->
+            apply_manager_contents_list ctxt mode baker rest >>= fun (ctxt, results) ->
             Lwt.return (ctxt, Cons_result (result, results))
         | Ok (ctxt,
               (Manager_operation_result
@@ -603,7 +617,7 @@ let rec apply_manager_contents_list
             Lwt.return (ctxt, Cons_result (result, mark_skipped rest))
 
 let apply_contents_list
-    (type kind) ctxt mode pred_block
+    (type kind) ctxt mode pred_block baker
     (operation : kind operation)
     (contents_list : kind contents_list)
   : (context * kind contents_result_list) tzresult Lwt.t =
@@ -637,7 +651,11 @@ let apply_contents_list
       let seed_nonce_revelation_tip =
         Constants.seed_nonce_revelation_tip ctxt in
       add_rewards ctxt seed_nonce_revelation_tip >>=? fun ctxt ->
-      return (ctxt, Single_result (Seed_nonce_revelation_result [(* FIXME *)]))
+      return (ctxt, Single_result
+                (Seed_nonce_revelation_result
+                   [
+                     Rewards (baker, level.cycle), Credited seed_nonce_revelation_tip
+                   ]))
   | Single (Double_endorsement_evidence { op1 ; op2 }) -> begin
       match op1.protocol_data.contents, op2.protocol_data.contents with
       | Single (Endorsement e1),
@@ -662,13 +680,22 @@ let apply_contents_list
                { delegate1 ; delegate2 }) >>=? fun () ->
           Delegate.has_frozen_balance ctxt delegate1 level.cycle >>=? fun valid ->
           fail_unless valid Unrequired_double_endorsement_evidence >>=? fun () ->
-          Delegate.punish ctxt delegate1 level.cycle >>=? fun (ctxt, burned) ->
+          Delegate.punish ctxt delegate1 level.cycle >>=? fun (ctxt, balance) ->
+          Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned ->
           let reward =
             match Tez.(burned /? 2L) with
             | Ok v -> v
             | Error _ -> Tez.zero in
           add_rewards ctxt reward >>=? fun ctxt ->
-          return (ctxt, Single_result (Double_endorsement_evidence_result [(* FIXME *)]))
+          return
+            (ctxt,
+             Single_result
+               (Double_endorsement_evidence_result [
+                   Rewards (baker, level.cycle), Credited reward;
+                   Rewards (delegate1, level.cycle), Debited balance.rewards;
+                   Deposits (delegate1, level.cycle), Debited balance.deposit;
+                   Fees (delegate1, level.cycle), Debited balance.fees
+                 ]))
       | _, _ -> fail Invalid_double_endorsement_evidence
     end
   | Single (Double_baking_evidence { bh1 ; bh2 }) ->
@@ -708,13 +735,22 @@ let apply_contents_list
       let delegate = Signature.Public_key.hash delegate1 in
       Delegate.has_frozen_balance ctxt delegate level.cycle >>=? fun valid ->
       fail_unless valid Unrequired_double_baking_evidence >>=? fun () ->
-      Delegate.punish ctxt delegate level.cycle >>=? fun (ctxt, burned) ->
+      Delegate.punish ctxt delegate level.cycle >>=? fun (ctxt, balance) ->
+      Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned ->
       let reward =
         match Tez.(burned /? 2L) with
         | Ok v -> v
         | Error _ -> Tez.zero in
       add_rewards ctxt reward >>=? fun ctxt ->
-      return (ctxt, Single_result (Double_baking_evidence_result [(* FIXME *)]))
+      return
+        (ctxt,
+         Single_result
+           (Double_baking_evidence_result [
+               Rewards (baker, level.cycle), Credited reward ;
+               Rewards (delegate, level.cycle), Debited balance.rewards ;
+               Deposits (delegate, level.cycle), Debited balance.deposit ;
+               Fees (delegate, level.cycle), Debited balance.fees ;
+             ]))
   | Single (Activate_account { id = pkh ; activation_code }) -> begin
       let blinded_pkh =
         Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in
@@ -722,8 +758,13 @@ let apply_contents_list
       | None -> fail (Invalid_activation { pkh })
       | Some amount ->
           Commitment.delete ctxt blinded_pkh >>=? fun ctxt ->
-          Contract.(credit ctxt (implicit_contract (Signature.Ed25519 pkh)) amount) >>=? fun ctxt ->
+          let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
-          return (ctxt, Single_result (Activate_account_result [(* FIXME *)]))
+          Contract.(credit ctxt contract amount) >>=? fun ctxt ->
+          return (ctxt, Single_result (
+              Activate_account_result
+                [
+                  Contract contract, Credited amount
+                ]))
     end
   | Single (Proposals { source ; period ; proposals }) ->
       Roll.delegate_pubkey ctxt source >>=? fun delegate ->
@@ -743,17 +784,17 @@ let apply_contents_list
       return (ctxt, Single_result Ballot_result)
   | Single (Manager_operation _) as op ->
       precheck_manager_contents_list ctxt operation op >>=? fun ctxt ->
-      apply_manager_contents_list ctxt mode op >>= fun (ctxt, result) ->
+      apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) ->
       return (ctxt, result)
   | Cons (Manager_operation _, _) as op ->
       precheck_manager_contents_list ctxt operation op >>=? fun ctxt ->
-      apply_manager_contents_list ctxt mode op >>= fun (ctxt, result) ->
+      apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) ->
       return (ctxt, result)
 
-let apply_operation ctxt mode pred_block hash operation =
+let apply_operation ctxt mode pred_block baker hash operation =
   let ctxt = Contract.init_origination_nonce ctxt hash in
   apply_contents_list
-    ctxt mode pred_block operation
+    ctxt mode pred_block baker operation
     operation.protocol_data.contents >>=? fun (ctxt, result) ->
   let ctxt = Gas.set_unlimited ctxt in
   let ctxt = Contract.set_storage_unlimited ctxt in

src/proto_alpha/lib_protocol/src/delegate_storage.ml

@@ -7,6 +7,22 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type frozen_balance = {
+  deposit : Tez_repr.t ;
+  fees : Tez_repr.t ;
+  rewards : Tez_repr.t ;
+}
+
+let frozen_balance_encoding =
+  let open Data_encoding in
+  conv
+    (fun { deposit ; fees ; rewards } -> (deposit, fees, rewards))
+    (fun (deposit, fees, rewards) -> { deposit ; fees ; rewards })
+    (obj3
+       (req "deposit" Tez_repr.encoding)
+       (req "fees" Tez_repr.encoding)
+       (req "rewards" Tez_repr.encoding))
+
 type error +=
   | Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
   | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
@@ -357,13 +373,14 @@ let punish ctxt delegate cycle =
   let contract = Contract_repr.implicit_contract delegate in
   get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
   get_frozen_fees ctxt contract cycle >>=? fun fees ->
+  get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
   Roll_storage.Delegate.remove_amount ctxt delegate deposit >>=? fun ctxt ->
   Roll_storage.Delegate.remove_amount ctxt delegate fees >>=? fun ctxt ->
+  (* Rewards are not in the delegate balnace yet... *)
   Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt ->
   Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt ->
   Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt ->
-  Lwt.return Tez_repr.(deposit +? fees) >>=? fun burned ->
+  return (ctxt, { deposit ; fees ; rewards })
-  return (ctxt, burned)
 
 
 let has_frozen_balance ctxt delegate cycle =
@@ -377,22 +394,6 @@ let has_frozen_balance ctxt delegate cycle =
       get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
       return Tez_repr.(rewards <> zero)
 
-type frozen_balance = {
-  deposit : Tez_repr.t ;
-  fees : Tez_repr.t ;
-  rewards : Tez_repr.t ;
-}
-
-let frozen_balance_encoding =
-  let open Data_encoding in
-  conv
-    (fun { deposit ; fees ; rewards } -> (deposit, fees, rewards))
-    (fun (deposit, fees, rewards) -> { deposit ; fees ; rewards })
-    (obj3
-       (req "deposit" Tez_repr.encoding)
-       (req "fees" Tez_repr.encoding)
-       (req "rewards" Tez_repr.encoding))
-
 let frozen_balance_by_cycle_encoding =
   let open Data_encoding in
   conv

src/proto_alpha/lib_protocol/src/delegate_storage.mli

@@ -7,6 +7,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type frozen_balance = {
+  deposit : Tez_repr.t ;
+  fees : Tez_repr.t ;
+  rewards : Tez_repr.t ;
+}
+
 (** Is the contract eligible to delegation ? *)
 val is_delegatable:
   Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
@@ -91,7 +97,7 @@ val cycle_end:
     cycle. Returns the burned amount. *)
 val punish:
   Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t ->
-  (Raw_context.t * Tez_repr.t) tzresult Lwt.t
+  (Raw_context.t * frozen_balance) tzresult Lwt.t
 
 (** Has the given key some frozen tokens in its implicit contract? *)
 val has_frozen_balance:
@@ -104,12 +110,6 @@ val frozen_balance:
   Raw_context.t -> Signature.Public_key_hash.t ->
   Tez_repr.t tzresult Lwt.t
 
-type frozen_balance = {
-  deposit : Tez_repr.t ;
-  fees : Tez_repr.t ;
-  rewards : Tez_repr.t ;
-}
-
 val frozen_balance_encoding: frozen_balance Data_encoding.t
 val frozen_balance_by_cycle_encoding:
   frozen_balance Cycle_repr.Map.t Data_encoding.t

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -227,18 +227,19 @@ module Scripts = struct
       let operation : _ operation = { shell ; protocol_data } in
       let hash = Operation.hash { shell ; protocol_data } in
       let ctxt = Contract.init_origination_nonce ctxt hash in
+      let baker = Signature.Public_key_hash.zero in
       match protocol_data.contents with
       | Single (Manager_operation _) as op ->
           partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
-          Apply.apply_manager_contents_list ctxt Readable op >>= fun (_ctxt, result) ->
+          Apply.apply_manager_contents_list ctxt Readable baker op >>= fun (_ctxt, result) ->
           return result
       | Cons (Manager_operation _, _) as op ->
           partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
-          Apply.apply_manager_contents_list ctxt Readable op >>= fun (_ctxt, result) ->
+          Apply.apply_manager_contents_list ctxt Readable baker op >>= fun (_ctxt, result) ->
           return result
       | _ ->
           Apply.apply_contents_list
-            ctxt Readable shell.branch operation
+            ctxt Readable shell.branch baker operation
             operation.protocol_data.contents >>=? fun (_ctxt, result) ->
           return result
 

src/proto_alpha/lib_protocol/src/main.ml

@@ -162,12 +162,21 @@ let apply_operation
         match mode with
         | Partial_application
             { block_header = { shell = { predecessor ; _ } ; _ } ; _ }
-        | Partial_construction { predecessor }
         | Application
             { block_header = { shell = { predecessor ; _ } ; _ } ; _ }
         | Full_construction { predecessor ; _ } ->
+            predecessor
+        | Partial_construction { predecessor } ->
             predecessor in
-      Apply.apply_operation ctxt Optimized predecessor
+      let baker =
+        match mode with
+        | Partial_application { baker ; _ }
+        | Application { baker ; _ }
+        | Full_construction { baker ; _ } ->
+            baker
+        | Partial_construction _ ->
+            Signature.Public_key_hash.zero in
+      Apply.apply_operation ctxt Optimized predecessor baker
         (Alpha_context.Operation.hash operation)
         operation >>=? fun (ctxt, result) ->
       let op_count = op_count + 1 in