Commit e7245511 authored by Jakob Botsch Nielsen's avatar Jakob Botsch Nielsen

Refactor to remove compute_block_reward

- No longer require that block reward can be computed from height.
- Remove Chain's dependence on BlockHeader. Instead inline appropriate
  fields in Chain structure.
- Change step_block to use a BlockHeader now instead of manually
  specifying all the fields. The new BlockHeader now additionally
  contains the creator and reward of that block, so step_block in effect
  contains the reward.
- These refactorings means that the circulation proof changes. Introduce
  created_blocks to get list of blocks created by user, and prove
  instead that the circulation equals the sum of rewards in blocks.
- Rename "baker" to a more general "creator" globally
parent 4ff6fa50
Pipeline #12836 failed with stage
in 6 minutes and 18 seconds
This diff is collapsed.
......@@ -101,11 +101,11 @@ Proof.
end.
Qed.
Lemma circulation_add_new_block header baker env :
circulation (add_new_block header baker env) =
(circulation env + compute_block_reward (block_height header))%Z.
Lemma circulation_add_new_block header env :
circulation (add_new_block_to_env header env) =
(circulation env + block_reward header)%Z.
Proof.
assert (Hperm: exists suf, Permutation ([baker] ++ suf) (elements Address)).
assert (Hperm: exists suf, Permutation ([block_creator header] ++ suf) (elements Address)).
{ apply NoDup_incl_reorganize; repeat constructor; unfold incl; auto. }
destruct Hperm as [suf perm].
symmetry in perm.
......@@ -119,12 +119,14 @@ Proof.
| [|- ?a + ?b + ?c = ?b + ?d + ?a] => enough (c = d) by lia
end.
pose proof (in_NoDup_app baker [baker] suf ltac:(intuition) perm_set) as not_in_suf.
pose proof (in_NoDup_app
(block_creator header)
[block_creator header] suf ltac:(intuition) perm_set) as not_in_suf.
clear perm perm_set.
induction suf as [| x xs IH]; auto.
cbn in *.
apply Decidable.not_or in not_in_suf.
destruct (address_eqb_spec x baker); try tauto.
destruct (address_eqb_spec x (block_creator header)); try tauto.
specialize (IH (proj2 not_in_suf)).
lia.
Qed.
......@@ -132,16 +134,12 @@ Qed.
Lemma step_circulation {prev next} (step : ChainStep prev next) :
circulation next =
match step with
| step_block _ _ _ _ =>
circulation prev + compute_block_reward (block_height (block_header next))
| step_block header _ _ _ _ =>
circulation prev + block_reward header
| _ => circulation prev
end%Z.
Proof.
destruct step;
repeat
match goal with
| [H: EnvironmentEquiv _ _ |- _] => rewrite H in *; clear H
end.
destruct_chain_step; try rewrite_environment_equiv.
- (* New block *)
now rewrite circulation_add_new_block.
- (* New action *)
......@@ -151,22 +149,19 @@ Proof.
Qed.
Theorem chain_trace_circulation
{state : ChainState} :
reachable state ->
circulation state =
sumZ compute_block_reward (seq 1 (block_height (block_header state))).
{state : ChainState}
(trace : ChainTrace empty_state state) :
circulation state = sumZ block_reward (trace_blocks trace).
Proof.
intros [trace].
remember empty_state as from eqn:eq.
induction trace as [| from mid to xs IH x]; rewrite eq in *; clear eq.
induction trace as [| from mid to xs IH x]; subst.
- unfold circulation.
induction (elements Address); auto.
- rewrite (step_circulation x).
destruct_chain_step.
+ rewrite_environment_equiv.
cbn.
rewrite (proj1 valid_header), IH, sumZ_seq_S; auto.
+ erewrite block_header_post_action; eauto.
+ intuition.
cbn.
destruct_chain_step; auto.
cbn.
rewrite <- IH by auto.
lia.
Qed.
End Circulation.
......@@ -220,7 +220,7 @@ Definition init
Definition add_proposal (actions : list CongressAction) (chain : Chain) (state : State) : State :=
let id := state.(next_proposal_id) in
let slot_num := chain.(block_header).(slot_number) in
let slot_num := chain.(current_slot) in
let proposal := {| actions := actions;
votes := FMap.empty;
vote_result := 0;
......@@ -285,7 +285,7 @@ Definition do_finish_proposal
do proposal <- FMap.find pid state.(proposals);
let rules := state.(state_rules) in
let debate_end := (proposal.(proposed_in) + rules.(debating_period_in_blocks))%nat in
let cur_slot := chain.(block_header).(slot_number) in
let cur_slot := chain.(current_slot) in
if (cur_slot <? debate_end)%nat then
None
else
......@@ -421,7 +421,7 @@ Qed.
Lemma num_outgoing_acts_block l contract :
address_is_contract contract = true ->
Forall ActIsFromAccount l ->
Forall act_is_from_account l ->
num_outgoing_acts l contract = 0.
Proof.
intros is_contract all.
......@@ -709,7 +709,7 @@ Local Ltac simpl_exp_invariant exp :=
| context G[filter ?f (?hd :: ?tl)] =>
let newexp := context G[filter f tl] in
replace exp with newexp by solve_single
| context G[add_new_block _ _ ?env] =>
| context G[add_new_block_to_env _ ?env] =>
let newexp := context G[env] in
replace exp with newexp by solve_single
| context G[transfer_balance _ _ _ ?env] =>
......@@ -855,13 +855,13 @@ Proof.
- (* Permute queue *)
unfold num_outgoing_acts.
cbn.
rewrite <- perm, prev_new in *; auto.
rewrite <- perm, prev_next in *; auto.
Qed.
Corollary congress_txs_after_block
{ChainBuilder : ChainBuilderType}
prev baker header acts new :
builder_add_block prev baker header acts = Some new ->
prev new header acts :
builder_add_block prev header acts = Some new ->
forall addr,
env_contracts new addr = Some (Congress.contract : WeakContract) ->
length (outgoing_txs (builder_trace new) addr) <=
......
......@@ -223,7 +223,7 @@ Definition init
Definition add_proposal (actions : list CongressAction) (chain : Chain) (state : State) : State :=
let id := state.(next_proposal_id) in
let slot_num := chain.(block_header).(slot_number) in
let slot_num := chain.(current_slot) in
let proposal := {| actions := actions;
votes := FMap.empty;
vote_result := 0;
......@@ -289,7 +289,7 @@ Definition do_finish_proposal
do proposal <- FMap.find pid state.(proposals);
let rules := state.(state_rules) in
let debate_end := (proposal.(proposed_in) + rules.(debating_period_in_blocks))%nat in
let cur_slot := chain.(block_header).(slot_number) in
let cur_slot := chain.(current_slot) in
if (cur_slot <? debate_end)%nat then
None
else
......@@ -355,8 +355,9 @@ Definition receive
end.
Ltac solve_contract_proper :=
repeat
match goal with
| _ => progress subst
| _ => solve [auto]
| [|- ?x _ = ?x _] => unfold x
| [|- ?x _ _ = ?x _ _] => unfold x
| [|- ?x _ _ _ = ?x _ _ _] => unfold x
......@@ -368,16 +369,15 @@ Ltac solve_contract_proper :=
| [|- (if ?x then _ else _) = (if ?x then _ else _)] => destruct x
| [|- match ?x with | _ => _ end = match ?x with | _ => _ end ] => destruct x
| [H: ChainEquiv _ _ |- _] => rewrite H in *
| _ => subst; auto
end.
Lemma init_proper :
Proper (ChainEquiv ==> eq ==> eq ==> eq) init.
Proof. repeat intro; solve_contract_proper. Qed.
Proof. repeat intro; repeat solve_contract_proper. Qed.
Lemma receive_proper :
Proper (ChainEquiv ==> eq ==> eq ==> eq ==> eq) receive.
Proof. repeat intro; solve_contract_proper. Qed.
Proof. repeat intro; repeat solve_contract_proper. Qed.
Definition contract : Contract Setup Msg State :=
build_contract init init_proper receive receive_proper.
......@@ -445,14 +445,18 @@ Section Theories.
sumnat count txs.
Definition exploit_example : option (Address * LocalChainBuilderDepthFirst) :=
let chain := builder_initial in
let baker := BoundedN.of_Z_const AddrSize 10 in
let chain := @builder_initial _ LocalChainBuilderDepthFirst in
let creator := BoundedN.of_Z_const AddrSize 10 in
let add_block (chain : LocalChainBuilderDepthFirst) act_bodies :=
let next_header :=
(block_header chain)<|block_height ::= S|><|slot_number ::= S|> in
let acts := map (build_act baker) act_bodies in
builder_add_block chain baker next_header acts in
(* Get some money on the baker *)
{| block_height := S (chain_height chain);
block_slot := S (current_slot chain);
block_finalized_height := finalized_height chain;
block_creator := creator;
block_reward := 50; |} in
let acts := map (build_act creator) act_bodies in
builder_add_block chain next_header acts in
(* Get some money on the creator *)
do chain <- add_block chain [];
(* Deploy congress and exploit contracts *)
let rules :=
......@@ -463,17 +467,17 @@ Section Theories.
let dep_exploit := create_deployment 0 exploit_contract tt in
do chain <- add_block chain [dep_congress; dep_exploit];
let contracts := map fst (FMap.elements (lc_contracts (lcb_lc chain))) in
let exploit := nth 0 contracts baker in
let congress := nth 1 contracts baker in
(* Add baker to congress, create a proposal to transfer *)
let exploit := nth 0 contracts creator in
let congress := nth 1 contracts creator in
(* Add creator to congress, create a proposal to transfer *)
(* some money to exploit contract, vote for the proposal, and execute the proposal *)
let add_baker := add_member baker in
let add_creator := add_member creator in
let create_proposal := create_proposal [cact_transfer exploit 1] in
let vote_proposal := vote_for_proposal 1 in
let exec_proposal := finish_proposal 1 in
let act_bodies :=
map (fun m => act_call congress 0 (serialize m))
[add_baker; create_proposal; vote_proposal; exec_proposal] in
[add_creator; create_proposal; vote_proposal; exec_proposal] in
do chain <- add_block chain act_bodies;
Some (congress, chain).
......
......@@ -28,13 +28,14 @@ Global Instance LocalChainBase : ChainBase :=
{| Address := BoundedN AddrSize;
address_eqb := BoundedN.eqb;
address_eqb_spec := BoundedN.eqb_spec;
compute_block_reward n := 50%Z;
address_is_contract a := (ContractAddrBase <=? BoundedN.to_N a)%N
|}.
Record LocalChain :=
build_local_chain {
lc_header : BlockHeader;
lc_height : nat;
lc_slot : nat;
lc_fin_height : nat;
lc_account_balances : FMap Address Amount;
lc_contract_state : FMap Address OakValue;
lc_contracts : FMap Address WeakContract;
......@@ -42,11 +43,14 @@ Record LocalChain :=
Instance local_chain_settable : Settable _ :=
settable! build_local_chain
<lc_header; lc_account_balances; lc_contract_state; lc_contracts>.
<lc_height; lc_slot; lc_fin_height;
lc_account_balances; lc_contract_state; lc_contracts>.
Definition lc_to_env (lc : LocalChain) : Environment :=
{| env_chain :=
{| block_header := lc_header lc;
{| chain_height := lc_height lc;
current_slot := lc_slot lc;
finalized_height := lc_fin_height lc;
account_balance a := with_default 0%Z (FMap.find a (lc_account_balances lc));
contract_state a := FMap.find a (lc_contract_state lc); |};
env_contracts a := FMap.find a (lc_contracts lc); |}.
......@@ -337,10 +341,9 @@ Section ExecuteActions.
End ExecuteActions.
Definition lc_initial : LocalChain :=
{| lc_header :=
{| block_height := 0;
slot_number := 0;
finalized_height := 0; |};
{| lc_height := 0;
lc_slot := 0;
lc_fin_height := 0;
lc_account_balances := FMap.empty;
lc_contract_state := FMap.empty;
lc_contracts := FMap.empty; |}.
......@@ -354,31 +357,32 @@ Record LocalChainBuilder :=
Definition lcb_initial : LocalChainBuilder :=
{| lcb_lc := lc_initial; lcb_trace := clnil |}.
Definition validate_header (new old : BlockHeader) : option unit :=
let (prev_block_height, prev_slot_number, prev_finalized_height) := old in
let (block_height, slot_number, finalized_height) := new in
if (block_height =? S prev_block_height)
&& (prev_slot_number <? slot_number)
&& (finalized_height <=? prev_block_height)
&& (prev_finalized_height <=? finalized_height)
Definition validate_header (header : BlockHeader) (chain : Chain) : option unit :=
if (block_height header =? S (chain_height chain))
&& (current_slot chain <? block_slot header)
&& (finalized_height chain <=? block_finalized_height header)
&& (block_finalized_height header <? block_height header)
&& (Bool.eqb (address_is_contract (block_creator header)) false)
&& (block_reward header >=? 0)%Z
then Some tt
else None.
Lemma validate_header_valid (new old : BlockHeader) :
validate_header new old = Some tt ->
IsValidNextBlock new old.
Lemma validate_header_valid header chain :
validate_header header chain = Some tt ->
IsValidNextBlock header chain.
Proof.
intros valid.
destruct new as [block_height slot_number fin_height];
destruct old as [prev_block_height prev_slot_number prev_fin_height].
unfold IsValidNextBlock.
simpl in *.
unfold validate_header in valid.
repeat
match goal with
(match goal with
| [H: context[Nat.eqb ?a ?b] |- _] => destruct (Nat.eqb_spec a b)
| [H: context[Nat.ltb ?a ?b] |- _] => destruct (Nat.ltb_spec a b)
| [H: context[Nat.leb ?a ?b] |- _] => destruct (Nat.leb_spec a b)
end; simpl in *; intuition.
| [H: context[Bool.eqb ?a ?b] |- _] => destruct (Bool.eqb_spec a b)
| [H: context[Z.geb ?a ?b] |- _] => destruct (Z.geb_spec a b)
end; [|repeat rewrite Bool.andb_false_r in valid; cbn in valid; congruence]).
apply build_is_valid_next_block; cbn; auto.
lia.
Qed.
Definition validate_actions (actions : list Action) : option unit :=
......@@ -388,7 +392,7 @@ Definition validate_actions (actions : list Action) : option unit :=
Lemma validate_actions_valid actions :
validate_actions actions = Some tt ->
Forall ActIsFromAccount actions.
Forall act_is_from_account actions.
Proof.
intros valid.
induction actions as [|x xs IH]; auto.
......@@ -402,19 +406,17 @@ Proof.
auto.
Qed.
Definition add_new_block
(header : BlockHeader)
(baker : Address)
(lc : LocalChain) : LocalChain :=
let lc := add_balance baker (compute_block_reward (block_height header)) lc in
let lc := lc<|lc_header := header|> in
lc.
Definition add_new_block (header : BlockHeader) (lc : LocalChain) : LocalChain :=
let lc := add_balance (block_creator header) (block_reward header) lc in
lc<|lc_height := block_height header|>
<|lc_slot := block_slot header|>
<|lc_fin_height := block_finalized_height header|>.
Lemma add_new_block_equiv header baker (lc : LocalChain) (env : Environment) :
Lemma add_new_block_equiv header (lc : LocalChain) (env : Environment) :
EnvironmentEquiv lc env ->
EnvironmentEquiv
(add_new_block header baker lc)
(Blockchain.add_new_block header baker env).
(add_new_block header lc)
(Blockchain.add_new_block_to_env header env).
Proof.
intros eq.
apply build_env_equiv; try apply eq.
......@@ -437,15 +439,14 @@ Qed.
Definition add_block
(depth_first : bool)
(lcb : LocalChainBuilder)
(baker : Address)
(header : BlockHeader)
(actions : list Action) : option LocalChainBuilder.
Proof.
set (lcopt :=
let lc := lcb_lc lcb in
do validate_header header (lc_header lc);
do validate_header header lc;
do validate_actions actions;
let lc := add_new_block header baker lc in
let lc := add_new_block header lc in
execute_actions 1000 actions lc depth_first).
destruct lcopt as [lc|] eqn:exec; [|exact None].
......
......@@ -13,7 +13,7 @@ Import ListNotations.
Section LocalBlockchainTests.
(* Addresses *)
Definition baker : Address :=
Definition creator : Address :=
BoundedN.of_Z_const AddrSize 10.
Definition person_1 : Address :=
......@@ -29,26 +29,28 @@ Section LocalBlockchainTests.
Definition chain1 : ChainBuilder := builder_initial.
Compute (block_header chain1).
Definition add_block (chain : ChainBuilder) acts : option ChainBuilder :=
let header :=
(block_header chain)<|block_height ::= S|><|slot_number ::= S|> in
builder_add_block chain baker header acts.
(* Baker mines an empty block (and gets some coins) *)
{| block_height := S (chain_height chain);
block_slot := S (current_slot chain);
block_finalized_height := finalized_height chain;
block_creator := creator;
block_reward := 50; |} in
builder_add_block chain header acts.
(* Creator created an empty block (and gets some coins) *)
Definition chain2 : ChainBuilder :=
unpack_option (add_block chain1 []).
Compute (account_balance chain2 person_1).
Compute (account_balance chain2 baker).
Compute (account_balance chain2 creator).
(* Baker transfers 10 coins to person_1 *)
(* Creator transfers 10 coins to person_1 *)
Definition chain3 : ChainBuilder :=
unpack_option (add_block chain2 [build_act baker (act_transfer person_1 10)]).
unpack_option (add_block chain2 [build_act creator (act_transfer person_1 10)]).
Compute (account_balance chain3 person_1).
Compute (account_balance chain3 baker).
Compute (account_balance chain3 creator).
(* person_1 deploys a Congress contract *)
Definition setup_rules :=
......@@ -71,7 +73,7 @@ Section LocalBlockchainTests.
end.
Compute (account_balance chain4 person_1).
Compute (account_balance chain4 baker).
Compute (account_balance chain4 creator).
Compute (account_balance chain4 congress_1).
Definition congress_ifc
......@@ -84,7 +86,7 @@ Section LocalBlockchainTests.
| None =>
@build_contract_interface
_ _ _
baker
creator
(fun c => None)
(fun a m => deploy_congress)
end.
......@@ -93,7 +95,7 @@ Section LocalBlockchainTests.
match congress_ifc.(get_state) chain with
| Some s => s
(* And also here *)
| None => {| owner := baker;
| None => {| owner := creator;
state_rules := setup_rules;
proposals := FMap.empty;
next_proposal_id := 0;
......@@ -155,8 +157,8 @@ End LocalBlockchainTests.
Hint Resolve congress_txs_after_block : core.
(* The congress satisfies a property specialized to the local blockchain DFS: *)
Lemma congress_txs_after_local_chain_block
(prev new : LocalChainBuilderDepthFirst) baker header acts :
builder_add_block prev baker header acts = Some new ->
(prev new : LocalChainBuilderDepthFirst) header acts :
builder_add_block prev header acts = Some new ->
forall addr,
env_contracts new addr = Some (Congress.contract : WeakContract) ->
length (outgoing_txs (builder_trace new) addr) <=
......@@ -164,8 +166,8 @@ Lemma congress_txs_after_local_chain_block
Proof. eauto. Qed.
(* And of course, it is satisfied for the breadth first chain as well. *)
Lemma congress_txs_after_local_chain_bf_block
(prev new : LocalChainBuilderBreadthFirst) baker header acts :
builder_add_block prev baker header acts = Some new ->
(prev new : LocalChainBuilderBreadthFirst) header acts :
builder_add_block prev header acts = Some new ->
forall addr,
env_contracts new addr = Some (Congress.contract : WeakContract) ->
length (outgoing_txs (builder_trace new) addr) <=
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment