Commit 7526b4eb authored by Jakob Botsch Nielsen's avatar Jakob Botsch Nielsen
Browse files

Lots of work

parent 99b27297
(* Copyright (c) 2008-2012, Adam Chlipala
*
* This work is licensed under a
* Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
* Unported License.
* The license text is available at:
* http://creativecommons.org/licenses/by-nc-nd/3.0/
*)
Require Import Eqdep List Omega Permutation.
Import ListNotations.
Set Implicit Arguments.
(** A version of [injection] that does some standard simplifications afterward: clear the hypothesis in question, bring the new facts above the double line, and attempt substitution for known variables. *)
Ltac inject H := injection H; clear H; intros; try subst.
(** Try calling tactic function [f] on all hypotheses, keeping the first application that doesn't fail. *)
Ltac appHyps f :=
match goal with
| [ H : _ |- _ ] => f H
end.
(** Succeed iff [x] is in the list [ls], represented with left-associated nested tuples. *)
Ltac inList x ls :=
match ls with
| x => idtac
| (_, x) => idtac
| (?LS, _) => inList x LS
end.
(** Try calling tactic function [f] on every element of tupled list [ls], keeping the first call not to fail. *)
Ltac app f ls :=
match ls with
| (?LS, ?X) => f X || app f LS || fail 1
| _ => f ls
end.
(** Run [f] on every element of [ls], not just the first that doesn't fail. *)
Ltac all f ls :=
match ls with
| (?LS, ?X) => f X; all f LS
| (_, _) => fail 1
| _ => f ls
end.
(** Workhorse tactic to simplify hypotheses for a variety of proofs.
* Argument [invOne] is a tuple-list of predicates for which we always do inversion automatically. *)
Ltac simplHyp invOne :=
(** Helper function to do inversion on certain hypotheses, where [H] is the hypothesis and [F] its head symbol *)
let invert H F :=
(** We only proceed for those predicates in [invOne]. *)
inList F invOne;
(** This case covers an inversion that succeeds immediately, meaning no constructors of [F] applied. *)
(inversion H; fail)
(** Otherwise, we only proceed if inversion eliminates all but one constructor case. *)
|| (inversion H; [idtac]; clear H; try subst) in
match goal with
(** Eliminate all existential hypotheses. *)
| [ H : ex _ |- _ ] => destruct H
(** Find opportunities to take advantage of injectivity of data constructors, for several different arities. *)
| [ H : ?F ?X = ?F ?Y |- ?G ] =>
(** This first branch of the [||] fails the whole attempt iff the arguments of the constructor applications are already easy to prove equal. *)
(assert (X = Y); [ assumption | fail 1 ])
(** If we pass that filter, then we use injection on [H] and do some simplification as in [inject].
* The odd-looking check of the goal form is to avoid cases where [injection] gives a more complex result because of dependent typing, which we aren't equipped to handle here. *)
|| (injection H;
match goal with
| [ |- X = Y -> G ] =>
try clear H; intros; try subst
end)
| [ H : ?F ?X ?U = ?F ?Y ?V |- ?G ] =>
(assert (X = Y); [ assumption
| assert (U = V); [ assumption | fail 1 ] ])
|| (injection H;
match goal with
| [ |- U = V -> X = Y -> G ] =>
try clear H; intros; try subst
end)
(** Consider some different arities of a predicate [F] in a hypothesis that we might want to invert. *)
| [ H : ?F _ |- _ ] => invert H F
| [ H : ?F _ _ |- _ ] => invert H F
| [ H : ?F _ _ _ |- _ ] => invert H F
| [ H : ?F _ _ _ _ |- _ ] => invert H F
| [ H : ?F _ _ _ _ _ |- _ ] => invert H F
| [ H : Some _ = Some _ |- _ ] => injection H; clear H
end.
(** Find some hypothesis to rewrite with, ensuring that [auto] proves all of the extra subgoals added by [rewrite]. *)
Ltac rewriteHyp :=
match goal with
| [ H : _ |- _ ] => rewrite H by solve [ auto ]
end.
(** Combine [autorewrite] with automatic hypothesis rewrites. *)
Ltac rewriterP := repeat (rewriteHyp; autorewrite with core in *).
Ltac rewriter := autorewrite with core in *; rewriterP.
Hint Rewrite app_ass.
Hint Rewrite app_comm_cons.
Ltac prove' invOne :=
let sintuition :=
simpl in *; intuition auto; try subst;
repeat (simplHyp invOne; intuition auto; try subst); try congruence in
let rewriter := autorewrite with core in *;
repeat (match goal with
| [ H : ?P |- _ ] => rewrite H by prove' invOne
end; autorewrite with core in *) in
do 3 (sintuition; autounfold; rewriter); try omega; try (elimtype False; omega).
Ltac prove := prove' fail.
Hint Rewrite <- Permutation_middle.
Lemma Permutation_app_middle {A : Type} (xs l1 l2 l3 l4 : list A) :
Permutation (l1 ++ l2) (l3 ++ l4) ->
Permutation (l1 ++ (xs ++ l2)) (l3 ++ (xs ++ l4)).
Proof.
intros perm.
induction xs as [| x xs IH]; prove.
Qed.
(* Change all x :: l into [x] ++ l *)
Ltac appify :=
match goal with
| [|- context[?e :: ?l]] =>
match l with
| nil => fail 1
| _ => change (e :: l) with ([e] ++ l)
end
end.
Local Ltac reassoc_right :=
match goal with
| [|- Permutation _ (?l1 ++ ?l2 ++ ?l3)] => rewrite (app_assoc l1 l2 l3)
| _ => fail 1
end.
Local Ltac reassoc_left :=
match goal with
| [|- Permutation (?l1 ++ ?l2 ++ ?l3) _] => rewrite (app_assoc l1 l2 l3)
| _ => fail 1
end.
Local Ltac unassoc_right :=
repeat
match goal with
| [|- Permutation _ ((?l1 ++ ?l2) ++ ?l3)] => rewrite <- (app_assoc l1 l2 l3)
end.
Local Ltac simplify_perm_once :=
let rec aux :=
apply Permutation_app_middle ||
(tryif reassoc_right
then aux
else (unassoc_right; reassoc_left; aux)) in
repeat rewrite <- app_assoc;
aux.
Local Ltac simplify_perm_round :=
simpl;
repeat appify;
(* Change into [] ++ l ++ [] *)
match goal with
| [|- Permutation ?l1 ?l2] => change l1 with ([] ++ l1);
change l2 with ([] ++ l2);
rewrite <- (app_nil_r l1), <- (app_nil_r l2)
end;
repeat simplify_perm_once;
simpl;
repeat rewrite <- app_assoc;
repeat rewrite app_nil_r;
repeat
match goal with
| [H: Permutation ?l1 ?l2|-_] => rewrite H
end.
Ltac simplify_perm :=
repeat simplify_perm_round;
simpl;
try apply Permutation_refl.
From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import PeanoNat.
From Coq Require Import Psatz.
From Coq Require Import Permutation.
From SmartContracts Require Import Oak.
From SmartContracts Require Import Monads.
From SmartContracts Require Import Extras.
From SmartContracts Require Import Automation.
Import ListNotations.
Definition Address := nat.
Delimit Scope address_scope with address.
Bind Scope address_scope with Address.
Module Address.
Definition eqb := Nat.eqb.
Definition eq_dec := Nat.eq_dec.
End Address.
Infix "=?" := Address.eqb (at level 70) : address_scope.
Definition Amount := nat.
Definition Amount := Z.
Definition BlockId := nat.
Definition Version := nat.
Open Scope Z.
(*Set Primitive Projections.*)
Record ContractDeployment :=
build_contract_deployment {
deployment_version : Version;
(* todo: model any type/constraints so we can have this. Right now the
problem is that Congress messages can contain _any_ oak value (for
the congress to send out), so there is no bijection from its message type
to oak type.
to oak type.
deployment_msg_ty : OakType;
deployment_state_ty : OakType; *)
deployment_setup : OakValue;
......@@ -53,68 +65,106 @@ Record Block :=
block_txs : list Tx;
}.
(* The ChainInterface is an interface that allows different implementations
of chains. This represents the view of the blockchain that a contract
can access and interact with. This does not contain all information of
the chain (and it can't for positivity reasons).
*)
Record ChainInterface :=
build_chain_interface {
(* Would be nice to encapsulate ChainInterface somewhat here
and avoid these ugly prefixed names *)
ci_type : Type;
ci_chain_at : ci_type -> BlockId -> option ci_type;
(* Last finished block. During contract execution, this is the previous
block, i.e. this block does _not_ contain the transaction that caused
the contract to be called *)
ci_head_block : ci_type -> Block;
ci_incoming_txs : ci_type -> Address -> list Tx;
ci_outgoing_txs : ci_type -> Address -> list Tx;
ci_contract_state : ci_type -> Address -> option OakValue;
}.
(* An actual chain interface together with a value of the chain.
For example, one obvious chain implementation could be as a list
of blocks and some operations on such a list. Then, the value is
simply the list of blocks.
This avoids having to either
1. Import an actual instance of ChainInterface when taking a chain, or
2. Abstracting over any implementation of ChainInterface when taking
a chain. *)
Record Chain :=
build_chain {
chain_ci : ChainInterface;
chain_val : chain_ci.(ci_type);
}.
Section ChainAccessors.
Context (chain : Chain).
Let g {A : Type} (p : forall chain : ChainInterface, ci_type chain -> A)
:= p chain.(chain_ci) chain.(chain_val).
Definition chain_at (bid : BlockId) : option Chain :=
do x <- chain.(chain_ci).(ci_chain_at) chain.(chain_val) bid;
Some {| chain_val := x |}.
Definition head_block := g ci_head_block.
Definition incoming_txs := g ci_incoming_txs.
Definition outgoing_txs := g ci_outgoing_txs.
Definition contract_state := g ci_contract_state.
Definition account_balance (addr : Address) : Amount :=
let sum := fold_right Nat.add 0 in
let sum_amounts txs := sum (map tx_amount txs) in
sum_amounts (incoming_txs addr) - sum_amounts (outgoing_txs addr).
Definition contract_deployment (addr : Address) : option ContractDeployment :=
let to_dep tx := match tx.(tx_body) with
| tx_deploy dep => Some dep
| _ => None
end in
find_first to_dep (incoming_txs addr).
End ChainAccessors.
Module Chain.
(* The ChainInterface is an interface that allows different implementations
of chains. This represents the view of the blockchain that a contract
can access and interact with. This does not contain all information of
the chain (and it can't for positivity reasons).
*)
Record ChainInterface :=
build_chain_interface {
type : Type;
chain_at : type -> BlockId -> option type;
(* Last finished block. During contract execution, this is the previous
block, i.e. this block does _not_ contain the transaction that caused
the contract to be called *)
head_block : type -> Block;
incoming_txs : type -> Address -> list Tx;
outgoing_txs : type -> Address -> list Tx;
contract_state : type -> Address -> option OakValue;
valid_address : type -> Address -> Prop;
no_incoming_txs
(t : type) (a : Address) : ~valid_address t a -> incoming_txs t a = [];
no_outgoing_txs
(t : type) (a : Address) : ~valid_address t a -> outgoing_txs t a = [];
no_contract_state
(t : type) (a : Address) : ~valid_address t a -> contract_state t a = None;
}.
(* An actual chain interface together with a value of the chain.
For example, one obvious chain implementation could be as a list
of blocks and some operations on such a list. Then, the value is
simply the list of blocks.
This avoids having to either
1. Import an actual instance of ChainInterface when taking a chain, or
2. Abstracting over any implementation of ChainInterface when taking
a chain. *)
Record Chain :=
build_chain {
ifc : ChainInterface;
val : ifc.(type);
}.
Module Exports.
Notation Chain := Chain.
Section Accessors.
Context (chain : Chain).
Let g {A : Type} (p : forall chain : ChainInterface, type chain -> A)
:= p chain.(ifc) chain.(val).
Definition chain_at (bid : BlockId) : option Chain :=
do x <- chain.(ifc).(chain_at) chain.(val) bid;
Some {| val := x |}.
Definition head_block := g head_block.
Definition incoming_txs := g incoming_txs.
Definition outgoing_txs := g outgoing_txs.
Definition contract_state := g contract_state.
Definition valid_address := g valid_address.
Lemma no_incoming_txs (a : Address) :
~valid_address a -> incoming_txs a = [].
Proof.
unfold valid_address, incoming_txs, g;
destruct chain as [ifc val];
destruct ifc; prove.
Qed.
Lemma no_outgoing_txs (a : Address) :
~valid_address a -> outgoing_txs a = [].
Proof.
unfold valid_address, outgoing_txs, g;
destruct chain as [ifc val];
destruct ifc; prove.
Qed.
Lemma no_contract_state (a : Address) :
~valid_address a -> contract_state a = None.
Proof.
unfold valid_address, contract_state, g;
destruct chain as [ifc val];
destruct ifc; prove.
Qed.
Definition account_balance (addr : Address) : Amount :=
let sum_amounts txs := sumZ tx_amount txs in
sum_amounts (incoming_txs addr) - sum_amounts (outgoing_txs addr).
Definition contract_deployment (addr : Address) : option ContractDeployment :=
let to_dep tx := match tx.(tx_body) with
| tx_deploy dep => Some dep
| _ => None
end in
find_first to_dep (incoming_txs addr).
End Accessors.
End Exports.
End Chain.
Export Chain.Exports.
Inductive ContractCallContext :=
build_contract_call_ctx {
build_ctx {
(* Chain *)
ctx_chain : Chain;
(* Address sending the funds *)
......@@ -125,8 +175,9 @@ Inductive ContractCallContext :=
ctx_amount : Amount;
}.
(* Operations that a contract can return that allows it to perform
different actions as a result of its execution. *)
(* Operations that a contract can return or that a user can use
to interact with a chain. This is also called an external action.
It is less specified than the internal action that will be defined later. *)
Inductive ChainAction :=
| act_transfer (to : Address) (amount : Amount)
| act_call (to : Address) (amount : Amount) (msg : OakValue)
......@@ -152,6 +203,15 @@ with WeakContract :=
option OakValue (* message *) ->
option (OakValue * list ChainAction)).
Definition wc_version (wc : WeakContract) : Version :=
let (v, _, _) := wc in v.
Definition wc_init (wc : WeakContract) :=
let (_, i, _) := wc in i.
Definition wc_receive (wc : WeakContract) :=
let (_, _, r) := wc in r.
(* Represents a strongly-typed contract. This is what user's will primarily
use and interact with when they want deployment. We keep the weak contract
only "internally" for blockchains, while any strongly-typed contract can
......@@ -213,7 +273,7 @@ Definition create_deployment
(* The contract interface is the main mechanism allowing a deployed
contract to interact with another deployed contract. This hides
the ugly details everything being OakValue away from contracts. *)
the ugly details of everything being OakValue away from contracts. *)
Record ContractInterface {setup_ty msg_ty state_ty : Type} :=
build_contract_interface {
(* The address of the contract being interfaced with *)
......@@ -254,35 +314,303 @@ Definition get_contract_interface
transfer := ifc_transfer;
call := ifc_call; |}.
(* TODO: Is there a more organic way of doing this than duplicating the
structures? Maybe by abstracting over the details or something? This is
super ugly.*)
Inductive FullTxBody :=
| ftx_empty
| ftx_deploy (contract : WeakContract) (setup : OakValue)
| ftx_call (message : OakValue).
Record FullTx :=
build_ftx {
ftx_from : Address;
ftx_to : Address;
ftx_amount : Amount;
ftx_body : FullTxBody;
ftx_is_internal : bool;
(* An internal action is like an external action, except it is more specified.
As an example, in an external action, when a contract is deployed no "to" address
is specified. This address is computed by the implementation. OTOH, in the internal
action, this _is_ specified.
As another example, in internal actions, empty actions are not allowed to contracts
and must instead be calls with no message. *)
Inductive InternalActionBody :=
| iact_empty
| iact_deploy (wc : WeakContract) (setup : OakValue)
| iact_call (msg : option OakValue).
Record InternalAction :=
build_internal_action {
iact_from : Address;
iact_to : Address;
iact_amount : Amount;
iact_body : InternalActionBody;
}.
Definition full_tx_to_tx (ftx : FullTx) : Tx :=
let (from, to, amount, fbody, _) := ftx in
let body :=
match fbody with
| ftx_empty => tx_empty
| ftx_deploy (build_weak_contract ver _ _) setup =>
Record Environment :=
build_environment {
env_chain : Chain;
env_contracts : Address -> option WeakContract;
}.
Definition iact_to_tx (act : InternalAction) : Tx :=
let (from, to, amount, body) := act in
let tx_body :=
match body with
| iact_empty => tx_empty
| iact_deploy (build_weak_contract ver _ _) setup =>
tx_deploy (build_contract_deployment ver setup)
| ftx_call msg => tx_call msg
| iact_call None => tx_empty
| iact_call (Some msg) => tx_call msg
end in
build_tx from to amount body.
Coercion full_tx_to_tx : FullTx >-> Tx.
build_tx from to amount tx_body.
Local Coercion iact_to_tx : InternalAction >-> Tx.
Local Coercion env_chain : Environment >-> Chain.
Section Transfer.
Context {action : InternalAction} {pre post : Environment}.
Let from := iact_from action.
Let to := iact_to action.
Let amount := iact_amount action.
Let body := iact_body action.
Let ctx := {| ctx_chain := pre;
ctx_from := from;
ctx_contract_address := to;
ctx_amount := amount; |}.
Record EmptyTransfer : Prop :=
build_empty_transfer {
empty_contracts_pre_to : env_contracts pre to = None;
empty_contracts_post : env_contracts post = env_contracts pre;
empty_contract_state_post : contract_state post = contract_state pre;
}.
Record DeployTransfer (wc : WeakContract) (setup : OakValue) : Prop :=
build_deploy_transfer {
deploy_incoming_txs_pre_to : incoming_txs pre to = [];
deploy_contracts_pre_to : env_contracts pre to = None;
deploy_contracts_post_to : env_contracts post to = Some wc;
deploy_contracts_post : forall a, a <> to -> env_contracts post a = env_contracts pre a;
deploy_state :
exists (s : OakValue), wc.(wc_init) ctx setup = Some s /\
contract_state post to = Some s;
deploy_contract_state_post_to :
forall a, a <> to -> contract_state post to = contract_state pre to;
}.
Record CallTransfer (msg : option OakValue) : Prop :=
build_call_transfer {
call_contracts_post : env_contracts post = env_contracts pre;
call_state :
exists (wc : WeakContract)
(prev_state new_state : OakValue)
(acts : list ChainAction),
env_contracts pre to = Some wc /\
contract_state pre to = Some prev_state /\
wc.(wc_receive) ctx prev_state msg = Some (new_state, acts) /\
contract_state post to = Some new_state;
call_contract_state_post_to :
forall a, a <> to -> contract_state post to = contract_state pre to;
}.
Record Transfer : Prop :=
build_transfer {
from_neq_to : from <> to;
valid_address_from : valid_address pre from;
valid_address_to : valid_address pre to;
amount_nonnegative : amount >= 0;
valid_address_post : valid_address post = valid_address pre;
head_block_post : head_block post = head_block pre;
account_balance_pre_from : account_balance pre from >= amount;
account_balance_post_to : account_balance post to >= amount;
incoming_txs_post_to :
incoming_txs post to = (action : Tx) :: incoming_txs pre to;
outgoing_txs_post_from :
outgoing_txs post from = (action : Tx) :: outgoing_txs pre from;
incoming_txs_post :
forall a, a <> to -> incoming_txs post a = incoming_txs pre a;
outgoing_txs_post :
forall a, a <> from -> outgoing_txs post a = outgoing_txs pre a;
body_transfer : match body with
| iact_empty => EmptyTransfer
| iact_deploy wc setup => DeployTransfer wc setup
| iact_call msg => CallTransfer msg
end;
}.
End Transfer.
Arguments Transfer : clear implicits.
Arguments EmptyTransfer : clear implicits.
Arguments CallTransfer : clear implicits.
Arguments DeployTransfer : clear implicits.
(* Proposition for whether an internal action actually reflects an external action. *)
Definition action_properly_reflected
(ext_from : Address)
(ext : ChainAction)
(iact : InternalAction) : Prop :=
let (iact_from, iact_to, iact_amount, iact_body) := iact in
iact_from = ext_from /\
match iact_body, ext with
| iact_empty, act_transfer ext_to ext_amount
| iact_call None, act_transfer ext_to ext_amount =>
iact_to = ext_to /\ iact_amount = ext_amount
| iact_deploy iact_wc iact_setup, act_deploy ext_amount ext_wc ext_setup =>
iact_amount = ext_amount /\ iact_wc = ext_wc /\ iact_setup = ext_setup
| iact_call (Some iact_msg), act_call ext_to ext_amount ext_msg =>