├── .gitattributes ├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── LICENSE.md ├── Makefile ├── Makefile.coq.local ├── README.md ├── _CoqProject ├── coq-algorand.opam ├── dune-project ├── meta.yml ├── resources ├── index.md └── pdf-icon.png └── theories ├── algorand_model.v ├── dune ├── fmap_ext.v ├── liveness.v ├── quorums.v ├── safety.v └── safety_helpers.v /.gitattributes: -------------------------------------------------------------------------------- 1 | report/ export-ignore 2 | -------------------------------------------------------------------------------- /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp:1.15.0-coq-8.16' 21 | - 'mathcomp/mathcomp:1.15.0-coq-8.15' 22 | - 'mathcomp/mathcomp:1.14.0-coq-8.15' 23 | - 'mathcomp/mathcomp:1.14.0-coq-8.14' 24 | fail-fast: false 25 | steps: 26 | - uses: actions/checkout@v3 27 | - uses: coq-community/docker-coq-action@v1 28 | with: 29 | opam_file: 'coq-algorand.opam' 30 | custom_image: ${{ matrix.image }} 31 | 32 | 33 | # See also: 34 | # https://github.com/coq-community/docker-coq-action#readme 35 | # https://github.com/erikmd/docker-coq-github-action-demo 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.DS_Store 2 | .*.aux 3 | *.a 4 | *.cma 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxa 9 | *.cmxs 10 | *.glob 11 | *.d 12 | *.native 13 | *.o 14 | *.vio 15 | *.vo 16 | *.vos 17 | *.vok 18 | build/ 19 | .coq-native/ 20 | .csdp.cache 21 | .lia.cache 22 | .nia.cache 23 | .nlia.cache 24 | .nra.cache 25 | csdp.cache 26 | lia.cache 27 | nia.cache 28 | nlia.cache 29 | nra.cache 30 | Makefile.coq 31 | Makefile.coq.conf 32 | _build 33 | docs 34 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 Algorand verification team. All Rights Reserved. 2 | 3 | Developed by: 4 | 5 | Runtime Verification, Inc. 6 | The University of Texas at Austin 7 | 8 | University of Illinois/NCSA 9 | Open Source License 10 | 11 | Permission is hereby granted, free of charge, to any person obtaining a copy of 12 | this software and associated documentation files (the "Software"), to deal with 13 | the Software without restriction, including without limitation the rights to 14 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 15 | of the Software, and to permit persons to whom the Software is furnished to do 16 | so, subject to the following conditions: 17 | 18 | * Redistributions of source code must retain the above copyright notice, 19 | this list of conditions and the following disclaimers. 20 | 21 | * Redistributions in binary form must reproduce the above copyright notice, 22 | this list of conditions and the following disclaimers in the 23 | documentation and/or other materials provided with the distribution. 24 | 25 | * Neither the names of the Algorand verification team, The University of Texas at Austin, 26 | Runtime Verification, Inc., nor the names of 27 | its contributors may be used to endorse or promote products derived from 28 | this Software without specific prior written permission. 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 31 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 32 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 33 | CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 34 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 35 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE 36 | SOFTWARE. 37 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | @+$(MAKE) -f Makefile.coq all 3 | 4 | clean: Makefile.coq 5 | @+$(MAKE) -f Makefile.coq cleanall 6 | @rm -f Makefile.coq Makefile.coq.conf 7 | 8 | Makefile.coq: _CoqProject 9 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 10 | 11 | force _CoqProject Makefile: ; 12 | 13 | %: Makefile.coq force 14 | @+$(MAKE) -f Makefile.coq $@ 15 | 16 | .PHONY: all clean force 17 | -------------------------------------------------------------------------------- /Makefile.coq.local: -------------------------------------------------------------------------------- 1 | GLOBFILES = $(VFILES:.v=.glob) 2 | COQ2HTML = coq2html 3 | COQ2HTMLDIR = docs/coq2html 4 | COQ2HTMLFLAGS = -base Algorand -external https://math-comp.github.io/htmldoc/ mathcomp 5 | 6 | coq2html: $(GLOBFILES) $(VFILES) 7 | $(SHOW)'COQ2HTML -d $(COQ2HTMLDIR)' 8 | $(HIDE)mkdir -p $(COQ2HTMLDIR) 9 | $(HIDE)cd theories && $(COQ2HTML) $(COQ2HTMLFLAGS) -d ../$(COQ2HTMLDIR) *.v *.glob 10 | .PHONY: coq2html 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Algorand Verification 2 | 3 | [![Docker CI][docker-action-shield]][docker-action-link] 4 | 5 | [docker-action-shield]: https://github.com/runtimeverification/algorand-verification/workflows/Docker%20CI/badge.svg?branch=master 6 | [docker-action-link]: https://github.com/runtimeverification/algorand-verification/actions?query=workflow:"Docker%20CI" 7 | 8 | 9 | 10 | 11 | The Algorand consensus protocol is the foundation of a decentralized 12 | digital currency and transactions platform. This project provides a 13 | model of the protocol in Coq, expressed as a transition system over 14 | global states in a message-passing distributed system. Included is 15 | a formal proof of safety for the transition system. 16 | 17 | ## Meta 18 | 19 | - License: [University of Illinois/NCSA Open Source License](LICENSE.md) 20 | - Compatible Coq versions: 8.14 or later 21 | - Additional dependencies: 22 | - [MathComp ssreflect 1.14.0 or later](https://math-comp.github.io) 23 | - [MathComp algebra](https://math-comp.github.io) 24 | - [MathComp finmap 1.5.1 or later](https://github.com/math-comp/finmap) 25 | - [MathComp analysis 0.5.0 or later](https://github.com/math-comp/analysis) 26 | - [Mczify](https://github.com/math-comp/mczify) 27 | - [Coq record update](https://github.com/tchajed/coq-record-update) 28 | - Coq namespace: `Algorand` 29 | - Related publication(s): 30 | - [Towards a Verified Model of the Algorand Consensus Protocol in Coq](https://arxiv.org/abs/1907.05523) doi:[10.1007/978-3-030-54994-7_27](https://doi.org/10.1007/978-3-030-54994-7_27) 31 | 32 | ## Building 33 | 34 | We recommend installing the dependencies of the project via 35 | [opam](http://opam.ocaml.org/doc/Install.html), for example: 36 | ```shell 37 | opam repo add coq-released https://coq.inria.fr/opam/released 38 | opam install coq.8.16.0 coq-mathcomp-ssreflect.1.15.0 \ 39 | coq-mathcomp-algebra coq-mathcomp-finmap.1.5.2 \ 40 | coq-mathcomp-analysis.0.5.4 coq-mathcomp-zify coq-record-update 41 | ``` 42 | 43 | Then, run `make` in the project root directory. This will check all the definitions and proofs. 44 | 45 | ## Contents 46 | 47 | The project includes: 48 | - an abstract and timed specification in Coq of the Algorand consensus protocol as a transition system, including node-level behavior, asynchronous messaging and a model of the adversary, 49 | - a **complete** formal proof of _asynchronous safety_ for the transition system. 50 | 51 | For more details on the formalization, see the report: 52 | 53 | PDF *[Modeling and Verification of the Algorand Consensus Protocol](https://github.com/runtimeverification/algorand-verification/blob/master/report/report.pdf)* 54 | 55 | Statements of some _liveness_ properties for the transition system are also provided, but these are work-in-progress and their proofs are currently **incomplete**. 56 | 57 | All Coq source files can be found under the `theories` directory, and their content is as follows: 58 | 59 | - `fmap_ext.v`: auxiliary definitions and results on finite maps 60 | - `algorand_model.v`: definition of the Algorand local state, global state, and transition system, along with helper functions and facts 61 | - `safety_helpers.v`: helper functions and lemmas used when proving safety of the transition system 62 | - `quorums.v`: definitions and hypotheses about quorums of nodes 63 | - `safety.v`: statement and complete formal proof of safety for the transition system 64 | - `liveness.v`: an initial attempt at specifying liveness properties for the transition system. This part is work-in-progress and thus the file contains incomplete (admitted) proofs. 65 | 66 | ## Help and Feedback 67 | 68 | Feel free to report GitHub issues or to contact us at: contact@runtimeverification.com 69 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q theories Algorand 2 | 3 | -arg -w -arg -notation-overridden 4 | 5 | theories/fmap_ext.v 6 | theories/algorand_model.v 7 | theories/safety_helpers.v 8 | theories/quorums.v 9 | theories/safety.v 10 | -------------------------------------------------------------------------------- /coq-algorand.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "palmskog@gmail.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/runtimeverification/algorand-verification" 6 | dev-repo: "git+https://github.com/runtimeverification/algorand-verification.git" 7 | bug-reports: "https://github.com/runtimeverification/algorand-verification/issues" 8 | license: "NCSA" 9 | 10 | synopsis: "A verified model of the Algorand consensus protocol in Coq" 11 | description: """ 12 | The Algorand consensus protocol is the foundation of a decentralized 13 | digital currency and transactions platform. This project provides a 14 | model of the protocol in Coq, expressed as a transition system over 15 | global states in a message-passing distributed system. Included is 16 | a formal proof of safety for the transition system.""" 17 | 18 | build: ["dune" "build" "-p" name "-j" jobs] 19 | depends: [ 20 | "dune" {>= "2.5"} 21 | "coq" {>= "8.14"} 22 | "coq-mathcomp-ssreflect" {>= "1.14"} 23 | "coq-mathcomp-algebra" 24 | "coq-mathcomp-finmap" {>= "1.5.1"} 25 | "coq-mathcomp-analysis" {>= "0.5.0"} 26 | "coq-mathcomp-zify" 27 | "coq-record-update" 28 | ] 29 | 30 | tags: [ 31 | "category:Computer Science/Concurrent Systems and Protocols/Theory of concurrent systems" 32 | "keyword:distributed algorithms" 33 | "keyword:blockchain" 34 | "keyword:consensus" 35 | "keyword:algorand" 36 | "logpath:Algorand" 37 | ] 38 | authors: [ 39 | "Musab A. Alturki" 40 | "Jing Chen" 41 | "Victor Luchangco" 42 | "Brandon Moore" 43 | "Karl Palmskog" 44 | "Lucas Peña" 45 | "Grigore Roșu" 46 | ] 47 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.5) 2 | (using coq 0.2) 3 | (name algorand) 4 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: Algorand Verification 3 | shortname: algorand-verification 4 | opam_name: coq-algorand 5 | organization: runtimeverification 6 | community: false 7 | dune: true 8 | action: true 9 | 10 | synopsis: A verified model of the Algorand consensus protocol in Coq 11 | 12 | description: |- 13 | The Algorand consensus protocol is the foundation of a decentralized 14 | digital currency and transactions platform. This project provides a 15 | model of the protocol in Coq, expressed as a transition system over 16 | global states in a message-passing distributed system. Included is 17 | a formal proof of safety for the transition system. 18 | 19 | publications: 20 | - pub_url: https://arxiv.org/abs/1907.05523 21 | pub_doi: 10.1007/978-3-030-54994-7_27 22 | pub_title: Towards a Verified Model of the Algorand Consensus Protocol in Coq 23 | 24 | authors: 25 | - name: Musab A. Alturki 26 | - name: Jing Chen 27 | - name: Victor Luchangco 28 | - name: Brandon Moore 29 | - name: Karl Palmskog 30 | - name: Lucas Peña 31 | - name: Grigore Roșu 32 | 33 | opam-file-maintainer: palmskog@gmail.com 34 | 35 | opam-file-version: dev 36 | 37 | license: 38 | fullname: University of Illinois/NCSA Open Source License 39 | identifier: NCSA 40 | file: LICENSE.md 41 | 42 | supported_coq_versions: 43 | text: '8.14 or later' 44 | opam: '{>= "8.14"}' 45 | 46 | tested_coq_opam_versions: 47 | - version: '1.15.0-coq-8.16' 48 | repo: 'mathcomp/mathcomp' 49 | - version: '1.15.0-coq-8.15' 50 | repo: 'mathcomp/mathcomp' 51 | - version: '1.14.0-coq-8.15' 52 | repo: 'mathcomp/mathcomp' 53 | - version: '1.14.0-coq-8.14' 54 | repo: 'mathcomp/mathcomp' 55 | 56 | dependencies: 57 | - opam: 58 | name: coq-mathcomp-ssreflect 59 | version: '{>= "1.14"}' 60 | description: |- 61 | [MathComp ssreflect 1.14.0 or later](https://math-comp.github.io) 62 | - opam: 63 | name: coq-mathcomp-algebra 64 | description: |- 65 | [MathComp algebra](https://math-comp.github.io) 66 | - opam: 67 | name: coq-mathcomp-finmap 68 | version: '{>= "1.5.1"}' 69 | description: |- 70 | [MathComp finmap 1.5.1 or later](https://github.com/math-comp/finmap) 71 | - opam: 72 | name: coq-mathcomp-analysis 73 | version: '{>= "0.5.0"}' 74 | description: |- 75 | [MathComp analysis 0.5.0 or later](https://github.com/math-comp/analysis) 76 | - opam: 77 | name: coq-mathcomp-zify 78 | description: |- 79 | [Mczify](https://github.com/math-comp/mczify) 80 | - opam: 81 | name: coq-record-update 82 | description: |- 83 | [Coq record update](https://github.com/tchajed/coq-record-update) 84 | 85 | namespace: Algorand 86 | 87 | keywords: 88 | - name: distributed algorithms 89 | - name: blockchain 90 | - name: consensus 91 | - name: algorand 92 | 93 | categories: 94 | - name: Computer Science/Concurrent Systems and Protocols/Theory of concurrent systems 95 | 96 | build: |- 97 | ## Building 98 | 99 | We recommend installing the dependencies of the project via 100 | [opam](http://opam.ocaml.org/doc/Install.html), for example: 101 | ```shell 102 | opam repo add coq-released https://coq.inria.fr/opam/released 103 | opam install coq.8.16.0 coq-mathcomp-ssreflect.1.15.0 \ 104 | coq-mathcomp-algebra coq-mathcomp-finmap.1.5.2 \ 105 | coq-mathcomp-analysis.0.5.4 coq-mathcomp-zify coq-record-update 106 | ``` 107 | 108 | Then, run `make` in the project root directory. This will check all the definitions and proofs. 109 | 110 | documentation: |- 111 | ## Contents 112 | 113 | The project includes: 114 | - an abstract and timed specification in Coq of the Algorand consensus protocol as a transition system, including node-level behavior, asynchronous messaging and a model of the adversary, 115 | - a **complete** formal proof of _asynchronous safety_ for the transition system. 116 | 117 | For more details on the formalization, see the report: 118 | 119 | PDF *[Modeling and Verification of the Algorand Consensus Protocol](https://github.com/runtimeverification/algorand-verification/blob/master/report/report.pdf)* 120 | 121 | Statements of some _liveness_ properties for the transition system are also provided, but these are work-in-progress and their proofs are currently **incomplete**. 122 | 123 | All Coq source files can be found under the `theories` directory, and their content is as follows: 124 | 125 | - `fmap_ext.v`: auxiliary definitions and results on finite maps 126 | - `algorand_model.v`: definition of the Algorand local state, global state, and transition system, along with helper functions and facts 127 | - `safety_helpers.v`: helper functions and lemmas used when proving safety of the transition system 128 | - `quorums.v`: definitions and hypotheses about quorums of nodes 129 | - `safety.v`: statement and complete formal proof of safety for the transition system 130 | - `liveness.v`: an initial attempt at specifying liveness properties for the transition system. This part is work-in-progress and thus the file contains incomplete (admitted) proofs. 131 | 132 | ## Help and Feedback 133 | 134 | Feel free to report GitHub issues or to contact us at: contact@runtimeverification.com 135 | --- 136 | -------------------------------------------------------------------------------- /resources/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Algorand Verification 3 | lang: en 4 | header-includes: 5 | - | 6 | 7 | 8 | 9 | 10 | 11 | --- 12 | 13 |
14 | [View the project on GitHub](https://github.com/runtimeverification/algorand-verification) 15 |
16 | 17 | ## About 18 | 19 | Welcome to the Algorand Verification project website! 20 | 21 | The Algorand consensus protocol is the foundation of a decentralized 22 | digital currency and transactions platform. This project provides a 23 | model of the protocol in Coq, expressed as a transition system over 24 | global states in a message-passing distributed system. Included is 25 | a formal proof of safety for the transition system. 26 | 27 | This is an open source project, licensed under the University of Illinois/NCSA Open Source License. 28 | 29 | ## Get the code 30 | 31 | The latest release of Algorand Verification can be [downloaded from GitHub](https://github.com/runtimeverification/algorand-verification/releases). 32 | 33 | ## Documentation 34 | 35 | Generated HTML documentation is available for source files in the latest release: 36 | 37 | - [fmap_ext.v](docs/latest/coq2html/Algorand.fmap_ext.html): auxiliary definitions and results on finite maps 38 | - [algorand_model.v](docs/latest/coq2html/Algorand.algorand_model.html): definition of the Algorand local state, global state, and transition system, along with helper functions and facts 39 | - [safety_helpers.v](docs/latest/coq2html/Algorand.safety_helpers.html): helper functions and lemmas used when proving safety of the transition system 40 | - [quorums.v](docs/latest/coq2html/Algorand.quorums.html): definitions and hypotheses about quorums of nodes 41 | - [safety.v](docs/latest/coq2html/Algorand.safety.html): statement and complete formal proof of safety for the transition system 42 | 43 | ## Help and contact 44 | 45 | - Report issues on [GitHub](https://github.com/runtimeverification/algorand-verification/issues) 46 | 47 | ## Authors 48 | 49 | - Musab A. Alturki 50 | - Jing Chen 51 | - Victor Luchangco 52 | - Brandon Moore 53 | - Karl Palmskog 54 | - Lucas Peña 55 | - Grigore Roșu 56 | -------------------------------------------------------------------------------- /resources/pdf-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/runtimeverification/algorand-verification/389c5b44d3101508c9fcb023c6ea47874c4e89af/resources/pdf-icon.png -------------------------------------------------------------------------------- /theories/algorand_model.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import finmap multiset. 3 | From Coq Require Import Reals Relation_Definitions Relation_Operators. 4 | From mathcomp Require Import boolp Rstruct. 5 | From RecordUpdate Require Import RecordSet. 6 | From Algorand Require Import fmap_ext. 7 | Import RecordSetNotations. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Open Scope mset_scope. 14 | Open Scope fmap_scope. 15 | Open Scope fset_scope. 16 | 17 | (** * Algorand parameters, data, and transition system *) 18 | 19 | (** This module contains the definitions that comprise the Algorand consensus 20 | protocol model. *) 21 | 22 | (** ** Basic parameters *) 23 | 24 | (** We assume a finite set of users. *) 25 | Parameter UserId : finType. 26 | 27 | (** We assume a countable set of values (blocks and block hashes). *) 28 | Parameter Value : choiceType. 29 | 30 | (** ** Message type *) 31 | 32 | (** An enumeration of all possible types (headers) of messages. *) 33 | Inductive MessageType := 34 | | Block 35 | | Proposal 36 | | Reproposal 37 | | Softvote 38 | | Certvote 39 | | Nextvote_Open 40 | | Nextvote_Val. 41 | 42 | Definition MessageType_eq (a b:MessageType) : bool := 43 | nosimpl match a,b with 44 | | Block, Block => true 45 | | Proposal, Proposal => true 46 | | Reproposal, Reproposal => true 47 | | Softvote, Softvote => true 48 | | Certvote, Certvote => true 49 | | Nextvote_Open, Nextvote_Open => true 50 | | Nextvote_Val, Nextvote_Val => true 51 | | _, _ => false 52 | end. 53 | 54 | Lemma MessageType_eqP : Equality.axiom MessageType_eq. 55 | Proof. 56 | move => a b;apply Bool.iff_reflect;split. 57 | by move <-;destruct a. 58 | by move/(ifT (a=b) True) => <-;destruct a, b. 59 | Qed. 60 | 61 | (** Make [MessageType] a [finType] by showing a mapping 62 | to the MathComp bounded [nat] type ['I_7]. 63 | *) 64 | Definition mtype2o (m:MessageType) : 'I_7 := 65 | inord (match m with 66 | | Block => 0 67 | | Proposal => 1 68 | | Reproposal => 2 69 | | Softvote => 3 70 | | Certvote => 4 71 | | Nextvote_Open => 5 72 | | Nextvote_Val => 6 73 | end). 74 | 75 | Definition o2mtype (i:'I_7) : option MessageType := 76 | match val i with 77 | | 0 => Some Block 78 | | 1 => Some Proposal 79 | | 2 => Some Reproposal 80 | | 3 => Some Softvote 81 | | 4 => Some Certvote 82 | | 5 => Some Nextvote_Open 83 | | 6 => Some Nextvote_Val 84 | | _ => None 85 | end. 86 | 87 | Lemma pcancel_MessageType_7 : pcancel mtype2o o2mtype. 88 | Proof. by case;rewrite /o2mtype /= inordK. Qed. 89 | 90 | (** Register canonical structures on [MessageType]; needed for using it in [fset]s, [mset]s, etc. *) 91 | Canonical messageType_eqType := EqType MessageType (Equality.Mixin MessageType_eqP). 92 | Canonical messageType_choiceType := ChoiceType MessageType (PcanChoiceMixin pcancel_MessageType_7). 93 | Canonical messageType_countType := CountType MessageType (PcanCountMixin pcancel_MessageType_7). 94 | Canonical messageType_finType := FinType MessageType (PcanFinMixin pcancel_MessageType_7). 95 | 96 | (** ** Extended value type *) 97 | 98 | (** Message payload type, packaging [Value] and other data. *) 99 | Inductive ExValue := 100 | | val : Value -> ExValue 101 | | step_val : nat -> ExValue 102 | | repr_val : Value -> UserId -> nat -> ExValue 103 | | next_val : Value -> nat -> ExValue. 104 | 105 | (** Make [ExValue] an equality type and a choice type. *) 106 | Definition codeExVal (e:ExValue) : 107 | Value + nat + (Value * UserId * nat) + (Value * nat) := 108 | match e with 109 | | val mv => inl (inl (inl mv)) 110 | | step_val k => inl (inl (inr k)) 111 | | repr_val v user n => inl (inr (v, user, n)) 112 | | next_val v n => inr (v,n) 113 | end. 114 | 115 | Definition decodeExVal (c:Value + nat + (Value * UserId * nat) + (Value * nat)) : ExValue := 116 | match c with 117 | | inl (inl (inl mv)) => val mv 118 | | inl (inl (inr k)) => step_val k 119 | | inl (inr (v, user, n)) => repr_val v user n 120 | | inr (v,n) => next_val v n 121 | end. 122 | 123 | Lemma cancelExVal : pcancel codeExVal (fun x => Some (decodeExVal x)). 124 | Proof. by case. Qed. 125 | 126 | (** Register canonical structures on [ExValue]; needed for using it in [fset]s, [mset]s, etc. *) 127 | Canonical exValue_eqType := EqType ExValue (PcanEqMixin cancelExVal). 128 | Canonical exValue_choiceType := ChoiceType ExValue (PcanChoiceMixin cancelExVal). 129 | 130 | (** ** Messages *) 131 | 132 | (** A message is represented by a record type for convenience, but 133 | can be viewed as a tuple [(type, ev, r, p, id)] where: 134 | - [type] is the message type, and 135 | - [ev] is the message payload, and 136 | - [r] is the round value, and 137 | - [p] is the period value, and 138 | - [id] is the sending user's identifier. *) 139 | Record Msg : Type := mkMsg 140 | { msg_type : MessageType ; 141 | msg_ev : ExValue ; 142 | msg_round : nat ; 143 | msg_period : nat ; 144 | msg_sender : UserId 145 | }. 146 | 147 | Definition codeMsg (m : Msg) := 148 | (msg_type m, msg_ev m, msg_round m, msg_period m, msg_sender m). 149 | 150 | Definition decodeMsg c := 151 | let: (msg_type, msg_ev, msg_round, msg_period, msg_sender) := c in 152 | mkMsg msg_type msg_ev msg_round msg_period msg_sender. 153 | 154 | Lemma cancelMsg : pcancel codeMsg (fun x => Some (decodeMsg x)). 155 | Proof. by case. Qed. 156 | 157 | (** Register canonical structures on [Msg]; needed for using it in [fset]s, [mset]s, etc. *) 158 | Canonical Msg_eqType := EqType Msg (PcanEqMixin cancelMsg). 159 | Canonical Msg_choiceType := ChoiceType Msg (PcanChoiceMixin cancelMsg). 160 | 161 | (** Messages are grouped by the target user, and are paired with a 162 | delivery deadline. In the absence of a partition, messages must 163 | be delivered before the deadline is reached. *) 164 | Definition MsgPool := {fmap UserId -> {mset R * Msg}}%mset. 165 | 166 | (** ** Credentials *) 167 | 168 | (** The credential of a user at a round-period-step triple. 169 | Note: We abstract away the random value produced by an oracle 170 | and the fact that credentials are interpreted as integer 171 | values. Instead, we model the type of credentials as an 172 | abstract totally ordered type. *) 173 | Parameter credType : orderType tt. 174 | 175 | (** A credential is constructed using the user's identifier and the 176 | current round-period-step values. *) 177 | Parameter credential : UserId -> nat -> nat -> nat -> credType. 178 | 179 | (** Credentials of two different users must be different. *) 180 | Axiom credentials_different : 181 | forall (u u' : UserId) (r r' : nat) (p p' : nat) (s s' : nat), 182 | u <> u' -> credential u r p s <> credential u' r' p' s'. 183 | 184 | (** A predicate defining whether a given credential qualifies its 185 | owner to be a committee member. This abstracts away from how 186 | credential values are interpreted. *) 187 | Parameter committee_cred : credType -> Prop. 188 | 189 | (** Whether the credential is a committee credential for the given 190 | round-period-step triple. *) 191 | Definition comm_cred_step uid r p s : Prop := 192 | committee_cred (credential uid r p s). 193 | 194 | Axiom credentials_valid_period: 195 | forall uid r p s, comm_cred_step uid r p s -> 1 <= p. 196 | 197 | (** ** User state *) 198 | 199 | (** A proposal/reproposal record is a quadruple consisting of 200 | a user id, a user's credential, a value and a boolean 201 | indicating whether the record represents a proposal ([true]) 202 | or a reproposal ([false]). *) 203 | Definition PropRecord := (UserId * credType * Value * bool)%type. 204 | 205 | (** A vote is a pair of a [UserId] (the identifier of the voter) 206 | and a [Value] (the value voted for). *) 207 | Definition Vote := (UserId * Value)%type. 208 | 209 | (** The structure of a user's state. *) 210 | Record UState := 211 | mkUState { 212 | corrupt : bool; (**r a flag indicating whether the user is corrupt *) 213 | round : nat; (**r the user's current round (starts at 1) *) 214 | period : nat; (**r the user's current period (starts at 1) *) 215 | step : nat; (**r the user's current step counter (starts at 1) *) 216 | timer : R; (**r the user's current timer value (since the beginning of the current period) *) 217 | deadline : R; (**r the user's next deadline time value (since the beginning of the current period) *) 218 | p_start : R; (**r the (local) time at which the user's current period started (i.e., local clock = p_start + timer) *) 219 | proposals : {fsfun nat * nat -> seq PropRecord with [::]}; (**r a sequence of proposal/reproposal records for the given round/period *) 220 | stv : {fmap nat -> Value}; (**r starting value *) 221 | blocks : {fsfun nat -> seq Value with [::]}; (**r a sequence of values seen for the given round *) 222 | softvotes : {fsfun nat * nat -> seq Vote with [::]}; (**r a sequence of softvotes seen for the given round/period *) 223 | certvotes : {fsfun nat * nat -> seq Vote with [::]}; (**r a sequence of certvotes seen for the given round/period *) 224 | nextvotes_open : {fsfun nat * nat * nat -> seq UserId with [::]}; (**r a sequence of bottom-nextvotes seen for the given round/period/step *) 225 | nextvotes_val : {fsfun nat * nat * nat -> seq Vote with [::]} (**r a sequence of value-nextvotes seen for the given round/period/step *) 226 | }. 227 | 228 | #[export] Instance UState_Settable : Settable _ := 229 | settable! mkUState . 231 | 232 | Definition codeUState (u : UState) := 233 | (u.(corrupt), u.(round), u.(period), u.(step), u.(timer), u.(deadline), 234 | u.(p_start), u.(proposals), u.(stv), u.(blocks), u.(softvotes), u.(certvotes), 235 | u.(nextvotes_open), u.(nextvotes_val)). 236 | 237 | Definition decodeUState c := 238 | let: (corrupt, round, period, step, timer, deadline, p_start, 239 | proposals, stv, blocks, softvotes, certvotes, 240 | nextvotes_open, nextvotes_val) := c in 241 | mkUState corrupt round period step timer deadline 242 | p_start proposals stv blocks softvotes certvotes 243 | nextvotes_open nextvotes_val. 244 | 245 | Lemma cancelUState : pcancel codeUState (fun x => Some (decodeUState x)). 246 | Proof. by case. Qed. 247 | 248 | Canonical UState_eqType := EqType UState (PcanEqMixin cancelUState). 249 | Canonical UState_choiceType := ChoiceType UState (PcanChoiceMixin cancelUState). 250 | 251 | (** ** Updating user state *) 252 | 253 | (** Update functions for sequences maintained in the user state. *) 254 | Definition set_proposals u r' p' prop : UState := 255 | u <| proposals := [fsfun u.(proposals) with 256 | (r', p') |-> (undup (prop :: u.(proposals) (r', p')))] |>. 257 | 258 | Definition set_blocks (u : UState) (r':nat) block : UState := 259 | u <| blocks := [fsfun u.(blocks) with 260 | r' |-> (undup (block :: u.(blocks) r'))] |>. 261 | 262 | Definition set_softvotes (u : UState) r' p' sv : UState := 263 | u <| softvotes := [fsfun u.(softvotes) with 264 | (r', p') |-> (undup (sv :: u.(softvotes) (r', p')))] |>. 265 | 266 | Definition set_certvotes (u : UState) r' p' sv : UState := 267 | u <| certvotes := [fsfun u.(certvotes) with 268 | (r', p') |-> (undup (sv :: u.(certvotes) (r', p')))] |>. 269 | 270 | Definition set_nextvotes_open (u : UState) r' p' s' nvo : UState := 271 | u <| nextvotes_open := [fsfun u.(nextvotes_open) with 272 | (r', p', s') |-> (undup (nvo :: u.(nextvotes_open) (r', p', s')))] |>. 273 | 274 | Definition set_nextvotes_val (u : UState) r' p' s' nvv : UState := 275 | u <| nextvotes_val := [fsfun u.(nextvotes_val) with 276 | (r', p', s') |-> (undup (nvv :: u.(nextvotes_val) (r', p', s')))] |>. 277 | 278 | (** Update function for advancing the period of a user state. *) 279 | Definition advance_period (u : UState) : UState := 280 | u <| period := (u.(period) + 1)%nat |> 281 | <| step := 1%nat |> 282 | <| timer := 0%R |> 283 | <| deadline := 0%R |> 284 | <| p_start := (u.(p_start) + u.(timer))%R |>. 285 | 286 | (** Update function for advancing the round of a user state. *) 287 | Definition advance_round (u : UState) : UState := 288 | u <| round := (u.(round) + 1)%nat |> 289 | <| period := 1%nat |> 290 | <| step := 1%nat |> 291 | <| stv := [fmap] |> 292 | <| timer := 0%R |> 293 | <| deadline := 0%R |> 294 | <| p_start := (u.(p_start) + u.(timer))%R |>. 295 | 296 | (** ** Global State *) 297 | 298 | (** The structure of the global state. *) 299 | Record GState := 300 | mkGState { 301 | now : R; (**r the current global time value *) 302 | network_partition : bool; (**r a flag indicating whether the network is currently partitioned *) 303 | users : {fmap UserId -> UState}; (**r the global set of users as a finite map of user ids to user states *) 304 | msg_in_transit : {fmap UserId -> {mset R * Msg}}; (**r messages in transit as a finite map from user identifiers (targets) to multisets of messages *) 305 | msg_history : {mset Msg} (**r the history of all broadcasted messages as a multiset of messages *) 306 | }. 307 | 308 | #[export] Instance GState_Settable : Settable _ := 309 | settable! mkGState . 310 | 311 | (** State with empty maps, unpartitioned, at global time 0. *) 312 | Definition null_state : GState := mkGState 0%R false [fmap] [fmap] mset0. 313 | 314 | Definition codeGState (g : GState) := 315 | (now g, network_partition g, users g, msg_in_transit g, msg_history g). 316 | 317 | Definition decodeGState c := 318 | let: (now, network_partition, users, msg_in_transit, msg_history) := c in 319 | mkGState now network_partition users msg_in_transit msg_history. 320 | 321 | Lemma cancelGState : pcancel codeGState (fun x => Some (decodeGState x)). 322 | Proof. by case. Qed. 323 | 324 | Canonical GState_eqType := EqType GState (PcanEqMixin cancelGState). 325 | Canonical GState_choiceType := ChoiceType GState (PcanChoiceMixin cancelGState). 326 | 327 | (** Flipping the network partition flag. *) 328 | Definition flip_partition_flag (g : GState) : GState := 329 | g <| network_partition := ~~ g.(network_partition) |>. 330 | 331 | (** ** Global parameters and axioms of the system *) 332 | 333 | (** Small (non-block) message delivery delay. *) 334 | Parameter lambda : R. 335 | 336 | (** Block message delivery delay. *) 337 | Parameter big_lambda : R. 338 | 339 | (** Recovery time period. *) 340 | Parameter L : R. 341 | 342 | (** Axioms on how these bounds are related. *) 343 | Axiom delays_positive : (lambda > 0)%R. 344 | 345 | Axiom delays_order : (3 * lambda <= big_lambda < L)%R. 346 | 347 | (** Number of soft-votes needed to cert-vote. *) 348 | Parameter tau_s : nat. 349 | 350 | (** Number of cert-votes needed for a certificate. *) 351 | Parameter tau_c : nat. 352 | 353 | (* Number of next-votes for bottom to move to next period. *) 354 | Parameter tau_b : nat. 355 | 356 | (* Number of next-votes for a value to move to next period. *) 357 | Parameter tau_v : nat. 358 | 359 | (** An abstract predicate on values that tells us whether a value is valid. *) 360 | Parameter valid : Value -> Prop. 361 | 362 | (** An abstract predicate on values that tells us whether a 363 | given hash value is indeed the hash of the given block value. *) 364 | Parameter correct_hash : Value -> Value -> Prop. 365 | 366 | (** ** Helper definitions for user-state transitions *) 367 | 368 | (** The block has been seen and is valid and the given value is 369 | indeed its hash value. *) 370 | Definition valid_block_and_hash b v : Prop := 371 | valid b /\ correct_hash v b. 372 | 373 | (** From user state, get round-period-step triple. *) 374 | Definition step_of_ustate (u:UState) := 375 | (u.(round), u.(period), u.(step)). 376 | 377 | (** Steps are ordered lexicographically ([Prop] versions). *) 378 | Definition step_le (step1 step2: nat * nat * nat) := 379 | let: (r1,p1,s1) := step1 in 380 | let: (r2,p2,s2) := step2 in 381 | r1 < r2 \/ r1 = r2 /\ (p1 < p2 \/ p1 = p2 /\ s1 <= s2). 382 | 383 | Definition step_lt (step1 step2: nat * nat * nat) := 384 | let: (r1,p1,s1) := step1 in 385 | let: (r2,p2,s2) := step2 in 386 | r1 < r2 \/ r1 = r2 /\ (p1 < p2 \/ p1 = p2 /\ s1 < s2). 387 | 388 | (** Steps are ordered lexicographically ([bool] versions). *) 389 | Definition step_leb (step1 step2: nat * nat * nat) : bool := 390 | let: (r1,p1,s1) := step1 in 391 | let: (r2,p2,s2) := step2 in 392 | (r1 < r2) || (r1 == r2) && ((p1 < p2) || (p1 == p2) && (s1 <= s2)). 393 | 394 | Definition step_ltb (step1 step2: nat * nat * nat) : bool := 395 | let: (r1,p1,s1) := step1 in 396 | let: (r2,p2,s2) := step2 in 397 | (r1 < r2) || (r1 == r2) && ((p1 < p2) || (p1 == p2) && (s1 < s2)). 398 | 399 | (** [us2] is after [us1] if the step of [us1] is less than the step of [us2]. *) 400 | Definition ustate_after_strict us1 us2 : Prop := 401 | step_lt (step_of_ustate us1) (step_of_ustate us2). 402 | 403 | (** [us2] is no earlier than [us1] in terms of round-period-step ordering. *) 404 | Definition ustate_after us1 us2 : Prop := 405 | us1.(round) < us2.(round) 406 | \/ (us1.(round) = us2.(round) /\ us1.(period) < us2.(period)) 407 | \/ (us1.(round) = us2.(round) /\ us1.(period) = us2.(period) /\ us1.(step) <= us2.(step)). 408 | 409 | Definition msg_step_s (mtype : MessageType) (v : ExValue) : nat := 410 | match mtype with 411 | | Block => 1 412 | | Proposal => 1 413 | | Reproposal => 1 414 | | Softvote => 2 415 | | Certvote => 3 416 | | Nextvote_Val => 417 | match v with 418 | | next_val _ s => s 419 | | _ => 111 420 | end 421 | | Nextvote_Open => 422 | match v with 423 | | step_val s => s 424 | | _ => 111 425 | end 426 | end. 427 | 428 | Definition msg_step (msg:Msg) : nat * nat * nat := 429 | (msg_round msg, msg_period msg, msg_step_s (msg_type msg) (msg_ev msg)). 430 | 431 | (** Is the given message a vote (softvote, certvote, or nextvote) message? *) 432 | Definition vote_msg (msg : Msg) : Prop := 433 | match msg_type msg with 434 | | Softvote | Certvote | Nextvote_Open | Nextvote_Val => True 435 | | _ => False 436 | end. 437 | 438 | (** Does the given round-period-step match the ones stored in the user state? *) 439 | Definition valid_rps (u : UState) r p s : Prop := 440 | u.(round) = r /\ u.(period) = p /\ u.(step) = s. 441 | 442 | Definition advancing_rp (u : UState) r p : Prop := 443 | u.(round) < r \/ u.(round) = r /\ u.(period) <= p. 444 | 445 | (** Is the vote [x] for this value [v]? *) 446 | Definition matchValue (x : Vote) (v : Value) : bool := 447 | let: (u', v') := x in v == v'. 448 | 449 | (** The sequence of all values appearing in a given sequence of votes with 450 | duplicates removed. *) 451 | Definition vote_values (vs: seq Vote) : seq Value := 452 | undup [seq x.2 | x <- vs]. 453 | 454 | Definition softvoters_for (v:Value) (u:UState) r p : {fset UserId} := 455 | [fset x.1 | x in u.(softvotes) (r, p) & matchValue x v]. 456 | 457 | Definition nextvoters_open_for (u:UState) r p s : {fset UserId} := 458 | [fset x in u.(nextvotes_open) (r, p, s)]. 459 | 460 | Definition nextvoters_val_for (v:Value) (u:UState) r p s : {fset UserId} := 461 | [fset x.1 | x in u.(nextvotes_val) (r, p, s) & matchValue x v]. 462 | 463 | (** The number of softvotes of a given value in a given user state for the round 464 | and period given. Does not use the invariant that [u.(softvotes) r p] is duplicate-free. *) 465 | Definition soft_weight (v:Value) (u:UState) r p : nat := 466 | size (softvoters_for v u r p). 467 | 468 | (** The sequence of values with high enough softvotes in a given user state for given round 469 | and period, i.e., the sequence of values in softvotes having votes greater than or equal 470 | to the threshold. Invariant: size is [<= 1]. *) 471 | Definition certvals (u:UState) r p : seq Value := 472 | [seq v <- vote_values (u.(softvotes) (r, p)) | (soft_weight v u r p) >= tau_s]. 473 | 474 | (** The sequence of values certified for in the last period as seen by the given user. 475 | This corresponds to prev_certvals field in the automaton model. *) 476 | Definition prev_certvals (u:UState) : seq Value := 477 | let p := u.(period) in 478 | if p > 1 then certvals u u.(round) (p - 1) else [::]. 479 | 480 | (** Whether the user has seen enough votes for bottom in the given round-period-step. *) 481 | Definition nextvote_bottom_quorum (u:UState) r p s : Prop := 482 | #|(u.(nextvotes_open) (r, p, s))| >= tau_b. 483 | 484 | (** Whether the user has seen enough nextvotes for a given value in the given round-period-step. *) 485 | Definition nextvote_value_quorum (u:UState) v r p s : Prop := 486 | #|[seq x.1 | x <- u.(nextvotes_val) (r, p, s) & matchValue x v]| >= tau_v. 487 | 488 | (** Whether the user has seen enough nextvotes for some value in the given round-period-step. *) 489 | Definition nextvote_quorum_for_some_value (u:UState) r p s : Prop := 490 | exists v, nextvote_value_quorum u v r p s. 491 | 492 | (** Whether a quorum for bottom was not seen in the last period 493 | of the current round (for some step during that period). *) 494 | Definition cert_may_exist (u:UState) : Prop := 495 | let p := u.(period) in 496 | let r := u.(round) in 497 | p > 1 /\ forall s, ~ nextvote_bottom_quorum u r (p - 1) s. 498 | 499 | (** Proposal record ordering induced by ordering on credentials. *) 500 | Definition reclt (rec rec' : PropRecord) : bool := (rec.1.1.2 < rec'.1.1.2)%O. 501 | 502 | (** Returns the proposal record in a given sequence of records having the least 503 | credential, i.e., the record of the potential leader. *) 504 | Fixpoint least_record (prs : seq PropRecord) : option PropRecord := 505 | match prs with 506 | | [::] => None 507 | | [:: rec & prs'] => 508 | match least_record prs' with 509 | | None => Some rec 510 | | Some rec' => 511 | if reclt rec' rec 512 | then Some rec' 513 | else Some rec 514 | end 515 | end. 516 | 517 | (** Returns whether the given (proposal) value is the potential leader value. *) 518 | Definition leader_prop_value (v : Value) (prs : seq PropRecord) : Prop := 519 | let opr := least_record prs in 520 | match opr with 521 | | None => False 522 | | Some (_,_, _, false) => False 523 | | Some (_,_, v', true) => v = v' 524 | end. 525 | 526 | (** Returns whether the given (reproposal) value is the potential leader value. *) 527 | Definition leader_reprop_value (v : Value) (prs : seq PropRecord) : Prop := 528 | let opr := least_record prs in 529 | match opr with 530 | | None => False 531 | | Some (_,_, _, true) => False 532 | | Some (_,_, v', false) => v = v' 533 | end. 534 | 535 | (** The timer deadline value for the NEXT step following the given step value. 536 | Note that [k] is zero-based and hence the apparent difference from the Algorand paper. 537 | The computed deadline values are exactly as given in the paper. *) 538 | Definition next_deadline k : R := 539 | match k with 540 | | 0 => 0 (**r deadline for step 1 *) 541 | | 1 => (2 * lambda)%R (**r deadline for step 2 *) 542 | | 2 => (lambda + big_lambda)%R (**r deadline for step 3 *) 543 | | n => (lambda + big_lambda + (INR n - 3) * L)%R (**r deadlines for steps 4, 5, 6, ... *) 544 | end. 545 | 546 | (** ** Step 1: Proposing predicates and user state updates *) 547 | 548 | (** The proposal step preconditions. Note that this covers both: 549 | - the case when [p = 1], and 550 | - the case when [p > 1] with the previous period voting for bottom. 551 | 552 | Just as in the automaton model, the fact that the last period's quorum 553 | was not for bottom is captured by the predicate [cert_may_exist]. *) 554 | Definition propose_ok (pre : UState) uid v b r p : Prop := 555 | pre.(timer) = 0%R /\ 556 | valid_rps pre r p 1 /\ 557 | comm_cred_step uid r p 1 /\ 558 | valid_block_and_hash b v /\ 559 | ~ cert_may_exist pre. 560 | 561 | (** The reproposal step preconditions. Note that this is the proposal 562 | step when [p > 1] and a next-vote quorum for a value [v] was 563 | seen in [p - 1]. Note also that this may overlap with the case 564 | above, when [cert_may_exist] does not hold. *) 565 | Definition repropose_ok (pre : UState) uid v r p : Prop := 566 | pre.(timer) = 0%R /\ 567 | valid_rps pre r p 1 /\ p > 1 /\ 568 | comm_cred_step uid r p 1 /\ 569 | exists s, nextvote_value_quorum pre v r (p - 1) s. 570 | 571 | (** The no-propose step preconditions.Note that this applies 572 | regardless of whether [p = 1]. *) 573 | Definition no_propose_ok (pre : UState) uid r p : Prop := 574 | pre.(timer) = 0%R /\ 575 | valid_rps pre r p 1 /\ 576 | (comm_cred_step uid r p 1 -> 577 | cert_may_exist pre /\ 578 | forall s v, ~ nextvote_value_quorum pre v r (p - 1) s). 579 | 580 | (** The proposing step (propose, repropose and nopropose) post-state. 581 | Move on to softvoting and set the new deadline to [2*lambda]. *) 582 | Definition propose_result (pre : UState) : UState := 583 | pre <| deadline := (2 * lambda)%R |> 584 | <| step := 2%nat |>. 585 | 586 | (** ** Step 2: Softvoting predicates and user state updates *) 587 | 588 | (** The Softvoting-a-proposal step preconditions. This covers both: 589 | - the case when [p = 1], and 590 | - the case when [p > 1] with the previous period voting for bottom. 591 | 592 | Note that: 593 | - the automaton model has the constraint clock [>= 2*lambda], and 594 | - the phrase "[v] is a period 1 block" in the Algorand2 description 595 | is interpreted here as "[v] is a reproposal", for simplicity. *) 596 | Definition softvote_new_ok (pre : UState) uid v r p : Prop := 597 | pre.(timer) = (2 * lambda)%R /\ 598 | valid_rps pre r p 2 /\ 599 | comm_cred_step uid r p 2 /\ 600 | ~ cert_may_exist pre /\ 601 | leader_prop_value v (pre.(proposals) (r, p)) . 602 | 603 | (** The Softvoting-a-reproposal step preconditions 604 | Note that this is the Softvoting step when [p > 1] and the previous period's 605 | winning vote was for a value [v]. *) 606 | Definition softvote_repr_ok (pre : UState) uid v (r p: nat) : Prop := 607 | pre.(timer) = (2 * lambda)%R /\ 608 | valid_rps pre r p 2 /\ p > 1 /\ 609 | comm_cred_step uid r p 2 /\ 610 | ( (~ cert_may_exist pre /\ 611 | (exists s, nextvote_value_quorum pre v r (p - 1) s) /\ 612 | leader_reprop_value v (pre.(proposals) (r, p))) 613 | \/ (cert_may_exist pre /\ pre.(stv).[? p] = Some v) ). 614 | 615 | (** The no-softvoting step preconditions. Three reasons a user may 616 | not be able to soft-vote: 617 | - not being in the soft-voting committee, or 618 | - not being able to identify a potential leader value to soft-vote for 619 | - not seeing enough next-votes for a value reproposed when the previous period 620 | had a quorum for bottom. 621 | 622 | Note that this may apply regardless of whether [p = 1]. *) 623 | Definition no_softvote_ok (pre : UState) uid r p : Prop := 624 | pre.(timer) = (2 * lambda)%R /\ 625 | valid_rps pre r p 2 /\ 626 | forall v, 627 | (comm_cred_step uid r p 2 -> 628 | (( cert_may_exist pre \/ ~ leader_prop_value v (pre.(proposals) (r, p))) 629 | /\ ((cert_may_exist pre \/ 630 | (forall s, ~ nextvote_value_quorum pre v r (p - 1) s) \/ 631 | ~ leader_reprop_value v (pre.(proposals) (r, p))) 632 | /\ (~ cert_may_exist pre \/ ~ pre.(stv).[? p] = Some v)))). 633 | 634 | (** The softvoting step (new or reproposal) post-state. 635 | We keep the current deadline at [2 * lambda] and let certvoting handle 636 | updating the deadline (to avoid timing out while certvoting is already 637 | enabled). This assumes it is ok to certvote at time [2 * lambda]. *) 638 | Definition softvote_result (pre : UState) : UState := 639 | pre <| step := 3 |> 640 | <| deadline := (lambda + big_lambda)%R |>. 641 | 642 | (** ** Step 3: Certvoting predicates and user state updates *) 643 | 644 | (** Certvoting step preconditions: the successful case. *) 645 | Definition certvote_ok (pre : UState) uid (v b: Value) r p : Prop := 646 | ((2 * lambda)%R < pre.(timer) <= lambda + big_lambda)%R /\ 647 | valid_rps pre r p 3 /\ 648 | comm_cred_step uid r p 3 /\ 649 | valid_block_and_hash b v /\ 650 | b \in pre.(blocks) r /\ 651 | v \in certvals pre r p . 652 | 653 | (** Certvoting step preconditions: the unsuccessful case - not a committee member. *) 654 | Definition no_certvote_ok (pre : UState) uid r p : Prop := 655 | ((2 * lambda)%R < pre.(timer) <= lambda + big_lambda)%R /\ 656 | valid_rps pre r p 3 /\ 657 | ~ comm_cred_step uid r p 3. 658 | 659 | (** Certvote timeout preconditions. A user timeouts if the deadline 660 | is reached while waiting for some external messages 661 | (i.e., while observing softvotes in step 3) *) 662 | Definition certvote_timeout_ok (pre : UState) uid r p : Prop := 663 | (pre.(timer) >= pre.(deadline))%R /\ 664 | valid_rps pre r p 3 /\ 665 | comm_cred_step uid r p 3 /\ 666 | forall b v, 667 | (~ valid_block_and_hash b v \/ 668 | ~ b \in pre.(blocks) r \/ 669 | ~ v \in certvals pre r p). 670 | 671 | (** The certvoting step's resulting user state. 672 | The state update for all certvoting cases: move on to the next step 673 | (the deadline does not need updating). *) 674 | Definition certvote_result (pre : UState) : UState := 675 | pre <| step := 4 |>. 676 | 677 | (** ** Steps >= 4: Nextvoting predicates and user state updates *) 678 | 679 | (** Nextvoting step preconditions, the proper-value case. Note: 680 | - corresponds (roughly) to transition nextvote_val in the automaton 681 | model (but not the same), and 682 | - corresponds more closely to the Algorand2 description (but with the 683 | committee membership constraint). 684 | *) 685 | Definition nextvote_val_ok (pre : UState) uid (v b : Value) r p s : Prop := 686 | pre.(timer) = (lambda + big_lambda + (INR s - 4) * L)%R /\ 687 | valid_rps pre r p s /\ 688 | comm_cred_step uid r p s /\ 689 | 3 < s /\ 690 | valid_block_and_hash b v /\ 691 | b \in pre.(blocks) r /\ 692 | v \in certvals pre r p. 693 | 694 | (** Nextvoting step preconditions, the bottom-value case. Note: 695 | - corresponds (roughly) to transition nextvote_open in the automaton 696 | model (but not the same), and 697 | - corresponds more closely to the Algorand2 description (but with the 698 | committee membership constraint). 699 | *) 700 | Definition nextvote_open_ok (pre : UState) uid r p s : Prop := 701 | pre.(timer) = (lambda + big_lambda + (INR s - 4) * L)%R /\ 702 | valid_rps pre r p s /\ 703 | comm_cred_step uid r p s /\ 704 | 3 < s /\ 705 | (forall v, v \in certvals pre r p -> forall b, b \in pre.(blocks) r -> 706 | ~valid_block_and_hash b v) /\ 707 | (p > 1 -> nextvote_bottom_quorum pre r (p - 1) s ). 708 | 709 | (** Nextvoting step preconditions, the additional special case of using 710 | the starting value. Note: 711 | - this might not be captured in the automaton model, and 712 | - corresponds more closely to the Algorand2 description (but with 713 | additional constraints given explicitly). 714 | *) 715 | Definition nextvote_stv_ok (pre : UState) uid r p s : Prop := 716 | pre.(timer) = (lambda + big_lambda + (INR s - 4) * L)%R /\ 717 | valid_rps pre r p s /\ 718 | comm_cred_step uid r p s /\ 719 | 3 < s /\ 720 | (forall v, v \in certvals pre r p -> forall b, b \in pre.(blocks) r -> 721 | ~valid_block_and_hash b v) /\ 722 | p > 1 /\ ~ nextvote_bottom_quorum pre r (p - 1) s. 723 | 724 | (** Nextvoting step preconditions, the no-voting case. *) 725 | Definition no_nextvote_ok (pre : UState) uid r p s : Prop := 726 | pre.(timer) = (lambda + big_lambda + (INR s - 4) * L)%R /\ 727 | valid_rps pre r p s /\ 728 | ~ comm_cred_step uid r p s. 729 | 730 | (** Nextvoting step state update for steps [s >= 4] (all cases). *) 731 | Definition nextvote_result (pre : UState) s : UState := 732 | pre <| step := (s + 1)%nat |> 733 | <| deadline := next_deadline s |>. 734 | 735 | (** Advancing period propositions and user state update. *) 736 | 737 | (** Preconditions, the bottom-value case. Note that this corresponds 738 | to transition advance_period_open in the automaton model. *) 739 | Definition adv_period_open_ok (pre : UState) r p s : Prop := 740 | valid_rps pre r p s /\ 741 | nextvote_bottom_quorum pre r p s. 742 | 743 | (** Preconditions, the proper value case. This corresponds to 744 | transition advance_period_val in the automaton model. *) 745 | Definition adv_period_val_ok (pre : UState) (v : Value) r p s : Prop := 746 | valid_rps pre r p s /\ 747 | nextvote_value_quorum pre v r p s. 748 | 749 | (** State update, the bottom-value case. *) 750 | Definition adv_period_open_result (pre : UState) : UState := 751 | (advance_period pre) <| stv := pre.(stv).[~ pre.(period).+1] |>. 752 | 753 | (** State updatem the proper value case. *) 754 | Definition adv_period_val_result (pre : UState) v : UState := 755 | (advance_period pre) <| stv := pre.(stv).[pre.(period).+1 <- v] |>. 756 | 757 | (** Advancing round predicates and user state updates. Note: 758 | - corresponds to transition certify in the automaton model, and 759 | - the requirement [valid_rps] has been removed since certification 760 | may happen at any time. 761 | 762 | TODO: need to have some assertion about message age. *) 763 | Definition certify_ok (pre : UState) (v : Value) r p : Prop := 764 | advancing_rp pre r p /\ 765 | exists b, 766 | valid_block_and_hash b v /\ 767 | b \in pre.(blocks) r /\ 768 | size [seq x <- pre.(certvotes) (r, p) | matchValue x v] >= tau_c. 769 | 770 | (** State update. *) 771 | Definition certify_result r (pre : UState) : UState := 772 | advance_round (pre <| round := r |>). 773 | 774 | (** The post state of delivering a non-vote message. *) 775 | Definition deliver_nonvote_msg_result (pre : UState) (msg : Msg) c r p : UState := 776 | let type := msg_type msg in 777 | let id := msg_sender msg in 778 | let ev := msg_ev msg in 779 | match ev with 780 | | val v => 781 | match type with 782 | | Proposal => set_proposals pre r p (id, c, v, true) 783 | | Reproposal => set_proposals pre r p (id, c, v, false) 784 | | Block => set_blocks pre r v 785 | | _ => pre 786 | end 787 | | _ => pre 788 | end. 789 | 790 | (** ** User transition relation - internal transitions *) 791 | 792 | (** The internal user-level transition relation type. 793 | An internal transition is a transition that does not consume a message, 794 | and a user transitions from a pre-state into a post-state while emitting 795 | a (possibly empty) sequence of outgoing messages. *) 796 | Definition u_transition_internal_type := UserId -> UState -> (UState * seq Msg) -> Prop. 797 | 798 | Reserved Notation "x # z ~> y" (at level 70). 799 | 800 | (** Internal actions are supposed to take place either: 801 | - at a specific time instance (i.e. never triggered by a recevied message), or 802 | - during a time duration, but the preconditions are already satisfied that 803 | the action fires eagerly at the beginning of that time duration (again, 804 | without consuming a message). 805 | *) 806 | Inductive UTransitionInternal : u_transition_internal_type := 807 | | propose : (**r step 1: block proposal *) 808 | forall uid (pre : UState) v b r p, 809 | propose_ok pre uid v b r p -> 810 | uid # pre ~> (propose_result pre, [:: mkMsg Proposal (val v) r p uid ; mkMsg Block (val b) r p uid]) 811 | 812 | | repropose : (**r step 1: block proposal (reproposal) *) 813 | forall uid (pre : UState) v r p, 814 | repropose_ok pre uid v r p -> 815 | uid # pre ~> (propose_result pre, [:: mkMsg Reproposal (repr_val v uid p) r p uid]) 816 | 817 | | no_propose : (**r step 1: block proposal (failure) *) 818 | forall uid (pre : UState) r p, 819 | no_propose_ok pre uid r p -> 820 | uid # pre ~> (propose_result pre, [::]) 821 | 822 | | softvote_new : (**r step 2: filtering step (new value) *) 823 | forall uid (pre : UState) v r p, 824 | softvote_new_ok pre uid v r p -> 825 | uid # pre ~> (softvote_result pre, [:: mkMsg Softvote (val v) r p uid]) 826 | 827 | | softvote_repr : (**r step 2: filtering step (old value) *) 828 | forall uid (pre : UState) v r p, 829 | softvote_repr_ok pre uid v r p -> 830 | uid # pre ~> (softvote_result pre, [:: mkMsg Softvote (val v) r p uid]) 831 | 832 | | no_softvote : (**r step 2: filtering step (no value) *) 833 | forall uid (pre : UState) r p, 834 | no_softvote_ok pre uid r p -> 835 | uid # pre ~> (softvote_result pre, [::]) 836 | 837 | | certvote1 : (**r step 3: certifying step (success) *) 838 | forall uid (pre : UState) v b r p, 839 | certvote_ok pre uid v b r p -> 840 | uid # pre ~> (certvote_result pre, [:: mkMsg Certvote (val v) r p uid]) 841 | 842 | | no_certvote : (**r step 3: certifying step (failure) *) 843 | forall uid (pre : UState) r p, 844 | no_certvote_ok pre uid r p -> 845 | uid # pre ~> (certvote_result pre, [::]) 846 | 847 | | nextvote_val : (**r steps >= 4: finishing step, [i] has cert-voted some [v] *) 848 | forall uid (pre : UState) v b r p s, 849 | nextvote_val_ok pre uid v b r p s -> 850 | uid # pre ~> (nextvote_result pre s, [:: mkMsg Nextvote_Val (next_val v s) r p uid]) 851 | 852 | | nextvote_open : (**r steps >= 4: finishing step, [i] has not cert-voted some [v] *) 853 | forall uid (pre : UState) r p s, 854 | nextvote_open_ok pre uid r p s -> 855 | uid # pre ~> (nextvote_result pre s, [:: mkMsg Nextvote_Open (step_val s) r p uid]) 856 | 857 | | nextvote_stv : (**r steps >= 4: finishing step, special case of using [stv] *) 858 | forall uid (pre : UState) v r p s, 859 | nextvote_stv_ok pre uid r p s -> 860 | pre.(stv).[? p] = Some v -> 861 | uid # pre ~> (nextvote_result pre s, [:: mkMsg Nextvote_Val (next_val v s) r p uid]) 862 | 863 | | no_nextvote : (**r steps >= 4: finishing step, no next-voting *) 864 | forall uid (pre : UState) r p s, 865 | no_nextvote_ok pre uid r p s -> 866 | uid # pre ~> (nextvote_result pre s, [::]) 867 | 868 | | certvote_timeout : (**r certvote timeout transition, applicable only to step = 3 *) 869 | forall uid (pre : UState) r p, 870 | certvote_timeout_ok pre uid p r -> 871 | uid # pre ~> (certvote_result pre, [::]) 872 | 873 | where "x # y ~> z" := (UTransitionInternal x y z) : type_scope. 874 | 875 | (** ** User transition relation - message transitions *) 876 | 877 | (** The message-triggered user-level transition relation. 878 | A message-triggered transition consumes an incoming message, 879 | and a user transitions from a pre-state, while consuming a message, into a 880 | post-state and emits a (possibly empty) sequence of outgoing messages. *) 881 | Definition u_transition_msg_type := UserId -> UState -> Msg -> (UState * seq Msg) -> Prop. 882 | 883 | Reserved Notation "a # b ; c ~> d" (at level 70). 884 | 885 | (** Deliver messages and possibly trigger actions urgently. 886 | Note that advancing the period takes precedence over nextvote2_open actions. *) 887 | Inductive UTransitionMsg : u_transition_msg_type := 888 | | deliver_softvote : (**r deliver a softvote while not triggering any internal action *) 889 | forall uid (pre : UState) r p i v b, 890 | let pre' := (set_softvotes pre r p (i, v)) in 891 | ~ certvote_ok pre' uid v b r p -> 892 | uid # pre ; mkMsg Softvote (val v) r p i ~> (pre', [::]) 893 | 894 | | deliver_softvote_certvote1 : (**r deliver a softvote and cert-vote for the value (committee member case) *) 895 | forall uid (pre : UState) r p i v b, 896 | let pre' := set_softvotes pre r p (i, v) in 897 | certvote_ok pre' uid v b r p -> 898 | uid # pre ; mkMsg Softvote (val v) r p i ~> (certvote_result pre', [:: mkMsg Certvote (val v) r p uid]) 899 | 900 | | deliver_nextvote_open : (**r deliver a nextvote for bottom while not triggering any internal action *) 901 | forall uid (pre : UState) r p s i, 902 | let pre' := set_nextvotes_open pre r p s i in 903 | (* ~ nextvote_open_ok pre' v r p s -> *) 904 | ~ adv_period_open_ok pre' r p s -> 905 | uid # pre ; mkMsg Nextvote_Open (step_val s) r p i ~> (pre', [::]) 906 | 907 | | deliver_nextvote_open_adv_prd : (**r deliver a nextvote for bottom and advance the period *) 908 | forall uid (pre : UState) r p s i, 909 | let pre' := set_nextvotes_open pre r p s i in 910 | adv_period_open_ok pre' r p s -> 911 | uid # pre ; mkMsg Nextvote_Open (step_val s) r p i ~> (adv_period_open_result pre', [::]) 912 | 913 | | deliver_nextvote_val : (**r deliver a nextvote for value while not triggering any internal action *) 914 | forall uid (pre : UState) r p s i v, 915 | let pre' := set_nextvotes_val pre r p s (i, v) in 916 | ~ adv_period_val_ok pre' v r p s -> 917 | uid # pre ; mkMsg Nextvote_Val (next_val v s) r p i ~> (pre', [::]) 918 | 919 | | deliver_nextvote_val_adv_prd : (**r deliver a nextvote for value and advance the period *) 920 | forall uid (pre : UState) r p s i v, 921 | let pre' := set_nextvotes_val pre r p s (i, v) in 922 | adv_period_val_ok pre' v r p s -> 923 | uid # pre ; mkMsg Nextvote_Val (next_val v s) r p i ~> (adv_period_val_result pre' v, [::]) 924 | 925 | | deliver_certvote : (**r deliver a certvote while not triggering any internal action *) 926 | forall uid (pre : UState) v r p i, 927 | let pre' := set_certvotes pre r p (i, v) in 928 | ~ certify_ok pre' v r p -> 929 | uid # pre ; mkMsg Certvote (val v) r p i ~> (pre', [::]) 930 | 931 | | deliver_certvote_adv_rnd : (**r deliver a certvote for value and advance the round *) 932 | forall uid (pre : UState) v r p i, 933 | let pre' := set_certvotes pre r p (i, v) in 934 | certify_ok pre' v r p -> 935 | uid # pre ; mkMsg Certvote (val v) r p i ~> (certify_result r pre', [::]) 936 | (** Note that some Algorand documents say this transition may try to 937 | send another certvote message from this node, but we have been 938 | informed that the implementation does not do this, 939 | and allowing it would complicated proofs. *) 940 | | deliver_nonvote_msg : (**r deliver a message other than vote messages (i.e., [Block], [Proposal], or [Reproposal]) *) 941 | forall uid (pre : UState) msg c r p, 942 | ~ vote_msg msg -> 943 | uid # pre ; msg ~> (deliver_nonvote_msg_result pre msg c r p, [::]) 944 | 945 | where "a # b ; c ~> d" := (UTransitionMsg a b c d) : type_scope. 946 | 947 | (** ** Helper functions for global transitions *) 948 | 949 | (** Is the network in a partitioned/unpartitioned state? *) 950 | Definition is_partitioned pre : bool := pre.(network_partition). 951 | Definition is_unpartitioned pre : bool := ~~ is_partitioned pre. 952 | 953 | (** It is OK to advance time if: 954 | - the user is corrupt (its deadline is irrelevant), or 955 | - the increment does not go beyond the deadline. *) 956 | Definition user_can_advance_timer (increment : posreal) : pred UState := 957 | fun u => u.(corrupt) || Rleb (u.(timer) + pos increment) u.(deadline). 958 | 959 | (** Advance the timer of an honest user (timers of corrupt users are irrelevant). *) 960 | Definition user_advance_timer (increment : posreal) (u : UState) : UState := 961 | if ~~ u.(corrupt) 962 | then u <| timer := (u.(timer) + pos increment)%R |> 963 | else u. 964 | 965 | (** Is it OK to advance timers of all (honest) users by the given increment? *) 966 | Definition tick_ok_users increment (pre:GState) : bool := 967 | allf (user_can_advance_timer increment) pre.(users). 968 | 969 | (** It is OK to advance time if: 970 | - the network is partitioned (message delivery delays are ignored), or 971 | - the time increment does not cause missing a message delivery deadline. 972 | *) 973 | Definition tick_ok_msgs (increment:posreal) (pre:GState) : bool := 974 | is_partitioned pre || 975 | let target_time := (pre.(now) + pos increment)%R in 976 | \big[andb/true]_(user_msgs <- codomf pre.(msg_in_transit)) 977 | \big[andb/true]_(m <- (enum_mset user_msgs)) Rleb target_time (fst m). 978 | 979 | (** Returns whether time may advance, taking into consideration the state of 980 | the network, users, their deadlines and message deadlines. *) 981 | Definition tick_ok (increment:posreal) (pre:GState) : bool := 982 | tick_ok_users increment pre && tick_ok_msgs increment pre. 983 | 984 | (** Advance all (honest) user timers by the given increment. *) 985 | Definition tick_users increment pre : {fmap UserId -> UState} := 986 | updf pre.(users) (domf pre.(users)) (fun _ us => user_advance_timer increment us). 987 | 988 | (** Computes the global state after advancing time with the given increment. *) 989 | Definition tick_update increment pre : GState := 990 | pre <| now := (pre.(now) + pos increment)%R |> 991 | <| users := tick_users increment pre |>. 992 | 993 | (** Computes the standard deadline of a message based on its type. *) 994 | Definition msg_deadline (msg : Msg) now : R := 995 | match msg_type msg with 996 | | Block => (now + lambda + big_lambda)%R 997 | | _ => (now + lambda)%R 998 | end. 999 | 1000 | Definition merge_msgs_deadline (now : R) (msgs : seq Msg) (v : {mset R * Msg}) : {mset R * Msg} := 1001 | seq_mset [seq (msg_deadline msg now,msg) | msg <- msgs] `+` v. 1002 | 1003 | Definition send_broadcasts_def (now : R) (targets : {fset UserId}) (prev_msgs : MsgPool) (msgs : seq Msg) : MsgPool := 1004 | updf prev_msgs targets (fun _ => merge_msgs_deadline now msgs). 1005 | 1006 | Definition send_broadcasts_key : unit. 1007 | Proof. exact: tt. Qed. 1008 | 1009 | Definition send_broadcasts := locked_with send_broadcasts_key send_broadcasts_def. 1010 | Canonical send_broadcasts_unlockable := [unlockable fun send_broadcasts]. 1011 | 1012 | (** Returns [true] if [P] is true at nth element in path [p]. *) 1013 | Definition at_step n (p : seq GState) (P : pred GState) : bool := 1014 | match drop n p with 1015 | | g :: _ => P g 1016 | | [::] => false 1017 | end. 1018 | 1019 | (** Returns [true] if the given user id is found in the map and the user state 1020 | corresponding to that id is for a corrupt user. *) 1021 | Definition is_user_corrupt (uid : UserId) (users : {fmap UserId -> UState}) : bool := 1022 | if users.[? uid] is Some u then u.(corrupt) else false. 1023 | 1024 | Definition is_user_corrupt_gstate (uid : UserId) (g : GState) : bool := 1025 | is_user_corrupt uid (g.(users)). 1026 | 1027 | Definition user_honest (uid:UserId) (g:GState) : bool := 1028 | if g.(users).[? uid] is Some ustate then ~~ (ustate.(corrupt)) else false. 1029 | 1030 | Definition user_honest_at ix p (uid : UserId) : bool := 1031 | at_step ix p (user_honest uid). 1032 | 1033 | (** Returns the given users map restricted to honest users only. *) 1034 | Definition honest_users (users : {fmap UserId -> UState}) := 1035 | let corrupt_ids := [fset x in domf users | is_user_corrupt x users] in 1036 | users.[\ corrupt_ids]. 1037 | 1038 | (** Computes the global state after a message delivery, given the result of the 1039 | user transition and the messages sent out. Note: 1040 | 1041 | - the delivered message is removed from the user's mailbox, and 1042 | - broadcasts new messages to honest users only. 1043 | *) 1044 | Definition delivery_result pre uid (uid_has_mailbox : uid \in pre.(msg_in_transit)) delivered ustate_post (sent: seq Msg) : GState := 1045 | let users' := pre.(users).[uid <- ustate_post] in 1046 | let user_msgs' := (pre.(msg_in_transit).[uid_has_mailbox] `\ delivered)%mset in 1047 | let msgs' := send_broadcasts pre.(now) (domf (honest_users pre.(users)) `\ uid) 1048 | pre.(msg_in_transit).[uid <- user_msgs'] sent in 1049 | let msgh' := (pre.(msg_history) `+` (seq_mset sent))%mset in 1050 | pre <| users := users' |> 1051 | <| msg_in_transit := msgs' |> 1052 | <| msg_history := msgh' |>. 1053 | 1054 | Arguments delivery_result : clear implicits. 1055 | 1056 | (** Computes the global state after an internal user-level transition 1057 | given the result of the user transition and the messages sent out. *) 1058 | Definition step_result pre uid ustate_post (sent: seq Msg) : GState := 1059 | let users' := pre.(users).[uid <- ustate_post] in 1060 | let msgs' := send_broadcasts pre.(now) (domf (honest_users pre.(users)) `\ uid) 1061 | pre.(msg_in_transit) sent in 1062 | let msgh' := (pre.(msg_history) `+` (seq_mset sent))%mset in 1063 | pre <| users := users' |> 1064 | <| msg_in_transit := msgs' |> 1065 | <| msg_history := msgh' |>. 1066 | 1067 | Definition new_deadline now cur_deadline msg : R := 1068 | let max_deadline := msg_deadline msg now in 1069 | Rmax cur_deadline max_deadline. 1070 | 1071 | (** Resets the deadline of a message having a missed deadline. *) 1072 | Definition reset_deadline now (msg : R * Msg) : R * Msg := 1073 | (new_deadline now msg.1 msg.2, msg.2). 1074 | 1075 | Definition map_mset {A B : choiceType} (f : A -> B) (m : {mset A}) : {mset B} := 1076 | seq_mset (map f m). 1077 | 1078 | (** Recursively resets message deadlines of all the messages given. *) 1079 | Definition reset_user_msg_delays msgs now : {mset R * Msg} := 1080 | map_mset (reset_deadline now) msgs. 1081 | 1082 | (** Constructs a message pool with all messages having missed delivery deadlines 1083 | updated appropriately based on the message type. *) 1084 | Definition reset_msg_delays (msgpool : MsgPool) now : MsgPool := 1085 | updf msgpool (domf msgpool) (fun _ msgs => reset_user_msg_delays msgs now). 1086 | 1087 | (** Postpones the deadline of a message (extending its delivery delay). *) 1088 | Definition extend_deadline r (msgs : {mset R * Msg}) (msg : R * Msg) : {mset R * Msg} := 1089 | let ext_deadline := (fst msg + r)%R in 1090 | (msgs `+` [mset (ext_deadline, msg.2)])%mset. 1091 | 1092 | (** Computes the state resulting from getting partitioned. 1093 | Note that this no longer injects extended message delays (see the [tick] rule). *) 1094 | Definition make_partitioned (pre:GState) : GState := 1095 | flip_partition_flag pre. 1096 | 1097 | (** Computes the state resulting from recovering from a partition. *) 1098 | Definition recover_from_partitioned pre : GState := 1099 | let msgpool' := reset_msg_delays pre.(msg_in_transit) pre.(now) in 1100 | (flip_partition_flag pre) <| msg_in_transit := msgpool' |>. 1101 | 1102 | (** Marks a user state corrupted by setting the corrupt flag. *) 1103 | Definition make_corrupt ustate : UState := 1104 | ustate <| corrupt := true |>. 1105 | 1106 | (** Drop the set of messages targeted for a specific user from the given 1107 | message map. *) 1108 | Definition drop_mailbox_of_user uid (msgs : MsgPool) : MsgPool := 1109 | if msgs.[? uid] is Some mailbox then msgs.[uid <- mset0] else msgs. 1110 | 1111 | (** Computes the state resulting from corrupting a user. 1112 | The user will have its corrupt flag (in its local state) set to [true] 1113 | and his mailbox in the global state removed. *) 1114 | Definition corrupt_user_result (pre : GState) (uid : UserId) 1115 | (ustate_key : uid \in pre.(users)) : GState := 1116 | let ustate' := make_corrupt pre.(users).[ustate_key] in 1117 | let msgs' := drop_mailbox_of_user uid pre.(msg_in_transit) in 1118 | let users' := pre.(users).[uid <- ustate'] in 1119 | pre <| users := users' |> <| msg_in_transit := msgs' |>. 1120 | 1121 | (** Computes the state resulting from replaying a message to a user. 1122 | The message is replayed to the given target user and added to his mailbox. 1123 | It is not broadcast because other users have already seen the original. *) 1124 | Definition replay_msg_result (pre : GState) (uid : UserId) (msg : Msg) : GState := 1125 | let msgs' := send_broadcasts pre.(now) [fset uid] pre.(msg_in_transit) [:: msg] in 1126 | pre <| msg_in_transit := msgs' |>. 1127 | 1128 | (** Does the adversary have the keys of the user for the given r-p-s? 1129 | The adversary will have the keys if the user is corrupt and the given 1130 | r-p-s comes after (or is equal to) the r-p-s of the user. *) 1131 | Definition have_keys ustate r p s : Prop := 1132 | ustate.(corrupt) /\ step_le (step_of_ustate ustate) (r,p,s). 1133 | 1134 | Definition mtype_matches_step mtype mval s : Prop := 1135 | match mtype, mval with 1136 | | Block, val _ | Proposal, val _ | Reproposal, repr_val _ _ _ => s = 1 1137 | | Softvote, val _ => s = 2 1138 | | Certvote, val _ => s = 3 1139 | | Nextvote_Open, step_val s' => s = s' 1140 | | Nextvote_Val, next_val _ s' => s = s' 1141 | | _, _ => False 1142 | end. 1143 | 1144 | (** Computes the state resulting from forging a message to a user. 1145 | The message is first created and then queued at the target user's mailbox *) 1146 | Definition forge_msg_result (pre : GState) (uid : UserId) r p mtype mval : GState := 1147 | let msg := mkMsg mtype mval r p uid in 1148 | let msgs' := send_broadcasts pre.(now) (domf (honest_users pre.(users))) 1149 | pre.(msg_in_transit) [:: msg] in 1150 | pre <| msg_in_transit := msgs' |>. 1151 | 1152 | (** ** Global transition relation *) 1153 | 1154 | (** Global transition relation type. *) 1155 | Definition g_transition_type := relation GState. 1156 | 1157 | Reserved Notation "x ~~> y" (at level 90). 1158 | 1159 | (** Note that corrupt user deadlines are ignored, and 1160 | when partitioned, message delivery delays are ignored. 1161 | This means that the adversary action to inject extended 1162 | message delays is modeled by [step_tick] ignoring message 1163 | delivery deadlines when partitioned. *) 1164 | Inductive GTransition : g_transition_type := 1165 | | step_tick : (**r advance the global time *) 1166 | forall increment pre, 1167 | tick_ok increment pre -> 1168 | pre ~~> tick_update increment pre 1169 | 1170 | | step_deliver_msg : (**r deliver a message to a user (honest users only) *) 1171 | forall pre uid (msg_key : uid \in pre.(msg_in_transit)) pending, 1172 | pending \in pre.(msg_in_transit).[msg_key] -> 1173 | forall (key_ustate : uid \in pre.(users)) ustate_post sent, 1174 | ~ pre.(users).[key_ustate].(corrupt) -> 1175 | uid # pre.(users).[key_ustate] ; snd pending ~> (ustate_post, sent) -> 1176 | pre ~~> delivery_result pre uid msg_key pending ustate_post sent 1177 | 1178 | | step_internal : (**r progress based on an internal step of a user (honest users only) *) 1179 | forall pre uid (ustate_key : uid \in pre.(users)), 1180 | ~ pre.(users).[ustate_key].(corrupt) -> 1181 | forall ustate_post sent, 1182 | uid # pre.(users).[ustate_key] ~> (ustate_post, sent) -> 1183 | pre ~~> step_result pre uid ustate_post sent 1184 | 1185 | | step_exit_partition : (**r recover from a partition *) 1186 | forall pre, 1187 | is_partitioned pre -> 1188 | pre ~~> recover_from_partitioned pre 1189 | 1190 | | step_enter_partition : (**r adversary action: partition the network *) 1191 | forall pre, 1192 | is_unpartitioned pre -> 1193 | pre ~~> make_partitioned pre 1194 | 1195 | | step_corrupt_user : (**r adversary action: corrupt a user *) 1196 | forall pre uid (ustate_key : uid \in pre.(users)), 1197 | ~ pre.(users).[ustate_key].(corrupt) -> 1198 | pre ~~> @corrupt_user_result pre uid ustate_key 1199 | 1200 | | step_replay_msg : (**r adversary action: replay a message seen before *) 1201 | forall pre uid (ustate_key : uid \in pre.(users)) msg, 1202 | ~ pre.(users).[ustate_key].(corrupt) -> 1203 | msg \in pre.(msg_history) -> 1204 | pre ~~> replay_msg_result pre uid msg 1205 | 1206 | | step_forge_msg : (**r adversary action: forge and send out a message *) 1207 | forall pre sender (sender_key : sender \in pre.(users)) r p s mtype mval, 1208 | have_keys pre.(users).[sender_key] r p s -> 1209 | comm_cred_step sender r p s -> 1210 | mtype_matches_step mtype mval s -> 1211 | pre ~~> forge_msg_result pre sender r p mtype mval 1212 | 1213 | where "x ~~> y" := (GTransition x y) : type_scope. 1214 | 1215 | (** ** Reachability for global transition relation *) 1216 | 1217 | (** There is a step at index [n] from [g1] to [g2] along a path [p]. 1218 | This means that [g1] and [g2] are adjacent elements in the path. *) 1219 | Definition step_in_path_at (g1 g2 : GState) n (p : seq GState) : Prop := 1220 | match drop n p with 1221 | | g1' :: g2' :: _ => [/\ g1' = g1 & g2' = g2] 1222 | | _ => False 1223 | end. 1224 | 1225 | (** Definition of reachable global state via paths. *) 1226 | Definition gtransition : rel GState := [rel x y | `[] ]. 1227 | 1228 | (** A trace starts from [g0] and transitions via [GTransition] at each step in the path [p]. *) 1229 | Definition is_trace (g0 : GState) (p : seq GState) : Prop := 1230 | nosimpl match p with 1231 | | [::] => False 1232 | | [:: g' & rest] => [/\ g0 = g' & path gtransition g0 rest] 1233 | end. 1234 | 1235 | (** Reachability between pairs of states under the reflexive-transitive closure of the transition relation. *) 1236 | Definition greachable (g0 g : GState) : Prop := exists2 p, is_trace g0 p & g = last g0 p. 1237 | 1238 | (** Classic definition of reachable global state. *) 1239 | Definition GReachable (g0 g : GState) : Prop := clos_refl_trans_1n _ GTransition g0 g. 1240 | 1241 | (** We next prove that the above notions of reachability are equivalent in our setting. *) 1242 | 1243 | (** Our definition of reachability implies the classic definition of reachable states. *) 1244 | Lemma greachable_GReachable : forall g0 g, greachable g0 g -> GReachable g0 g. 1245 | Proof. 1246 | move => g0 g; case => x. 1247 | destruct x. inversion 1. 1248 | move => [H_g0 H_path]; subst g1. 1249 | revert H_path. 1250 | move: g0 g. 1251 | elim: x => /=; first by move => g0 g Ht ->; exact: rt1n_refl. 1252 | move => g1 p IH g0 g. 1253 | move/andP => [Hg Hp] Hgg. 1254 | have IH' := IH _ _ Hp Hgg. 1255 | move: IH'; apply: rt1n_trans. 1256 | by move: Hg; move/asboolP. 1257 | Qed. 1258 | 1259 | (** Classic definition of reachable states implies our definition of reachable states. *) 1260 | Lemma GReachable_greachable : forall g0 g, GReachable g0 g -> greachable g0 g. 1261 | Proof. 1262 | move => g0 g. 1263 | elim. move => x; exists [:: x]; done. 1264 | move => x y z Hxy Hc. 1265 | case => p Hp Hl. 1266 | unfold is_trace in Hp. 1267 | destruct p. contradiction. 1268 | destruct Hp as [Hy Hp]. 1269 | exists (x :: y :: p) => //=; last by subst. 1270 | unfold is_trace; split; first by []. 1271 | apply/andP. 1272 | by split => //; apply/asboolP. 1273 | Qed. 1274 | 1275 | (** ** Labeling global transitions *) 1276 | 1277 | (** Labels to classify transitions more abstractly. *) 1278 | Inductive GLabel : Type := 1279 | | lbl_tick : posreal -> GLabel 1280 | | lbl_deliver : UserId -> R -> Msg -> seq Msg -> GLabel 1281 | | lbl_step_internal : UserId -> seq Msg -> GLabel 1282 | | lbl_exit_partition : GLabel 1283 | | lbl_enter_partition : GLabel 1284 | | lbl_corrupt_user : UserId -> GLabel 1285 | | lbl_replay_msg : UserId -> GLabel 1286 | | lbl_forge_msg : UserId -> nat -> nat -> MessageType -> ExValue -> GLabel. 1287 | 1288 | (** Specify when labels classify a transition between pairs of global states. *) 1289 | Definition related_by (label : GLabel) (pre post : GState) : Prop := 1290 | match label with 1291 | | lbl_tick increment => 1292 | tick_ok increment pre /\ post = tick_update increment pre 1293 | | lbl_deliver uid deadline delivered_msg sent => 1294 | exists (key_ustate : uid \in pre.(users)) ustate_post, 1295 | uid # pre.(users).[key_ustate] ; delivered_msg ~> (ustate_post,sent) 1296 | /\ ~ pre.(users).[key_ustate].(corrupt) 1297 | /\ exists (key_mailbox : uid \in pre.(msg_in_transit)), 1298 | (deadline,delivered_msg) \in pre.(msg_in_transit).[key_mailbox] 1299 | /\ post = delivery_result pre uid key_mailbox (deadline,delivered_msg) ustate_post sent 1300 | | lbl_step_internal uid sent => 1301 | exists (key_user : uid \in pre.(users)) ustate_post, 1302 | ~ pre.(users).[key_user].(corrupt) /\ 1303 | uid # pre.(users).[key_user] ~> (ustate_post,sent) 1304 | /\ post = step_result pre uid ustate_post sent 1305 | | lbl_exit_partition => 1306 | is_partitioned pre /\ post = recover_from_partitioned pre 1307 | | lbl_enter_partition => 1308 | is_unpartitioned pre /\ post = make_partitioned pre 1309 | | lbl_corrupt_user uid => 1310 | exists (ustate_key : uid \in pre.(users)), 1311 | ~ pre.(users).[ustate_key].(corrupt) 1312 | /\ post = @corrupt_user_result pre uid ustate_key 1313 | | lbl_replay_msg uid => 1314 | exists (ustate_key : uid \in pre.(users)) msg, 1315 | ~ pre.(users).[ustate_key].(corrupt) 1316 | /\ msg \in pre.(msg_history) 1317 | /\ post = replay_msg_result pre uid msg 1318 | | lbl_forge_msg sender r p mtype mval => 1319 | exists (sender_key : sender \in pre.(users)) s, 1320 | have_keys pre.(users).[sender_key] r p s 1321 | /\ comm_cred_step sender r p s 1322 | /\ mtype_matches_step mtype mval s 1323 | /\ post = forge_msg_result pre sender r p mtype mval 1324 | end. 1325 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Algorand) 3 | (package coq-algorand) 4 | (synopsis "A verified model of the Algorand consensus protocol in Coq") 5 | (flags :standard -w -notation-overridden)) 6 | -------------------------------------------------------------------------------- /theories/fmap_ext.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import finmap. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Open Scope fmap_scope. 9 | Open Scope fset_scope. 10 | 11 | (** * General utility lemmas for finite maps *) 12 | 13 | Section CheckAllFmap. 14 | 15 | Variables (V : Type) (I : choiceType). 16 | 17 | Variable P : pred V. 18 | 19 | Variable f : {fmap I -> V}. 20 | 21 | Section AllFs. 22 | 23 | Variable s : {fset I}. 24 | 25 | (** Check the predicate [P] on given domain elements in the map [f]. *) 26 | Definition allfs := 27 | \big[andb/true]_(i <- s) (if f.[? i] is Some v then P v else true). 28 | 29 | Lemma allfsP : reflect (forall (i : I) (h : i \in domf f), i \in s -> P f.[h]) allfs. 30 | Proof. 31 | apply: (iffP idP); last first. 32 | rewrite /allfs big_seq. 33 | elim/big_ind: _ => //; last first. 34 | move => i Hs Hi. 35 | case Hf: (i \in domf f); last by rewrite not_fnd // Hf. 36 | rewrite (in_fnd Hf). 37 | exact: Hi. 38 | move => x y Hx Hy Hp. 39 | by apply/andP; split; [apply Hx|apply Hy]. 40 | move => Hb i Hi Hs. 41 | case Hp: (P _) => //. 42 | have Hip: f.[? i] = Some f.[Hi] by apply: in_fnd. 43 | move: Hb. 44 | set B : pred I := fun j => j == i. 45 | rewrite /allfs (big_fsetID _ B) /=. 46 | move/andP => [Ha Hb]. 47 | move: Ha. 48 | rewrite /B /=. 49 | suff Hsuff: [fset x | x in s & x == i] = [fset i]. 50 | by rewrite Hsuff big_seq_fset1 (in_fnd Hi) Hp. 51 | apply/fsetP => x. 52 | rewrite inE in_fsetE /= inE. 53 | apply/idP/idP; first by move/andP; case. 54 | by move/eqP =>->; rewrite Hs; apply/andP. 55 | Qed. 56 | 57 | End AllFs. 58 | 59 | Definition allf := allfs (domf f). 60 | 61 | Lemma allfP : reflect (forall (i : I) (h : i \in domf f), P f.[h]) allf. 62 | Proof. 63 | apply: (iffP idP); last by move => Hf; apply/allfsP. 64 | by move/allfsP => Hf i h; apply: Hf. 65 | Qed. 66 | 67 | End CheckAllFmap. 68 | 69 | Section UpdateAllFmap. 70 | 71 | Variables (V : Type) (I : choiceType). 72 | 73 | Variable P : pred V. 74 | 75 | Variable f : {fmap I -> V}. 76 | 77 | Variable s : {fset I}. 78 | 79 | (** Update function parameter for individual values. *) 80 | Variable upd : I -> V -> V. 81 | 82 | (** Update values for given elements in map domain. *) 83 | Definition updf' := 84 | \big[(@catf _ _)/[fmap]]_(i <- s) 85 | (if f.[? i] is Some v then [fmap].[i <- upd i v] else [fmap]). 86 | 87 | Lemma updf'_update : forall (i : I) (h : i \in domf f), 88 | i \in domf updf' -> updf'.[? i] = Some (upd i f.[h]). 89 | Proof. 90 | rewrite /updf'. 91 | elim/big_rec: _. 92 | move => i h. 93 | by rewrite /= in_fset0. 94 | move => i x Ht IH i0 h. 95 | case Hi: (i0 == i). 96 | move/eqP: Hi =><-. 97 | rewrite (in_fnd h) => Hi. 98 | rewrite /= fsetU0 in Hi. 99 | rewrite catf_setl. 100 | case: ifP => Hx'. 101 | rewrite cat0f. 102 | exact: IH. 103 | rewrite cat0f. 104 | move/negP/negP: Hx' => Hx'. 105 | rewrite in_fnd. 106 | rewrite dom_setf in_fsetU. 107 | apply/orP. 108 | left. 109 | by rewrite in_fset1. 110 | move => h'. 111 | by rewrite getf_set. 112 | have IH' := IH _ h. 113 | move/eqP: Hi => Hi. 114 | case Hii: (i \in domf f). 115 | rewrite (in_fnd Hii). 116 | rewrite [domf _]/=. 117 | rewrite {1}fsetU0. 118 | rewrite in_fsetU. 119 | case/orP. 120 | rewrite in_fsetD. 121 | move/andP => [H1 H2]. 122 | move: H2 Hi. 123 | rewrite in_fset1. 124 | by move/eqP. 125 | move => Hi0. 126 | have IH'' := IH' Hi0. 127 | rewrite -IH''. 128 | rewrite fnd_cat. 129 | case: ifP => //. 130 | by rewrite Hi0. 131 | move/negP/negP: Hii => Hii. 132 | by rewrite (not_fnd Hii) cat0f. 133 | Qed. 134 | 135 | Lemma updf'_domf : forall i, i \in domf updf' -> i \in domf f. 136 | Proof. 137 | rewrite /updf'. 138 | elim/big_rec: _ => //. 139 | move => i x Ht IH i0. 140 | case Hi0: (i == i0). 141 | move/eqP: Hi0 =>->. 142 | rewrite mem_catf. 143 | case/orP; last by exact: IH. 144 | case Hi0: (i0 \in domf f) => //. 145 | move/negP/negP: Hi0 => Hi0. 146 | by rewrite (not_fnd Hi0). 147 | rewrite mem_catf. 148 | case/orP; last by exact: IH. 149 | case Hi: (i \in domf f). 150 | rewrite (in_fnd Hi) mem_setf /= inE. 151 | move/eqP => Hii. 152 | move: Hi0. 153 | by rewrite Hii. 154 | move/negP/negP: Hi => Hi. 155 | by rewrite (not_fnd Hi). 156 | Qed. 157 | 158 | Lemma updf'_s : forall i, i \in domf updf' -> i \in s. 159 | Proof. 160 | rewrite /updf'. 161 | have ->: (\big[catf (V:=V)/[fmap]]_(i0 <- s) match f.[? i0] with | Some v => [fmap].[i0 <- upd i0 v] | None => [fmap] end) = 162 | (\big[catf (V:=V)/[fmap]]_(i0 <- s | i0 \in s) match f.[? i0] with | Some v => [fmap].[i0 <- upd i0 v] | None => [fmap] end). 163 | by rewrite big_seq. 164 | elim/big_rec: _ => //. 165 | move => i x Ht IH i0. 166 | case Hi0: (i0 \in domf x); first by move => Hi0'; apply: IH. 167 | move/negP/negP: Hi0 => Hi0. 168 | case Hi: (i \in domf f). 169 | rewrite (in_fnd Hi) /=. 170 | rewrite fsetU0 /=. 171 | rewrite in_fsetU. 172 | case/orP; last by move => Hi0'; case/negP: Hi0. 173 | rewrite in_fsetD. 174 | move/andP => [Ha Ha']. 175 | move: Ha'. 176 | rewrite in_fset1. 177 | by move/eqP =>->. 178 | move/negP/negP: Hi => Hi. 179 | rewrite (not_fnd Hi). 180 | rewrite mem_catf. 181 | case/orP => //. 182 | move => Hi0'. 183 | exact: IH. 184 | Qed. 185 | 186 | (** Update given domain elements while retaining original mapping for other elements. *) 187 | Definition updf := f + updf'. 188 | 189 | Lemma domf_s_updf' : forall i, i \in domf f -> (i \in enum_fset s) = (i \in domf updf'). 190 | Proof. 191 | rewrite /updf'. 192 | have Hs := fset_uniq s. 193 | rewrite unlock. 194 | elim: (enum_fset s) Hs => //=. 195 | move => a l IH. 196 | move/andP => [Ha Hu]. 197 | move/IH: Hu {IH} => IH. 198 | move => i Hi. 199 | rewrite in_cons in_fsetU. 200 | apply/idP/idP; first case/orP. 201 | - move => Haa. 202 | move: Hi; move/eqP: Haa=>-> => Hi. 203 | rewrite -IH //. 204 | rewrite (in_fnd Hi). 205 | apply/orP; left. 206 | rewrite in_fsetD. 207 | apply/andP; split; last by rewrite /= fsetU0 in_fset1. 208 | move: Ha. 209 | by rewrite IH. 210 | - move => Hf. 211 | apply/orP; right. 212 | by rewrite -IH. 213 | - case/orP; last first. 214 | rewrite -IH //. 215 | by move =>->; rewrite orbT. 216 | rewrite in_fsetD. 217 | rewrite -IH //. 218 | move/andP => [Hd Hf]. 219 | case Hia: (i == a); first by rewrite orbC orbT. 220 | move/negP: Hia; case. 221 | move: Hf. 222 | case Haa: (a \in domf f); first by rewrite (in_fnd Haa) /= fsetU0 in_fset1. 223 | move/negP/negP: Haa => Haa. 224 | by rewrite (not_fnd Haa). 225 | Qed. 226 | 227 | Lemma updf_update : forall (i : I) (h : i \in domf f), 228 | i \in s -> updf.[? i] = Some (upd i f.[h]). 229 | Proof. 230 | move => i h Hi. 231 | rewrite /updf fnd_cat. 232 | case: ifP; first by move => Hi'; apply: updf'_update. 233 | move/negP; case. 234 | by rewrite -domf_s_updf'. 235 | Qed. 236 | 237 | Lemma updf_update' : forall (i : I) (h : i \in domf f), 238 | i \notin s -> updf.[? i] = Some f.[h]. 239 | Proof. 240 | move => i h Hi. 241 | rewrite /updf. 242 | rewrite fnd_cat. 243 | case: ifP; first by move/updf'_s; move/negP: Hi. 244 | move/negP/negP. 245 | rewrite -domf_s_updf' // => Hs. 246 | by rewrite in_fnd. 247 | Qed. 248 | 249 | Lemma updf_domf : domf f = domf updf. 250 | Proof. 251 | apply/fsetP => x; apply/idP/idP. 252 | move => Hx. 253 | rewrite /updf domf_cat in_fsetU. 254 | by apply/orP; left. 255 | rewrite /updf domf_cat in_fsetU; case/orP => Hx //. 256 | exact: updf'_domf. 257 | Qed. 258 | 259 | End UpdateAllFmap. 260 | -------------------------------------------------------------------------------- /theories/liveness.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import finmap multiset. 3 | From Coq Require Import Reals Relation_Definitions Relation_Operators Lra. 4 | From mathcomp Require Import boolp Rstruct. 5 | From Algorand Require Import fmap_ext algorand_model safety_helpers quorums safety. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Open Scope mset_scope. 12 | Open Scope fmap_scope. 13 | Open Scope fset_scope. 14 | 15 | (** NOTE: This is only an initial attempt at specifying liveness 16 | properties for the transition system. This part is still 17 | work-in-progress and thus the file contains incomplete 18 | (admitted) proofs. *) 19 | 20 | Definition users_at ix path : {fmap UserId -> UState} := 21 | match drop ix path with 22 | | g1 :: _ => g1.(users) 23 | | _ => [fmap] 24 | end. 25 | 26 | Definition user_stv_val (uid:UserId) (g:GState) (p:nat) (stv':option Value) : bool := 27 | if g.(users).[? uid] is Some ustate then ustate.(stv).[? p] == stv' else false. 28 | 29 | Definition user_stv_val_at ix path uid p stv : bool := 30 | match drop ix path with 31 | | g1 :: _ => user_stv_val uid g1 p stv 32 | | _ => false 33 | end. 34 | 35 | (** ** Sensible states *) 36 | 37 | (** This notion specifies what states can be considered valid states. The idea 38 | is that we only consider execution traces that begin at sensible states, 39 | since sensibility is preserved by the transition system (to be shown), the 40 | set of reachable states will also be sensible (to be shown). This means that 41 | it is not important which specific state is assumed as the initial state as 42 | long as the state is sensible. 43 | Note: the traditional operational notion of an initial state is a now a 44 | special case of sensibility. *) 45 | Definition sensible_ustate (us : UState) : Prop := 46 | (us.(p_start) >= 0)%R /\ 47 | (0 <= us.(timer) <= us.(deadline))%R . 48 | 49 | Definition sensible_gstate (gs : GState) : Prop := 50 | (gs.(now) >= 0)%R /\ 51 | ~ gs.(users) = [fmap] /\ 52 | domf gs.(msg_in_transit) `<=` domf gs.(users) /\ (* needed? *) 53 | forall uid (k:uid \in gs.(users)), sensible_ustate gs.(users).[k]. 54 | (* more constraints if we add corrupt users map and total message history *) 55 | 56 | Lemma step_later_deadlines : forall s, 57 | s > 3 -> next_deadline s = (lambda + big_lambda + (INR s - 3) * L)%R. 58 | Proof. 59 | intros s H_s; clear -H_s. 60 | unfold next_deadline. 61 | do 3 (destruct s;[exfalso;apply not_false_is_true;assumption|]). 62 | reflexivity. 63 | Qed. 64 | 65 | (** The user transition relation preserves sensibility of user states. *) 66 | Lemma utr_msg_preserves_sensibility : forall uid us us' m ms, 67 | sensible_ustate us -> uid # us ; m ~> (us', ms) -> 68 | sensible_ustate us'. 69 | Proof. 70 | intros uid us us' m ms H_sensible Hstep; 71 | remember (us',ms) as ustep_output eqn:H_output; 72 | destruct Hstep; injection H_output; intros; subst; 73 | match goal with 74 | | [H_sensible : sensible_ustate ?s |- _] => is_var s; 75 | destruct s;unfold sensible_ustate in * |- *; 76 | decompose record H_sensible;clear H_sensible;simpl in * |- * 77 | end; 78 | autounfold with utransition_unfold in * |- *; 79 | match goal with 80 | | [H : context C [valid_rps] |- _] => unfold valid_rps in H;simpl in H;decompose record H 81 | | _ => idtac 82 | end; 83 | try by intuition lra. 84 | (* deliver nonvote msg needs some custom steps *) 85 | clear H_output. 86 | destruct msg as [mtype ex_val ? ? ?]; 87 | destruct ex_val;simpl;[destruct mtype;simpl|..];intuition lra. 88 | Qed. 89 | 90 | Lemma utr_nomsg_preserves_sensibility : forall uid us us' ms, 91 | sensible_ustate us -> uid # us ~> (us', ms) -> 92 | sensible_ustate us'. 93 | Proof. 94 | let use_hyp H := (unfold valid_rps in H;simpl in H; decompose record H) in 95 | let tidy _ := 96 | (match goal with 97 | | [ |- context C [ next_deadline (?s + 1 - 1) ] ] => 98 | replace (s + 1 - 1) with s by (rewrite addn1;rewrite subn1;symmetry;apply Nat.pred_succ) 99 | | [ H : is_true (3 < ?s) |- context C [next_deadline ?s] ] => 100 | rewrite (step_later_deadlines H) 101 | end) in 102 | intros uid us us' ms H_sensible Hstep; 103 | remember (us',ms) as ustep_output eqn:H_output; 104 | destruct Hstep; injection H_output; intros; subst; 105 | match goal with 106 | | [H_sensible : sensible_ustate ?s |- _] => is_var s; 107 | destruct s;unfold sensible_ustate in * |- *; 108 | decompose record H_sensible;clear H_sensible;simpl in * |- * 109 | end; 110 | try ( 111 | match goal with 112 | | [H: propose_ok _ _ _ _ _ _ |- _] => unfold propose_ok in H; use_hyp H 113 | | [H: repropose_ok _ _ _ _ _ |- _] => unfold repropose_ok in H; use_hyp H 114 | | [H: no_propose_ok _ _ _ _ |- _] => unfold no_propose_ok in H; use_hyp H 115 | | [H: softvote_new_ok _ _ _ _ _ |- _] => unfold softvote_new_ok in H; use_hyp H 116 | | [H: softvote_repr_ok _ _ _ _ _ |- _] => unfold softvote_repr_ok in H; use_hyp H 117 | | [H: no_softvote_ok _ _ _ _ |- _] => unfold no_softvote_ok in H; use_hyp H 118 | | [H: certvote_ok _ _ _ _ _ _ |- _] => unfold certvote_ok in H; use_hyp H 119 | | [H: no_certvote_ok _ _ _ _ |- _] => unfold no_certvote_ok in H; use_hyp H 120 | | [H: nextvote_val_ok _ _ _ _ _ _ _ |- _] => unfold nextvote_val_ok in H; use_hyp H 121 | | [H: nextvote_open_ok _ _ _ _ _ _ _ |- _] => unfold nextvote_open_ok in H; use_hyp H 122 | | [H: nextvote_stv_ok _ _ _ _ _ _ _ /\ _ |- _] => destruct H as [H Hs]; unfold nextvote_stv_ok in H; use_hyp H 123 | | [H: no_nextvote_ok _ _ _ _ _ |- _] => unfold no_nextvote_ok in H; use_hyp H 124 | | [H: set_softvotes _ _ _ _ |- _] => unfold set_softvotes in H; use_hyp H 125 | | [H: certvote_timeout_ok _ _ _ _ |- _] => unfold timout_ok in H; use_hyp H 126 | | _ => idtac 127 | end; 128 | repeat (tidy ());intuition lra). 129 | - split => //; split => //. 130 | by admit. 131 | - split => //; split => //. 132 | by admit. 133 | - split => //; split => //. 134 | by admit. 135 | - split => //; split => //. 136 | by admit. 137 | Admitted. 138 | 139 | (** The global transition relation preserves sensibility of global states. *) 140 | Lemma gtr_preserves_sensibility : forall gs gs', 141 | sensible_gstate gs -> GTransition gs gs' -> 142 | sensible_gstate gs'. 143 | Proof. 144 | let use_hyp H := (unfold valid_rps in H;simpl in H; decompose record H) in 145 | intros gs gs' H_sensible Hstep; 146 | destruct Hstep. 147 | 148 | * destruct pre. unfold tick_update, tick_users. simpl. 149 | admit. 150 | * apply utr_msg_preserves_sensibility in H1; 151 | [|unfold sensible_gstate in H_sensible;decompose record H_sensible;done]. 152 | destruct pre;unfold sensible_gstate in * |- *. 153 | unfold delivery_result;simpl in * |- *. 154 | { intuition. 155 | * move :H5. clear. 156 | move/(f_equal (fun f => uid \in f)). 157 | change (uid \in ?f) with (uid \in domf f). 158 | by rewrite dom_setf fset1U1 in_fset0. 159 | * admit. 160 | * rewrite ffunE. simpl. 161 | set test := (uid0 == uid);destruct test eqn:H_eq;subst test. 162 | assumption. 163 | change (uid0 \in ?f) with (uid0 \in domf f) in k. 164 | rewrite dom_setf in_fset1U H_eq /= in k. 165 | by rewrite in_fnd;apply H6. 166 | } 167 | * apply utr_nomsg_preserves_sensibility in H0; 168 | [|unfold sensible_gstate in H_sensible;decompose record H_sensible;done]. 169 | destruct pre;unfold sensible_gstate in * |- *. 170 | unfold step_result;simpl in * |- *. 171 | { intuition. 172 | * move:H4; clear. 173 | move/(f_equal (fun f => uid \in f)). 174 | change (uid \in ?f) with (uid \in domf f). 175 | by rewrite dom_setf fset1U1 in_fset0. 176 | * admit. 177 | * rewrite ffunE. simpl. 178 | set test := (uid0 == uid);destruct test eqn:H_eq;subst test. 179 | assumption. 180 | change (uid0 \in ?f) with (uid0 \in domf f) in k. 181 | rewrite dom_setf in_fset1U H_eq /= in k. 182 | by rewrite in_fnd;apply H5. 183 | } 184 | * (* recover from partition *) 185 | admit. 186 | * (* make partitioned *) 187 | admit. 188 | * (* corrupt user *) 189 | admit. 190 | * (* replay message *) 191 | admit. 192 | * (* forge message *) 193 | Admitted. 194 | 195 | (* Generalization of preservation of sensibility to paths *) 196 | Lemma greachable_preserves_sensibility : forall g0 g, 197 | greachable g0 g -> sensible_gstate g0 -> sensible_gstate g. 198 | Proof. 199 | move => g0 g [p Hp] Hg. 200 | destruct p. inversion Hp. 201 | unfold is_trace in Hp. 202 | destruct Hp as [Hg' Hpath]. 203 | subst g1. 204 | elim: p g0 g Hg Hpath => /= [g g0 Hg|]; first by rewrite Hg. 205 | move => g p IH g1 g0 Hl. 206 | move/andP => [Ht Hp] Hs. 207 | move/IH: Hp => Hp. 208 | move/Hp: Hl; apply. 209 | move: Ht. 210 | move/asboolP. 211 | exact: gtr_preserves_sensibility. 212 | Qed. 213 | 214 | Lemma at_most_one_certval_in_p 215 | g0 trace (H_path: is_trace g0 trace) 216 | r0 (H_start: state_before_round r0 g0): 217 | forall ix g, onth trace ix = Some g -> 218 | forall uid u, g.(users).[? uid] = Some u -> 219 | forall r, r0 <= r -> 220 | forall p v1 v2, 221 | v1 \in certvals u r p -> v2 \in certvals u r p -> v1 = v2. 222 | Proof. 223 | clear -H_path H_start. 224 | move => ix g H_onth uid u H_lookup r H_round p v1 v2. 225 | unfold certvals, vote_values, soft_weight. 226 | rewrite !mem_filter. 227 | move => /andP [Hv1_q Hv1in]. 228 | move => /andP [Hv2_q Hv2in]. 229 | have H_votes_checked := (softvote_credentials_checked H_path H_start H_onth H_lookup H_round). 230 | 231 | have Hq := quorums_s_honest_overlap trace. 232 | specialize (Hq r p 2 _ _ (H_votes_checked _ _) Hv1_q (H_votes_checked _ _) Hv2_q). 233 | 234 | move: Hq => [softvoter [H_voted_v1 [H_voted_v2 H_softvoter_honest]]]. 235 | assert (softvoted_in_path trace softvoter r p v1) as H_sent_v1. { 236 | apply (softvotes_sent H_path H_start H_onth H_lookup H_round). 237 | move:H_voted_v1 => /imfsetP /= [] x /andP [H_x_in]. 238 | unfold matchValue. destruct x. move => /eqP ? /= ?;subst. 239 | assumption. 240 | assumption. 241 | } 242 | assert (softvoted_in_path trace softvoter r p v2) as H_sent_v2. { 243 | apply (softvotes_sent H_path H_start H_onth H_lookup H_round). 244 | move:H_voted_v2 => /imfsetP /= [] x /andP [H_x_in]. 245 | unfold matchValue. destruct x. move => /eqP ? /= ?;subst. 246 | assumption. 247 | assumption. 248 | } 249 | move: H_sent_v1 => [ix_v1 H_sent_v1]. 250 | move: H_sent_v2 => [ix_v2 H_sent_v2]. 251 | 252 | by case:(no_two_softvotes_in_p H_path H_sent_v1 H_sent_v2). 253 | Qed. 254 | 255 | (** A user has (re-)proposed a value/block for a given round/period 256 | along a given path. *) 257 | Definition proposed_in_path_at ix path uid r p v b : Prop := 258 | exists g1 g2, step_in_path_at g1 g2 ix path /\ 259 | (user_sent uid (mkMsg Proposal (val v) r p uid) g1 g2 /\ 260 | user_sent uid (mkMsg Block (val b) r p uid) g1 g2 \/ 261 | user_sent uid (mkMsg Reproposal (repr_val v uid p) r p uid) g1 g2). 262 | 263 | (** A block proposer (potential leader) for a given round/period along a path. *) 264 | Definition block_proposer_in_path_at ix path uid r p v b : Prop := 265 | uid \in committee r p 1 /\ 266 | valid_block_and_hash b v /\ 267 | proposed_in_path_at ix path uid r p v b. 268 | 269 | (** The block proposer (the leader) for a given round/period along a path. *) 270 | Definition leader_in_path_at ix path uid r p v b : Prop := 271 | block_proposer_in_path_at ix path uid r p v b /\ 272 | forall id, id \in committee r p 1 /\ id <> uid -> 273 | (credential uid r p 1 < credential id r p 1)%O. 274 | 275 | (** A trace is partition-free if it is either empty or it is a valid trace that 276 | starts at an unparitioned state and does not involve a partitioning 277 | transition -- Note: not compatible with [is_trace] above. *) 278 | 279 | Definition partition_free g0 trace : Prop := 280 | is_trace g0 trace /\ 281 | is_unpartitioned g0 /\ 282 | forall n, ~ step_at trace n lbl_enter_partition. 283 | 284 | Lemma partition_state : forall g, 285 | is_unpartitioned g -> 286 | is_partitioned (make_partitioned g). 287 | Proof. 288 | intros g unp_H. 289 | unfold is_unpartitioned,is_partitioned in unp_H. 290 | unfold is_partitioned, make_partitioned, flip_partition_flag. 291 | simpl. assumption. 292 | Qed. 293 | 294 | (** [is_partitioned] as a proposition. *) 295 | Lemma is_partitionedP : forall g : GState, 296 | reflect 297 | (g.(network_partition) = true) 298 | (is_partitioned g). 299 | Admitted. 300 | 301 | Lemma partition_free_step : forall g0 g1, 302 | is_unpartitioned g0 -> GTransition g0 g1 -> 303 | ~ related_by lbl_enter_partition g0 g1 -> 304 | is_unpartitioned g1. 305 | Proof. 306 | intros g0 g1 g0unp_H g0g1step_H notpstep_H. 307 | unfold related_by in notpstep_H. intuition. 308 | unfold make_partitioned in H0. unfold flip_partition_flag in H0. simpl in * |- *. 309 | (* almost all cases are straightforward *) 310 | destruct g0g1step_H ; auto. 311 | (* except recover_from_partitioned, which is handled separately *) 312 | unfold is_unpartitioned in g0unp_H. rewrite H in g0unp_H. auto. 313 | Qed. 314 | 315 | Lemma partition_free_prefix : forall g0 n trace, 316 | n > 0 -> 317 | partition_free g0 trace -> 318 | partition_free g0 (take n trace). 319 | Proof. 320 | Admitted. 321 | 322 | Lemma partition_free_suffix : forall g0 n trace, 323 | n < size trace -> 324 | partition_free g0 trace -> 325 | partition_free g0 (drop n trace). 326 | Proof. 327 | Admitted. 328 | 329 | (* Whether the effect of a message is recored in the user state *) 330 | Definition message_recorded ustate msg : Prop := 331 | match msg_type msg, msg_ev msg with 332 | | Block, val b => 333 | let: r := msg_round msg in 334 | b \in ustate.(blocks) r 335 | | Proposal, val v => 336 | let: uid := msg_sender msg in 337 | let: r := msg_round msg in 338 | let: p := msg_period msg in 339 | exists c, (uid, c, v, true) \in ustate.(proposals) (r, p) 340 | | Reproposal, repr_val v uid' p' => 341 | let: uid := msg_sender msg in 342 | let: r := msg_round msg in 343 | let: p := msg_period msg in 344 | exists c, (uid, c, v, false) \in ustate.(proposals) (r, p) 345 | | Softvote, val v => 346 | let: uid := msg_sender msg in 347 | let: r := msg_round msg in 348 | let: p := msg_period msg in 349 | (uid, v) \in ustate.(softvotes) (r, p) 350 | | Certvote, val v => 351 | let: uid := msg_sender msg in 352 | let: r := msg_round msg in 353 | let: p := msg_period msg in 354 | (uid, v) \in ustate.(certvotes) (r, p) 355 | | Nextvote_Open, step_val s => 356 | let: uid := msg_sender msg in 357 | let: r := msg_round msg in 358 | let: p := msg_period msg in 359 | uid \in ustate.(nextvotes_open) (r, p, s) 360 | | Nextvote_Val, next_val v s => 361 | let: uid := msg_sender msg in 362 | let: r := msg_round msg in 363 | let: p := msg_period msg in 364 | (uid, v) \in ustate.(nextvotes_val) (r, p, s) 365 | | _, _ => True 366 | end. 367 | 368 | (** The effect of the message is recorded in the state of the target user on or 369 | before the message's deadline. *) 370 | Definition msg_timely_delivered msg deadline gstate target : Prop := 371 | Rle gstate.(now) deadline /\ 372 | exists ustate, gstate.(users).[? target] = Some ustate /\ 373 | message_recorded ustate msg. 374 | 375 | (** If a message is sent along a partition-free trace, and the trace is long enough, 376 | then the message is received by all honest users in a timely fashion. *) 377 | (* Note: this probably needs revision *) 378 | Lemma sent_msg_timely_received : forall sender msg g0 g1 trace, 379 | let deadline := msg_deadline msg g0.(now) in 380 | user_sent sender msg g0 g1 -> 381 | path gtransition g0 (g1 :: trace) -> 382 | partition_free g0 (g1 :: trace) -> 383 | Rle deadline (last g0 (g1 :: trace)).(now) -> 384 | exists ix g, ohead (drop ix (g1 :: trace)) = Some g 385 | /\ (forall target, target \in honest_users g.(users) -> 386 | msg_timely_delivered msg deadline g target). 387 | Proof. 388 | Admitted. 389 | 390 | 391 | (** If the block proposer of period [r,1] is honest, then a certificate for round [r] 392 | is produced at period [r,1]. *) 393 | (* Need the assumption of no partition?? *) 394 | Lemma prop_a : forall g0 g1 trace uid r v b, 395 | path gtransition g0 (g1 :: trace) -> 396 | partition_free g0 (g0 :: g1 :: trace) -> 397 | leader_in_path_at 0 (g0 :: g1 :: trace) uid r 1 v b -> 398 | user_honest_at 0 (g0 :: g1 :: trace) uid -> 399 | certified_in_period trace r 1 v. 400 | Proof. 401 | intros g0 g1 trace sender r v b tr_H pfree_tr_H leader_H honest_H. 402 | destruct leader_H as [proposer_H crommitte_H]. 403 | destruct proposer_H as [poleader_H [vb_H proposed_H]]. 404 | destruct proposed_H as [g' prop_sent_H]. 405 | destruct prop_sent_H as [g'' [prop_step_H prop_sent_H]]. destruct prop_step_H. subst. 406 | (* Need to identify: - the step and state at which the message is received 407 | - the user who is receiving the message *) 408 | destruct prop_sent_H as [propsent_H | repropsent_H]. 409 | destruct propsent_H as [propsent_H blocksent_H]. 410 | pose proof (@sent_msg_timely_received sender (mkMsg Proposal (val v) r 1 sender) g' g'' trace). simpl in * |- *. 411 | Admitted. 412 | 413 | 414 | (** If some period [r,p] for [p >= 2] is reached with unique starting value bot and the 415 | leader is honest, then the leader’s proposal is certified. *) 416 | (* TODO: all users need starting value bot or just leader? *) 417 | Lemma prop_c : forall ix path uid r p v b, 418 | p >= 2 -> 419 | all (fun u => user_stv_val_at ix path u p None) (domf (users_at ix path)) -> 420 | leader_in_path_at ix path uid r 1 v b -> 421 | user_honest_at ix path uid -> 422 | certified_in_period path r p v. 423 | Proof. 424 | Admitted. 425 | 426 | (** Softvote quorum of all honest users implies certvote quorum. *) 427 | Lemma honest_softvote_quorum_implies_certvote : forall (softvote_quorum : {fset UserId}) ix path r p v, 428 | (forall voter : UserId, voter \in softvote_quorum -> 429 | voter \in domf (honest_users (users_at ix path))) -> 430 | softvote_quorum `<=` committee r p 3 -> 431 | tau_c <= #|softvote_quorum| -> 432 | (forall voter : UserId, voter \in softvote_quorum 433 | -> softvoted_in_path_at ix path voter r p v) -> 434 | (forall voter : UserId, voter \in softvote_quorum 435 | -> certvoted_in_path path voter r p v). 436 | Proof. 437 | Abort. 438 | 439 | (** Honest user softvotes starting value. *) 440 | Lemma stv_not_bot_softvote : forall ix path r p v uid, 441 | uid \in domf (honest_users (users_at ix path)) -> 442 | user_stv_val_at ix path uid p (Some v) -> 443 | softvoted_in_path_at ix path uid r p v. 444 | Proof. 445 | Abort. 446 | 447 | (** If some period [r,p] with [p >= 2] is reached, and all honest users have starting 448 | value [H(B)], then a certificate for [H(B)] that period is produced by the honest users. *) 449 | (* TODO: need to say quorum for certificate is only *honest* users? *) 450 | Lemma prop_e : forall ix path r p v b, 451 | p >= 2 -> 452 | all (fun u => user_stv_val_at ix path u p (Some v)) 453 | (domf (honest_users (users_at ix path))) -> 454 | valid_block_and_hash b v -> 455 | certified_in_period path r p v. 456 | Proof. 457 | intros. 458 | exists (domf (honest_users (users_at ix path))). 459 | (* quorum subset of committee at step 3 *) 460 | assert (domf (honest_users (users_at ix path)) `<=` committee r p 3) by admit. 461 | (* at least t_H honest users *) 462 | assert (tau_c <= #|domf (honest_users (users_at ix path))|) by admit. 463 | repeat split; try assumption. 464 | Admitted. 465 | 466 | (** If any honest user is in period [r,p] with starting value bottom, then within 467 | time [(2*lambda+Lambda)], every honest user in period [r,p] will either certify a 468 | value (i.e., will get a certificate) or move to the next period. *) 469 | Lemma prop_f : forall r p g0 g1 g2 path_seq uid, 470 | path gtransition g0 path_seq -> 471 | g2 = last g0 path_seq -> 472 | g1 = last g0 (drop 1 path_seq) -> 473 | user_honest uid g1 -> 474 | user_stv_val uid g1 p None -> 475 | (exists v, certvoted_in_path path_seq uid r p v \/ 476 | period_advance_at 1 path_seq uid r p g1 g2). 477 | Proof. 478 | Admitted. 479 | -------------------------------------------------------------------------------- /theories/quorums.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import finmap multiset. 3 | From Coq Require Import Reals Relation_Definitions Relation_Operators. 4 | From mathcomp Require Import boolp Rstruct. 5 | From Algorand Require Import fmap_ext algorand_model safety_helpers. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Open Scope mset_scope. 12 | Open Scope fmap_scope. 13 | Open Scope fset_scope. 14 | 15 | (** * Quorum definitions and axioms *) 16 | 17 | (** This module contains core definitions and axioms related 18 | to quorums. *) 19 | 20 | (** ** Committees and quorum overlaps *) 21 | 22 | (** A committee is a set of users with sufficiently small credentials. *) 23 | Definition committee (r p s:nat) : {fset UserId} := 24 | [fset uid : UserId | `[] ]. 25 | 26 | (** Any two quorums must both contain an honest voter. *) 27 | Definition quorum_honest_overlap_statement tau : Prop := 28 | forall trace r p s (quorum1 quorum2 : {fset UserId}), 29 | quorum1 `<=` committee r p s -> 30 | #|` quorum1 | >= tau -> 31 | quorum2 `<=` committee r p s -> 32 | #|` quorum2 | >= tau -> 33 | exists honest_voter, 34 | honest_voter \in quorum1 35 | /\ honest_voter \in quorum2 36 | /\ honest_during_step (r,p,s) honest_voter trace. 37 | 38 | (** A single quorum must have an honest voter. *) 39 | Definition quorum_has_honest_statement tau : Prop := 40 | forall trace r p s (quorum : {fset UserId}), 41 | quorum `<=` committee r p s -> 42 | #|` quorum | >= tau -> 43 | exists honest_voter, honest_voter \in quorum /\ 44 | honest_during_step (r,p,s) honest_voter trace. 45 | 46 | (** Specialize two quorum statement to one quorum. *) 47 | Lemma quorum_has_honest_from_overlap_stmt tau: 48 | quorum_honest_overlap_statement tau -> 49 | quorum_has_honest_statement tau. 50 | Proof. 51 | clear. 52 | intros H_overlap trace r p s q H_q H_size. 53 | destruct (H_overlap trace _ _ _ _ _ H_q H_size H_q H_size) as [honest_voter H]. 54 | exists honest_voter;tauto. 55 | Qed. 56 | 57 | (** One major purpose of cryptographic self-selection is 58 | to ensure an adversary cannot predict which users will be part 59 | of a future committee, so any manipulation targeting a subset 60 | of users should hit a similar fraction of the users which are 61 | on and not on a committee (up to reasonable statistical variance). *) 62 | 63 | (** For the proofs we need to be able to relate the membership of different 64 | committees. Intuitively, if a supermajority of one committee satisfies 65 | some time-independent property (such as having voted a certain way in 66 | a particular past round) then also a majority of honest users as a 67 | whole satisfy this property, and then it's overwhelmingly unlikely 68 | that another committee could contain a supermajority that does not 69 | satisfy the property, because most users do. *) 70 | 71 | (** However, this intuitive argument clearly fails for some properties 72 | like being a member of a specific committee (which is true for 73 | a supermajority of that committee despite failing for a majority 74 | of honest users as a whole), so only assume statments for 75 | particular properties of interest. *) 76 | 77 | (** In fact, it seems that for safety we only need to invoke this 78 | condition with the property being whether a node decided 79 | to certvote for a value in some step 3. For honest nodes not 80 | on a committee the node "decides to certvote" if they receive 81 | enough softvotes for the value, even though they do not actually 82 | try to transmit a certvote message unless they are in the 83 | committee). *) 84 | 85 | Definition interquorum_property tau1 tau2 (P: UserId -> Prop) trace := 86 | forall r1 p1 s1 (quorum1 : {fset UserId}), 87 | quorum1 `<=` committee r1 p1 s1 -> 88 | #|` quorum1 | >= tau1 -> 89 | (forall uid, uid \in quorum1 -> 90 | honest_during_step (r1,p1,s1) uid trace -> 91 | P uid) -> 92 | forall r2 p2 s2 (quorum2 : {fset UserId}), 93 | quorum2 `<=` committee r2 p2 s2 -> 94 | #|` quorum2 | >= tau2 -> 95 | (exists honest_P_uid, honest_P_uid \in quorum2 96 | /\ P honest_P_uid 97 | /\ honest_during_step (r2,p2,s2) honest_P_uid trace). 98 | 99 | Axiom quorums_s_honest_overlap : quorum_honest_overlap_statement tau_s. 100 | Definition quorum_s_has_honest : quorum_has_honest_statement tau_s 101 | := quorum_has_honest_from_overlap_stmt quorums_s_honest_overlap. 102 | 103 | Axiom quorums_c_honest_overlap : quorum_honest_overlap_statement tau_c. 104 | Definition quorum_c_has_honest : quorum_has_honest_statement tau_c 105 | := quorum_has_honest_from_overlap_stmt quorums_c_honest_overlap. 106 | 107 | Axiom quorums_b_honest_overlap : quorum_honest_overlap_statement tau_b. 108 | Definition quorum_b_has_honest : quorum_has_honest_statement tau_b 109 | := quorum_has_honest_from_overlap_stmt quorums_b_honest_overlap. 110 | 111 | Axiom quorums_v_honest_overlap : quorum_honest_overlap_statement tau_v. 112 | Definition quorum_v_has_honest : quorum_has_honest_statement tau_v 113 | := quorum_has_honest_from_overlap_stmt quorums_v_honest_overlap. 114 | 115 | Definition saw_v trace r p v := fun uid => 116 | has (fun g => 117 | match (g.(users)).[? uid] with 118 | | None => false 119 | | Some u => 120 | [&& v \in certvals u r p, 121 | has (fun b => `[< valid_block_and_hash b v>]) (u.(blocks) r) & 122 | step_leb (step_of_ustate u) (r,p,4)] 123 | end) trace. 124 | 125 | Axiom interquorum_c_v_certinfo: 126 | forall trace r p v, 127 | interquorum_property tau_c tau_v (saw_v trace r p v) trace. 128 | Axiom interquorum_c_b_certinfo: 129 | forall trace r p v, 130 | interquorum_property tau_c tau_b (saw_v trace r p v) trace. 131 | 132 | (** ** Definitions of voting and sufficient votes *) 133 | 134 | (** A user has certvoted at a specifix index along a path. *) 135 | Definition certvoted_in_path_at ix path uid r p v : Prop := 136 | user_sent_at ix path uid (mkMsg Certvote (val v) r p uid). 137 | 138 | (** A user has certvoted along a path. *) 139 | Definition certvoted_in_path path uid r p v : Prop := 140 | exists ix, certvoted_in_path_at ix path uid r p v. 141 | 142 | (** Value [v] was certified in a given round/period along a path. *) 143 | Definition certified_in_period trace r p v := 144 | exists (certvote_quorum:{fset UserId}), 145 | certvote_quorum `<=` committee r p 3 146 | /\ #|` certvote_quorum | >= tau_c 147 | /\ forall (voter:UserId), voter \in certvote_quorum -> 148 | certvoted_in_path trace voter r p v. 149 | 150 | (** A user has softvoted at a specific index along a path. *) 151 | Definition softvoted_in_path_at ix path uid r p v : Prop := 152 | exists g1 g2, step_in_path_at g1 g2 ix path 153 | /\ user_sent uid (mkMsg Softvote (val v) r p uid) g1 g2. 154 | 155 | (** A user has softvoted along a path. *) 156 | Definition softvoted_in_path path uid r p v : Prop := 157 | exists ix, softvoted_in_path_at ix path uid r p v. 158 | 159 | (** Enough softvotes for a value [v] in a given round/period along a path. *) 160 | Definition enough_softvotes_in_period trace r p v := 161 | exists (softvote_quorum:{fset UserId}), 162 | softvote_quorum `<=` committee r p 2 163 | /\ #|` softvote_quorum | >= tau_s 164 | /\ forall (voter:UserId), voter \in softvote_quorum -> 165 | softvoted_in_path trace voter r p v. 166 | 167 | (** A user has nextvoted bottom at a specific index along a path. *) 168 | Definition nextvoted_bot_in_path_at ix path uid (r p s:nat) : Prop := 169 | exists g1 g2, step_in_path_at g1 g2 ix path 170 | /\ user_sent uid (mkMsg Nextvote_Open (step_val s) r p uid) g1 g2. 171 | 172 | (** A user has nextvoted bottom along a path. *) 173 | Definition nextvoted_bot_in_path path uid r p s : Prop := 174 | exists ix, nextvoted_bot_in_path_at ix path uid r p s. 175 | 176 | (** Enough nextvotes for bottom in a given round/period along a path. *) 177 | Definition enough_nextvotes_bot_in_step trace r p s := 178 | exists (nextvote_quorum:{fset UserId}), 179 | nextvote_quorum `<=` committee r p s 180 | /\ #|` nextvote_quorum | >= tau_b 181 | /\ forall (voter:UserId), voter \in nextvote_quorum -> 182 | nextvoted_bot_in_path trace voter r p s. 183 | 184 | (** A user has nextvoted for a value [v] at a specific index along a path. *) 185 | Definition nextvoted_val_in_path_at ix path uid r p s v : Prop := 186 | exists g1 g2, step_in_path_at g1 g2 ix path 187 | /\ user_sent uid (mkMsg Nextvote_Val (next_val v s) r p uid) g1 g2. 188 | 189 | (** A user has nextvoted for a value [v] along a path. *) 190 | Definition nextvoted_val_in_path path uid r p s v : Prop := 191 | exists ix, nextvoted_val_in_path_at ix path uid r p s v. 192 | 193 | (** Enough nextvotes for a value [v] in a given round/period along a path. *) 194 | Definition enough_nextvotes_val_in_step trace r p s v := 195 | exists (nextvote_quorum:{fset UserId}), 196 | nextvote_quorum `<=` committee r p s 197 | /\ #|` nextvote_quorum | >= tau_v 198 | /\ forall (voter:UserId), voter \in nextvote_quorum -> 199 | nextvoted_val_in_path trace voter r p s v. 200 | -------------------------------------------------------------------------------- /theories/safety_helpers.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import finmap multiset. 3 | From mathcomp Require Import zify. 4 | From Coq Require Import Reals Relation_Definitions Relation_Operators. 5 | From mathcomp Require Import boolp Rstruct. 6 | From Algorand Require Import fmap_ext algorand_model. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Open Scope mset_scope. 13 | Open Scope fmap_scope. 14 | Open Scope fset_scope. 15 | 16 | (** * Safety helper definitions and results *) 17 | 18 | (** This module contains helper functions and lemmas 19 | used when proving safety of the transition system. *) 20 | 21 | Ltac finish_case := simpl;solve[repeat first[reflexivity|eassumption|split|eexists]]. 22 | 23 | (** Gather all the unfoldings we might want for working with transitions into 24 | a hint database for use with autounfold. *) 25 | Create HintDb utransition_unfold discriminated. 26 | #[export] Hint Unfold 27 | (* UTransitionInternal *) 28 | propose_result propose_ok repropose_ok no_propose_ok 29 | softvote_result softvote_new_ok softvote_repr_ok no_softvote_ok 30 | certvote_result certvote_ok no_certvote_ok 31 | nextvote_result nextvote_val_ok nextvote_open_ok nextvote_stv_ok no_nextvote_ok 32 | certvote_timeout_ok 33 | (* UTransitionMsg *) 34 | set_softvotes certvote_ok certvote_result 35 | set_nextvotes_open adv_period_open_ok adv_period_open_result 36 | set_nextvotes_val adv_period_val_ok adv_period_val_result 37 | set_certvotes certify_ok certify_result 38 | vote_msg deliver_nonvote_msg_result : utransition_unfold. 39 | 40 | Create HintDb gtransition_unfold discriminated. 41 | #[export] Hint Unfold 42 | tick_ok tick_update tick_users 43 | delivery_result 44 | step_result 45 | is_partitioned recover_from_partitioned 46 | is_unpartitioned make_partitioned 47 | corrupt_user_result : gtransition_unfold. 48 | 49 | Arguments delivery_result : clear implicits. 50 | 51 | (** ** Generic path lemmas *) 52 | 53 | (** Dropping elements from a path still results in a path. *) 54 | Lemma path_drop T (R:rel T) x p (H:path R x p) n: 55 | match drop n p with 56 | | List.nil => true 57 | | List.cons x' p' => path R x' p' 58 | end. 59 | Proof. 60 | by elim: n x p H=> [|n IHn] x [|a l /andP [] H_path];last apply IHn. 61 | Qed. 62 | 63 | Lemma path_drop' T (R:rel T) x p (H:path R x p) n: 64 | match drop n (x::p) with 65 | | [::] => true 66 | | [:: x' & p'] => path R x' p' 67 | end. 68 | Proof. 69 | elim: n x p H=> [|n IHn] x p H_path //=. 70 | move/IHn: {IHn}H_path. 71 | destruct n;simpl. 72 | by destruct p;[|move/andP => []]. 73 | rewrite -add1n -drop_drop. 74 | by destruct (drop n p);[|destruct l;[|move/andP => []]]. 75 | Qed. 76 | 77 | (** Predicate [path] still holds after taking [n] elements. *) 78 | Lemma path_prefix : forall T R p (x:T) n, 79 | path R x p -> path R x (take n p). 80 | Proof. 81 | induction p;[done|]. 82 | move => /= x n /andP [Hr Hpath]. 83 | destruct n. done. 84 | simpl;apply /andP;by auto. 85 | Qed. 86 | 87 | (** Proposition does not hold initially but holds for last element implies there 88 | must be a point in the path where it becomes true. *) 89 | Lemma path_steps : forall {T} (R : rel T) x0 p, 90 | path R x0 p -> 91 | forall (P : pred T), 92 | ~~ P x0 -> P (last x0 p) -> 93 | exists n, 94 | match drop n (x0 :: p) with 95 | | x1 :: x2 :: _ => ~~ P x1 && P x2 96 | | _ => false 97 | end. 98 | Proof. 99 | clear. 100 | intros T R x0 p H_path P H_x0. 101 | revert p H_path. induction p using last_ind. 102 | * simpl. intros _ H_b. exfalso. revert H_b. apply /negP. assumption. 103 | * rewrite last_rcons. rewrite rcons_path. 104 | move => /andP [H_path H_step] H_x. 105 | destruct (P (last x0 p)) eqn:H_last. 106 | + destruct IHp as [n' Hind];[done..|]. exists n'. 107 | destruct n';simpl in Hind |- *. destruct p;[by exfalso|assumption]. 108 | destruct (ltnP n' (size p));[|by (rewrite drop_oversize in Hind)]. 109 | rewrite drop_rcons;[destruct (drop n' p) as [|? [|]];[done..|tauto]|]. 110 | apply ltnW;assumption. 111 | + clear IHp. exists (size p). 112 | destruct (size p) eqn:H_size. simpl. 113 | rewrite (size0nil H_size) in H_last |- *. simpl. by apply/andP. 114 | simpl. 115 | rewrite (drop_nth x0). 116 | rewrite <- cats1, <- H_size. 117 | rewrite drop_size_cat;[|reflexivity]. 118 | rewrite nth_cat. 119 | rewrite H_size ltnSn. 120 | change n with (n.+1.-1). 121 | rewrite <- H_size, nth_last, H_last. 122 | simpl. assumption. 123 | rewrite size_rcons H_size. 124 | rewrite ltnS. apply leqnSn. 125 | Qed. 126 | 127 | (** ** Generic multiset lemmas *) 128 | 129 | (** Element [x] in mset of seq iff [x] is in seq. *) 130 | Lemma in_seq_mset (T : choiceType) (x : T) (s : seq T): 131 | (x \in seq_mset s) = (x \in s). 132 | Proof. 133 | apply perm_mem, perm_eq_seq_mset. 134 | Qed. 135 | 136 | (** The number of elements in the preimage of [f] w.r.t. [b] and multiset [m] is 137 | the same as applying [map_mset] on [f] and [m] and then [b]. *) 138 | Lemma map_mset_count {A B :choiceType} (f: A -> B) (m : {mset A}) : 139 | forall (b:B), (count (preim f (pred1 b)) m) = (map_mset f m) b. 140 | Proof. 141 | move => b. 142 | unfold map_mset. 143 | move: {m}(EnumMset.f m) => l. 144 | by rewrite mset_seqE count_map. 145 | Qed. 146 | 147 | (** Element membership w.r.t. preimage is preserved by [map_mset] on the multiset [m]. *) 148 | Lemma map_mset_has {A B :choiceType} (f: A -> B) (m : {mset A}) : 149 | forall (b:pred B), has b (map_mset f m) = has (preim f b) m. 150 | Proof. 151 | move => b. 152 | rewrite -has_map. 153 | by apply eq_has_r, perm_mem, perm_eq_seq_mset. 154 | Qed. 155 | 156 | (** The support of a multiset is unique when viewed as a sequence. *) 157 | Lemma finsupp_mset_uniq (T:choiceType) (A:{mset T}): 158 | uniq (finsupp A). 159 | Proof. 160 | by rewrite -(perm_uniq (perm_undup_mset A));apply undup_uniq. 161 | Qed. 162 | 163 | (** The sequence of a subset of a multiset is equal to the subset's finite support modulo reordering. *) 164 | Lemma msubset_finsupp (T:choiceType) (A B: {mset T}): 165 | (A `<=` B)%mset -> 166 | perm_eq (finsupp A) [seq i <- finsupp B | i \in A]. 167 | Proof. 168 | move=>H_sub. 169 | apply uniq_perm. 170 | by apply finsupp_mset_uniq. 171 | by apply filter_uniq;apply finsupp_mset_uniq. 172 | move=>x. 173 | rewrite mem_filter. 174 | rewrite !msuppE. 175 | rewrite andb_idr //. 176 | move:H_sub => /msubset_subset. apply. 177 | Qed. 178 | 179 | (** Summing up elements in a multiset subset is the same as taking sequence length. *) 180 | Lemma msubset_size_sum (T:choiceType) (A B: {mset T}): 181 | (A `<=` B)%mset -> 182 | \sum_(i <- finsupp B) A i = size A. 183 | Proof. 184 | move=>H_sub. 185 | rewrite (bigID (fun i => i \in A)) /= -big_filter. 186 | rewrite -(perm_big _ (msubset_finsupp H_sub)) -size_mset big1. 187 | by rewrite addn0. 188 | by move=>i /mset_eq0P. 189 | Qed. 190 | 191 | (** The size of a unioned multiset is sum of the size of its components. *) 192 | Lemma mset_add_size (T:choiceType) (A B : {mset T}): 193 | size (A `+` B) = (size A + size B)%nat. 194 | Proof. 195 | rewrite size_mset (eq_bigr (fun a => A a + B a)%nat);[|by move => ? _;rewrite msetE2]. 196 | rewrite big_split !msubset_size_sum //. 197 | rewrite -{1}[B]mset0D. apply msetSD, msub0set. 198 | rewrite -{1}[A]msetD0. apply msetDS, msub0set. 199 | Qed. 200 | 201 | (** The size of [msetn n x] is [n] for any [x]. *) 202 | Lemma msetn_size (T:choiceType) n (x:T): 203 | size (msetn n x) = n. 204 | Proof. 205 | rewrite size_mset finsupp_msetn. 206 | case:n=>[|n] /=. 207 | exact: big_nil. 208 | by rewrite big_seq_fset1 msetnxx. 209 | Qed. 210 | 211 | (** The subset of a multiset has smaller size. *) 212 | Lemma msubset_size (T:choiceType) (A B : {mset T}): 213 | (A `<=` B)%mset -> size A <= size B. 214 | Proof. 215 | move=>H_sub. 216 | by rewrite -(msetBDK H_sub) mset_add_size leq_addl. 217 | Qed. 218 | 219 | (** If msets are equal after adding seqs to mset [A], this implies seqs have the same elements. *) 220 | Lemma msetD_seq_mset_perm_eq (T:choiceType) (A: {mset T}) (l l': seq T): 221 | A `+` seq_mset l = A `+` seq_mset l' -> perm_eq l l'. 222 | Proof. 223 | move/(f_equal (msetB^~A)); rewrite !msetDKB => H_seq_eq. 224 | apply/(perm_trans _ (perm_eq_seq_mset l')). 225 | rewrite perm_sym -H_seq_eq. 226 | by apply perm_eq_seq_mset. 227 | Qed. 228 | 229 | (** ** Generic sequence lemmas *) 230 | 231 | Lemma in_memP (T : eqType) (x : T) l : reflect (List.In x l) (in_mem x (mem l)). 232 | Proof. 233 | apply iffP with (P := x \in l). 234 | - by case: (x \in l) => //; constructor. 235 | - elim: l => [|h l IH] //=. 236 | rewrite inE; case/orP; first by move/eqP=>->; left. 237 | by move/IH => mem_x; right. 238 | - elim: l => [|h l IH] //=; case. 239 | by move =>->; rewrite inE; apply/orP; left. 240 | by move/IH; rewrite inE => mem_x; apply/orP; right. 241 | Qed. 242 | 243 | Lemma take_rcons T : forall (s : seq T) (x : T), take (size s) (rcons s x) = s. 244 | Proof. elim => //=; last by move => a l IH x; rewrite IH. Qed. 245 | 246 | Lemma perm_eq_cons1P (T : eqType) (s : seq T) (a : T) : reflect (s = [:: a]) (perm_eq s [:: a]). 247 | Proof. 248 | case: s => [|x s]; first by rewrite /perm_eq /= ?eqxx; constructor. 249 | case: s => [|y s]. 250 | apply: (iffP idP). 251 | rewrite /perm_eq /= ?eqxx. 252 | move/andP => [Ht Ht']. 253 | move: Ht. 254 | case Hax: (a == x) => //. 255 | by move/eqP: Hax =>->. 256 | by move =>->; apply perm_refl. 257 | apply: (iffP idP) => //. 258 | set s1 := [:: _ & _]. 259 | set s2 := [:: _]. 260 | move => Hpr. 261 | by have Hs: size s1 = size s2 by apply perm_size. 262 | Qed. 263 | 264 | (** ** Lemmas relating seqs and sets *) 265 | 266 | (** A set derived from an empty seq is the empty set. *) 267 | Lemma set_nil : forall (T : finType), [set x in [::]] = @set0 T. 268 | Proof. by move => T. Qed. 269 | 270 | (** The cardinality of seq as set is size of the unduplicated seq. *) 271 | Lemma finseq_size : forall (T : finType) (s: seq T), #|s| = size (undup s). 272 | Proof. 273 | move=> T s. 274 | rewrite -cardsE. 275 | elim: s => //=; first by rewrite set_nil cards0. 276 | move => x s IH. 277 | rewrite set_cons /=. 278 | case: ifP => //=. 279 | move => xs. 280 | suff Hsuff: x |: [set x0 in s] = [set x in s] by rewrite Hsuff. 281 | apply/setP => y. 282 | rewrite in_setU1. 283 | case Hxy: (y == x) => //. 284 | rewrite /= inE. 285 | by move/eqP: Hxy=>->. 286 | move/negP/negP => Hx. 287 | by rewrite cardsU1 /= inE Hx /= add1n IH. 288 | Qed. 289 | 290 | (** A set derived using filter in seq and filter directly have same size. *) 291 | Lemma imfset_filter_size_lem (A B : choiceType) (f : A -> B) (sq : seq A) (P : A -> bool): 292 | #|` [fset x | x in [seq f x | x <- sq & P x]]| = #|` [fset f x | x in sq & P x]|. 293 | Proof. 294 | clear -f sq P. 295 | rewrite Imfset.imfsetE !size_seq_fset. 296 | apply perm_size, uniq_perm;[apply undup_uniq..|]. 297 | intro fx. rewrite !mem_undup map_id /= filter_undup mem_undup. 298 | apply Bool.eq_true_iff_eq;rewrite -!/(is_true _). 299 | by split;move/mapP => [x H_x ->];apply map_f;move:H_x;rewrite mem_undup. 300 | Qed. 301 | 302 | (** ** Generic definitions *) 303 | 304 | (** Turn [pred] on [UState] into [pred] on [GState] - assumed false if [uid] not present. *) 305 | Definition upred uid (P : pred UState) : pred GState := 306 | fun g => 307 | match g.(users).[? uid] with 308 | | Some u => P u 309 | | None => false 310 | end. 311 | 312 | (** Turn [pred] on [UState] into [pred] on [GState] - assumed true if [uid] not present. *) 313 | Definition upred' uid (P : pred UState) : pred GState := 314 | fun g => 315 | match g.(users).[? uid] with 316 | | Some u => P u 317 | | None => true 318 | end. 319 | 320 | (** ** Lemmas about the step of a user state *) 321 | 322 | (** [step_le] is equivalent to [step_leb]. *) 323 | Lemma step_leP: forall s1 s2, reflect (step_le s1 s2) (step_leb s1 s2). 324 | Proof. 325 | clear. 326 | move => [[r1 p1] s1] [[r2 p2] s2]. 327 | case H:(step_leb _ _);constructor;[|move/negP in H]; 328 | by rewrite /step_le !(reflect_eq eqP, reflect_eq andP, reflect_eq orP). 329 | Qed. 330 | 331 | (** [step_lt] is equivalent to [step_ltb]. *) 332 | Lemma step_ltP: forall s1 s2, reflect (step_lt s1 s2) (step_ltb s1 s2). 333 | Proof. 334 | clear. 335 | move => [[r1 p1] s1] [[r2 p2] s2]. 336 | case H:(step_ltb _ _);constructor;[|move/negP in H]; 337 | by rewrite /step_lt !(reflect_eq eqP, reflect_eq andP, reflect_eq orP). 338 | Qed. 339 | 340 | (** Weaken step: less-than implies less-than-or-equal. *) 341 | Lemma step_ltW a b: 342 | step_lt a b -> step_le a b. 343 | Proof. 344 | clear. 345 | destruct a as [[? ?] ?],b as [[? ?]?]. 346 | unfold step_lt,step_le;intuition. 347 | Qed. 348 | 349 | (** Transitivitity of [step_le]. *) 350 | Lemma step_le_trans a b c: 351 | step_le a b -> step_le b c -> step_le a c. 352 | Proof. 353 | destruct a as [[? ?] ?],b as [[? ?]?],c as [[? ?]?]. 354 | unfold step_le. 355 | intros H_ab H_bc. 356 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 357 | [eapply ltn_trans;eassumption|assumption|assumption|]; 358 | right;split;[reflexivity|];clear -H_ab H_bc. 359 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 360 | [eapply ltn_trans;eassumption|assumption|assumption|]; 361 | right;split;[reflexivity|];clear -H_ab H_bc. 362 | eapply leq_trans;eassumption. 363 | Qed. 364 | 365 | (** Transitivity of [step_lt]. *) 366 | Lemma step_lt_trans a b c: 367 | step_lt a b -> step_lt b c -> step_lt a c. 368 | Proof. 369 | destruct a as [[? ?] ?],b as [[? ?]?],c as [[? ?]?]. 370 | unfold step_lt. 371 | intros H_ab H_bc. 372 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 373 | [eapply ltn_trans;eassumption|assumption|assumption|]; 374 | right;split;[reflexivity|];clear -H_ab H_bc. 375 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 376 | [eapply ltn_trans;eassumption|assumption|assumption|]; 377 | right;split;[reflexivity|];clear -H_ab H_bc. 378 | eapply ltn_trans;eassumption. 379 | Qed. 380 | 381 | (** [a < b] and [b <= c] implies [a < c]. *) 382 | Lemma step_lt_le_trans a b c: 383 | step_lt a b -> step_le b c -> step_lt a c. 384 | Proof. 385 | destruct a as [[? ?] ?],b as [[? ?]?],c as [[? ?]?]. 386 | unfold step_lt, step_le. 387 | intros H_ab H_bc. 388 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 389 | [eapply ltn_trans;eassumption|assumption|assumption|]; 390 | right;split;[reflexivity|];clear -H_ab H_bc. 391 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 392 | [eapply ltn_trans;eassumption|assumption|assumption|]; 393 | right;split;[reflexivity|];clear -H_ab H_bc. 394 | eapply leq_trans;eassumption. 395 | Qed. 396 | 397 | (** [a <= b] and [b < c] implies [a < c]. *) 398 | Lemma step_le_lt_trans a b c: 399 | step_le a b -> step_lt b c -> step_lt a c. 400 | Proof. 401 | destruct a as [[? ?] ?],b as [[? ?]?],c as [[? ?]?]. 402 | unfold step_lt, step_le. 403 | intros H_ab H_bc. 404 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 405 | [eapply ltn_trans;eassumption|assumption|assumption|]; 406 | right;split;[reflexivity|];clear -H_ab H_bc. 407 | destruct H_ab as [H_ab|[-> H_ab]];destruct H_bc as [H_bc|[-> H_bc]];[left..|]; 408 | [eapply ltn_trans;eassumption|assumption|assumption|]; 409 | right;split;[reflexivity|];clear -H_ab H_bc. 410 | eapply leq_ltn_trans;eassumption. 411 | Qed. 412 | 413 | (** [step] is not less than itself. *) 414 | Lemma step_lt_irrefl r p s: ~step_lt (r,p,s) (r,p,s). 415 | Proof. 416 | rewrite /step_lt => Hrp; case: Hrp; rewrite ltnn //. 417 | by case => ?; rewrite ltnn; case => //; case. 418 | Qed. 419 | 420 | (** [step] is less than or equal to itself. *) 421 | Lemma step_le_refl step: step_le step step. 422 | Proof. 423 | clear;unfold step_le;intuition. 424 | Qed. 425 | 426 | (** [ustate_after] and [step_le] are equivalent. *) 427 | Lemma ustate_after_iff_step_le u1 u2: 428 | step_le (step_of_ustate u1) (step_of_ustate u2) 429 | <-> ustate_after u1 u2. 430 | Proof. 431 | unfold ustate_after;destruct u1, u2;simpl. 432 | clear;tauto. 433 | Qed. 434 | 435 | (** Transitivity of [ustate_after]. *) 436 | Lemma ustate_after_transitive : 437 | forall us1 us2 us3, 438 | ustate_after us1 us2 -> 439 | ustate_after us2 us3 -> 440 | ustate_after us1 us3. 441 | Proof. 442 | move => us1 us2 us3. 443 | rewrite -!ustate_after_iff_step_le. 444 | apply step_le_trans. 445 | Qed. 446 | 447 | (** ** Lemmas about tick functions *) 448 | 449 | (** [tick_ok_users] function as a predicate. *) 450 | Lemma tick_ok_usersP : forall increment (g : GState), 451 | reflect 452 | (forall (uid : UserId) (h : uid \in domf g.(users)), user_can_advance_timer increment g.(users).[h]) 453 | (tick_ok_users increment g). 454 | Proof. 455 | move => increment g. 456 | exact: allfP. 457 | Qed. 458 | 459 | (** Domain of users unchanged after tick. *) 460 | Lemma tick_users_domf : forall increment pre, 461 | domf pre.(users) = domf (tick_users increment pre). 462 | Proof. 463 | move => increment pre. 464 | by rewrite -updf_domf. 465 | Qed. 466 | 467 | (** [tick_users] at [uid] results in [user_advance_timer]. *) 468 | Lemma tick_users_upd : forall increment pre uid (h : uid \in domf pre.(users)), 469 | (tick_users increment pre).[? uid] = Some (user_advance_timer increment pre.(users).[h]). 470 | Proof. 471 | move => increment pre uid h. 472 | by rewrite updf_update. 473 | Qed. 474 | 475 | (** [tick_users] results in [None] if the user not in the domain of the pre-state. *) 476 | Lemma tick_users_notin : forall increment pre uid (h : uid \notin domf pre.(users)), 477 | (tick_users increment pre).[? uid] = None. 478 | Proof. 479 | move => increment pre uid h. 480 | apply not_fnd. 481 | change (uid \notin domf (tick_users increment pre)); by rewrite -updf_domf. 482 | Qed. 483 | 484 | (** ** Lemmas about [merge_msgs_deadline] and [send_broadcasts] *) 485 | 486 | (** A message in [merge_msgs_deadline] is either already in the mailbox or 487 | it is a member of the messages being merged. *) 488 | Lemma in_merge_msgs : forall d (msg:Msg) now msgs mailbox, 489 | (d,msg) \in merge_msgs_deadline now msgs mailbox -> 490 | msg \in msgs \/ (d,msg) \in mailbox. 491 | Proof. 492 | move=> d msg now msgs mb. 493 | move=> /msetDP [|];[|right;done]. 494 | by rewrite (perm_mem (perm_eq_seq_mset _)) => /mapP [x H_x [_ ->]];left. 495 | Qed. 496 | 497 | (** [send_broadcasts] definition. *) 498 | Lemma send_broadcastsE now targets prev_msgs msgs: 499 | send_broadcasts now targets prev_msgs msgs = updf prev_msgs targets (fun _ => merge_msgs_deadline now msgs). 500 | Proof. 501 | by rewrite unlock. 502 | Qed. 503 | 504 | (** [send_broadcasts] at [uid] results in [merge_msgs_deadline]. *) 505 | Lemma send_broadcasts_in : forall (msgpool : MsgPool) now uid msgs targets 506 | (h : uid \in msgpool) (h' : uid \in targets), 507 | (send_broadcasts now targets msgpool msgs).[? uid] = Some (merge_msgs_deadline now msgs msgpool.[h]). 508 | Proof. 509 | by move => *;rewrite send_broadcastsE updf_update. 510 | Qed. 511 | 512 | (** [send_brodcasts] results in [None] if [uid] is not in the domain of [msgpool]. *) 513 | Lemma send_broadcast_notin : 514 | forall (msgpool : MsgPool) now uid msgs targets 515 | (h : uid \notin domf msgpool), 516 | (send_broadcasts now targets msgpool msgs).[? uid] = None. 517 | Proof. 518 | move => *;apply not_fnd. 519 | change (?k \notin ?f) with (k \notin domf f). 520 | by rewrite send_broadcastsE -updf_domf. 521 | Qed. 522 | 523 | (** [send_brodcasts] at [uid] results in [msgpool] at [uid] if [uid] is in [msgpool], 524 | but uid is not in targets of [send_broadcasts] function. *) 525 | Lemma send_broadcast_notin_targets : forall (msgpool : MsgPool) now uid msgs targets 526 | (h : uid \in msgpool) (h' : uid \notin targets), 527 | (send_broadcasts now targets msgpool msgs).[? uid] = msgpool.[? uid]. 528 | Proof. 529 | move => msgpool now uid msg targets h h'. 530 | by rewrite send_broadcastsE updf_update' // in_fnd. 531 | Qed. 532 | 533 | (** [send_broadcast] contains [msg] but original mailbox does not, [msg] must be in [l]. *) 534 | Lemma broadcasts_prop 535 | uid (msg:Msg) (l:seq Msg) 536 | time (targets : {fset UserId}) (mailboxes' mailboxes : {fmap UserId -> {mset R * Msg}}): 537 | (odflt mset0 mailboxes'.[? uid] `<=` odflt mset0 mailboxes.[? uid])%mset -> 538 | match (send_broadcasts time targets mailboxes' l).[? uid] with 539 | | Some msg_mset => has (fun p : R * Msg => p.2 == msg) msg_mset 540 | | None => false 541 | end -> 542 | ~~ 543 | match mailboxes.[? uid] with 544 | | Some msg_mset => has (fun p : R * Msg => p.2 == msg) msg_mset 545 | | None => false 546 | end -> msg \in l. 547 | Proof. 548 | clear. 549 | move => H_sub H_pre H_post. 550 | have: ~~has (fun p: R * Msg => p.2 == msg) (odflt mset0 mailboxes.[?uid]) 551 | by case:fndP H_post;[|rewrite enum_mset0]. 552 | move {H_post} => H_post. 553 | 554 | rewrite send_broadcastsE in H_pre. 555 | case:mailboxes'.[?uid]/fndP => H_mb'; 556 | [|by move:H_pre;rewrite not_fnd //; 557 | congr (uid \notin _): H_mb';apply updf_domf]. 558 | 559 | have: ~~has (fun p: R * Msg => p.2 == msg) (mailboxes'.[H_mb']) 560 | by apply/contraNN:H_post => /hasP /= [x H_in H_x]; 561 | apply/hasP;exists x;[apply (msubset_subset H_sub);rewrite in_fnd|]. 562 | move {H_post} => H_post. 563 | 564 | move: {mailboxes H_sub}H_pre. 565 | 566 | case:(uid \in targets)/boolP=>H_tgt; 567 | [|by apply contraTT;rewrite updf_update']. 568 | 569 | rewrite updf_update {targets H_tgt}// => /hasP /=[[d msg'] H_in /eqP /=H_msg]. 570 | move:H_msg H_in=> {msg'}-> /in_merge_msgs [//|H_in]. 571 | 572 | move/negP in H_post;contradict H_post. 573 | by apply /hasP;exists (d,msg). 574 | Qed. 575 | 576 | (** ** Definition of [onth], lemmas about [onth] and [step] *) 577 | 578 | (** [onth]: option returning [n]th element of seq if [n] small enough. *) 579 | Definition onth {T : Type} (s : seq T) (n : nat) : option T := 580 | ohead (drop n s). 581 | 582 | (** [onth] results in [Some] if the index is small. *) 583 | Lemma onth_size : forall T (s:seq T) n x, onth s n = Some x -> n < size s. 584 | Proof. 585 | clear. 586 | move => T s n x H. 587 | rewrite ltnNge. 588 | apply/negP. 589 | contradict H. 590 | unfold onth. 591 | by rewrite drop_oversize. 592 | Qed. 593 | 594 | (** If [onth] of a prefix is not [None] then [onth] of the original sequence is the same. *) 595 | Lemma onth_from_prefix T (s:seq T) k n x: 596 | onth (take k s) n = Some x -> 597 | onth s n = Some x. 598 | Proof. 599 | move => H_prefix. 600 | have H_inbounds: n < size (take k s). 601 | rewrite ltnNge;apply/negP => H_oversize. 602 | by rewrite /onth drop_oversize in H_prefix. 603 | move: H_prefix. 604 | unfold onth, ohead. 605 | rewrite -{2}(cat_take_drop k s) drop_cat H_inbounds. 606 | by case: (drop n (take k s)). 607 | Qed. 608 | 609 | (** [onth] equal to [Some x] implies [n]th element is [x]. *) 610 | Lemma onth_nth T (s:seq T) ix x: 611 | onth s ix = Some x -> (forall x0, nth x0 s ix = x). 612 | Proof. 613 | unfold onth. 614 | unfold ohead. 615 | move => H_drop x0. 616 | rewrite -[ix]addn0 -nth_drop. 617 | destruct (drop ix s);simpl;congruence. 618 | Qed. 619 | 620 | (** [onth] equal to [Some x] means [x] is in the sequence. *) 621 | Lemma onth_in (T:eqType) (s:seq T) ix x: 622 | onth s ix = Some x -> x \in s. 623 | Proof. 624 | clear. 625 | intro H. 626 | rewrite -(onth_nth H x). 627 | exact (mem_nth _ (onth_size H)). 628 | Qed. 629 | 630 | (** [onth] equal to [Some x] means that the last element of the prefixed sequence is [x]. *) 631 | Lemma onth_take_last T (s:seq T) n x: 632 | onth s n = some x -> 633 | forall x0, last x0 (take n.+1 s) = x. 634 | Proof. 635 | clear. 636 | move => H_x x0. 637 | have H_size := onth_size H_x. 638 | rewrite -nth_last size_takel // nth_take //. 639 | by apply onth_nth. 640 | Qed. 641 | 642 | (** Predicates true for all elements of a sequence are true for elements returned by [onth]. *) 643 | Lemma all_onth T P s: @all T P s -> forall ix x, onth s ix = Some x -> P x. 644 | Proof. 645 | move/all_nthP => H ix x H_g. rewrite -(onth_nth H_g x). 646 | apply H, (onth_size H_g). 647 | Qed. 648 | 649 | (** [x] in [s] implies [onth] (the index of [x] in [s]) is [x]. *) 650 | Lemma onth_index (T : eqType) (x : T) (s : seq T): x \in s -> onth s (index x s) = Some x. 651 | Proof. 652 | move => H_in. 653 | by rewrite /onth /ohead (drop_nth x);[rewrite nth_index|rewrite index_mem]. 654 | Qed. 655 | 656 | (** [at_step] holds for [n]th element with [P] and [n]th element is [g], then [P g] holds. *) 657 | Lemma at_step_onth n (path : seq GState) (P : pred GState): 658 | at_step n path P -> 659 | forall g, onth path n = Some g -> 660 | P g. 661 | Proof. 662 | unfold at_step, onth. 663 | case Hdrop: (drop n path) => [|a l] //=. 664 | by move => HP g; case =><-. 665 | Qed. 666 | 667 | (** If [n]th element is [g] and [P g] holds, then [at_step] holds for [n] and [P]. *) 668 | Lemma onth_at_step n (path : seq GState) g: 669 | onth path n = Some g -> 670 | forall (P : pred GState), P g -> at_step n path P. 671 | Proof. 672 | unfold at_step, onth. 673 | case Hdrop: (drop n path) => [|a l] //=. 674 | by case =><-. 675 | Qed. 676 | 677 | (** [onth] is true at [ix] implies [onth] is true at truncated trace for size of new trace minus one. *) 678 | Lemma onth_take_some : forall (trace: seq GState) ix g, 679 | onth trace ix = Some g -> 680 | onth (take ix.+1 trace) (size (take ix.+1 trace)).-1 = Some g. 681 | Proof. 682 | move => trace ix g H_onth. 683 | clear -H_onth. 684 | unfold onth. 685 | erewrite drop_nth with (x0:=g). simpl. 686 | rewrite nth_last. erewrite onth_take_last with (x:=g); try assumption. 687 | trivial. 688 | destruct trace. inversion H_onth. intuition. 689 | Qed. 690 | 691 | (** ** Lemmas about [step_in_path_at] *) 692 | 693 | (** [step_in_path_at] implies a global transition. *) 694 | Lemma transition_from_path 695 | g0 states ix (H_path: is_trace g0 states) 696 | g1 g2 697 | (H_step : step_in_path_at g1 g2 ix states): 698 | g1 ~~> g2. 699 | Proof. 700 | unfold step_in_path_at in H_step. 701 | destruct states. inversion H_path. 702 | destruct H_path as [H_g0 H_path]; subst. 703 | have {H_path} := path_drop' H_path ix. 704 | destruct (drop ix (g :: states));[done|]. 705 | destruct l;[done|]. 706 | destruct H_step as [-> ->]. 707 | simpl. 708 | by move/andP => [] /asboolP. 709 | Qed. 710 | 711 | (** [step_in_path_at] with same index must be with same states. *) 712 | Lemma step_ix_same trace ix g1 g2: 713 | step_in_path_at g1 g2 ix trace -> 714 | forall g3 g4, 715 | step_in_path_at g3 g4 ix trace -> 716 | g3 = g1 /\ g4 = g2. 717 | Proof. 718 | clear. 719 | unfold step_in_path_at. 720 | destruct (drop ix trace) as [|? [|]];(tauto || intuition congruence). 721 | Qed. 722 | 723 | (** A step in path at [n] from [g1] to [g2] means [g1] is at index [n]. *) 724 | Lemma step_in_path_onth_pre {g1 g2 n path} (H_step : step_in_path_at g1 g2 n path) 725 | : onth path n = Some g1. 726 | Proof. 727 | unfold step_in_path_at in H_step. 728 | unfold onth. destruct (drop n path) as [|? []];destruct H_step. 729 | rewrite H;reflexivity. 730 | Qed. 731 | 732 | (** [step_in_path_at] from [g1] to [g2] with [n] means [g2] is at index [n+1]. *) 733 | Lemma step_in_path_onth_post {g1 g2 n path} (H_step : step_in_path_at g1 g2 n path) 734 | : onth path n.+1 = Some g2. 735 | Proof. 736 | unfold step_in_path_at in H_step. 737 | unfold onth. rewrite -add1n -drop_drop. 738 | destruct (drop n path) as [|? []];destruct H_step. 739 | rewrite H0;reflexivity. 740 | Qed. 741 | 742 | (** [step_in_path_at] of truncated path implies [step_in_path_at] of original path. *) 743 | Lemma step_in_path_prefix (g1 g2 : GState) n k (path : seq GState) : 744 | step_in_path_at g1 g2 n (take k path) 745 | -> step_in_path_at g1 g2 n path. 746 | Proof. 747 | revert k path;induction n. 748 | intros k path; 749 | destruct path;[done|];destruct k;[done|]; 750 | destruct path;[done|];destruct k;done. 751 | intros k path. destruct k. 752 | clear;intro;exfalso;destruct path;assumption. 753 | unfold step_in_path_at. 754 | destruct path. done. 755 | simpl. apply IHn. 756 | Qed. 757 | 758 | (** [step_in_path_at] implies [step_in_path_at] of truncated path provided the truncation 759 | is sufficiently long. *) 760 | Lemma step_in_path_take (g1 g2 : GState) n (path : seq GState) : 761 | step_in_path_at g1 g2 n path 762 | -> step_in_path_at g1 g2 n (take n.+2 path). 763 | Proof. 764 | revert path; induction n. 765 | intro path. 766 | destruct path;[done|];destruct path;done. 767 | intros path. 768 | unfold step_in_path_at. 769 | destruct path. done. 770 | simpl. apply IHn. 771 | Qed. 772 | 773 | (** ** Lemmas on [reset_msg_delays] and [reset_user_msg_delays] *) 774 | 775 | (** Reset_deadline in [reset_user_msg_delays] if [m] is in [msgs]. *) 776 | Lemma reset_msg_delays_fwd : forall (msgs : {mset R * Msg}) (m : R * Msg), 777 | m \in msgs -> forall now, (reset_deadline now m \in reset_user_msg_delays msgs now). 778 | Proof. 779 | move => msgs m Hm now. 780 | rewrite -has_pred1 /= has_count. 781 | have Hcnt: (0 < count_mem m msgs) by rewrite -has_count has_pred1. 782 | eapply leq_trans;[eassumption|clear Hcnt]. 783 | rewrite (count_mem_mset (reset_deadline now m) (reset_user_msg_delays msgs now)). 784 | rewrite /reset_user_msg_delays -map_mset_count. 785 | apply sub_count. 786 | by move => H /= /eqP ->. 787 | Qed. 788 | 789 | (** If [m] was in [reset_user_msg_delays] then the deadline must have been reset. *) 790 | Lemma reset_user_msg_delays_rev (now : R) (msgs : {mset R * Msg}) (m: R*Msg): 791 | m \in reset_user_msg_delays msgs now -> 792 | exists d0, m = reset_deadline now (d0,m.2) /\ (d0,m.2) \in msgs. 793 | Proof. 794 | move => Hm. 795 | suff: (has (preim (reset_deadline now) (pred1 m)) msgs). 796 | move: m Hm => [d msg] Hm. 797 | move/hasP => [[d0 msg0] H_mem H_preim]. 798 | move: H_preim; rewrite /preim /pred1 /= /reset_deadline /=. 799 | case/eqP => Hn Hd; rewrite -Hd -Hn. 800 | by exists d0; split. 801 | by rewrite has_count map_mset_count -count_mem_mset -has_count has_pred1. 802 | Qed. 803 | 804 | (** The domain of [msgpool] is unchanged after [reset_msg_delays]. *) 805 | Lemma reset_msg_delays_domf : forall (msgpool : MsgPool) now, 806 | domf msgpool = domf (reset_msg_delays msgpool now). 807 | Proof. by move => msgpool pre; rewrite -updf_domf. Qed. 808 | 809 | (** [reset_msg_delays] at [uid] results in [reset_user_msg_delays]. *) 810 | Lemma reset_msg_delays_upd : forall (msgpool : MsgPool) now uid (h : uid \in domf msgpool), 811 | (reset_msg_delays msgpool now).[? uid] = Some (reset_user_msg_delays msgpool.[h] now). 812 | Proof. 813 | move => msgpool now uid h. 814 | have Hu := updf_update _ h. 815 | have Hu' := Hu (domf msgpool) _ h. 816 | by rewrite Hu'. 817 | Qed. 818 | 819 | (** [reset_msg_delays] results in [None] if the user is not in the domain of the message pool. *) 820 | Lemma reset_msg_delays_notin : forall (msgpool : MsgPool) now uid 821 | (h : uid \notin domf msgpool), 822 | (reset_msg_delays msgpool now).[? uid] = None. 823 | Proof. 824 | move => msgpool now uid h. 825 | apply not_fnd. 826 | change (uid \notin domf (reset_msg_delays msgpool now)). 827 | unfold reset_msg_delays. 828 | by rewrite -updf_domf. 829 | Qed. 830 | 831 | (** ** Definitions and lemmas for sent and forged messages *) 832 | 833 | Definition user_sent sender (m : Msg) (pre post : GState) : Prop := 834 | exists (ms : seq Msg), m \in ms 835 | /\ ((exists d incoming, related_by (lbl_deliver sender d incoming ms) pre post) 836 | \/ (related_by (lbl_step_internal sender ms) pre post)). 837 | 838 | Definition user_forged (msg:Msg) (g1 g2: GState) := 839 | related_by (lbl_forge_msg (msg_sender msg) (msg_round msg) (msg_period msg) (msg_type msg) (msg_ev msg)) g1 g2. 840 | 841 | Definition user_sent_at ix path uid msg := 842 | exists g1 g2, step_in_path_at g1 g2 ix path 843 | /\ user_sent uid msg g1 g2. 844 | 845 | (** A user who sends a message must be in both pre and post states. *) 846 | Lemma user_sent_in_pre {sender m pre post} (H : user_sent sender m pre post): 847 | sender \in pre.(users). 848 | Proof. 849 | by case: H => [msgs [H_mem [[d [recv H_step]] | H_step]]]; 850 | case: H_step => [key_ustate [ustate_post H_step]]. 851 | Qed. 852 | 853 | Lemma user_sent_in_post {sender m pre post} (H : user_sent sender m pre post): 854 | sender \in post.(users). 855 | Proof. 856 | destruct H as [msgs [H_mem [[d [recv H_step]] | H_step]]]; simpl in H_step. 857 | - by destruct H_step as [key_ustate [ustate_post [H_sender [H_corrupt H_step]]]]; 858 | destruct H_step as [key_mailbox [H_recv H_post]]; 859 | subst post; unfold delivery_result, step_result;destruct pre;simpl;clear; 860 | change (sender \in domf (users.[sender <- ustate_post])); 861 | rewrite dom_setf; apply fset1U1. 862 | - by destruct H_step as [key_ustate [ustate_post [H_corrupt [H_sender H_post]]]]; 863 | subst post; unfold delivery_result, step_result;destruct pre;simpl;clear; 864 | change (sender \in domf (users.[sender <- ustate_post])); 865 | rewrite dom_setf; apply fset1U1. 866 | Qed. 867 | 868 | (** The step of a user in the pre-state who sends message is same as [msg_step]. *) 869 | Lemma utransition_label_start uid msg g1 g2 : 870 | user_sent uid msg g1 g2 -> 871 | forall u, g1.(users).[? uid] = Some u -> 872 | (step_of_ustate u) = (msg_step msg). 873 | Proof. 874 | unfold user_sent. 875 | move => [sent [msg_in H_trans]] u H_u. 876 | case: msg msg_in => mtype v r p uid_m msg_in. 877 | case: H_trans => [[d [body H_recv]]|H_step]. 878 | * { (* message delivery cases *) 879 | destruct H_recv as (key_ustate & ustate_post & H_step & H_honest 880 | & key_mailbox & H_msg_in_mailbox & ->). 881 | destruct g1;simpl in * |- *. 882 | unfold step_of_ustate. 883 | rewrite in_fnd in H_u. injection H_u;clear H_u. intros <-. 884 | 885 | remember (ustate_post,sent) as ustep_out in H_step. 886 | destruct H_step;injection Hequstep_out;clear Hequstep_out;intros <- <-; 887 | try (exfalso;exact (notF msg_in)). 888 | 889 | (* Only one delivery transition actually sends a message *) 890 | move: msg_in; rewrite inE; case/eqP => [eq_type eq_ev eq_p eq_r eq_s]; subst. 891 | unfold certvote_ok in H;decompose record H;clear H. 892 | revert H0. 893 | clear;unfold pre',valid_rps;autounfold with utransition_unfold;simpl;clear. 894 | move => [-> [-> ->]];reflexivity. 895 | } 896 | * { (* internal transition cases *) 897 | destruct H_step as (key_user & ustate_post & H_honest & H_step & ->). 898 | destruct g1;simpl in * |- *. 899 | rewrite in_fnd in H_u;injection H_u;clear H_u. 900 | intro H. rewrite -> H in * |- *. clear key_user users H. 901 | move/in_memP: msg_in => msg_in. 902 | clear -msg_in H_step. 903 | 904 | unfold step_of_ustate. 905 | remember (ustate_post,sent) as ustep_out in H_step; 906 | destruct H_step; 907 | injection Hequstep_out;clear Hequstep_out;intros <- <-; 908 | let rec use_mem H := 909 | first [exfalso;exact H 910 | 911 | |destruct H as [H|H];[injection H as <- <- <- <- <-|use_mem H]] 912 | in use_mem msg_in; 913 | autounfold with utransition_unfold in H; 914 | decompose record H;clear H; 915 | match goal with 916 | | [H:valid_rps _ _ _ _ |- _] => unfold valid_rps in H;move: H 917 | | [H:advancing_rp _ _ _ |- _] => unfold advancing_rp in H;move :H 918 | end;clear;simpl;move=> [-> [-> ->]];reflexivity. 919 | } 920 | Qed. 921 | 922 | (** The step of a user in post-state who sends a message is greater than the message step. *) 923 | Lemma utransition_label_end : forall uid msg g1 g2, 924 | user_sent uid msg g1 g2 -> 925 | forall u, g2.(users).[? uid] = Some u -> 926 | step_lt (msg_step msg) (step_of_ustate u). 927 | Proof. 928 | move => uid msg g1 g2. 929 | unfold user_sent. 930 | move => [sent [msg_in H_trans]] u H_u. 931 | case: msg msg_in => mtype v r p uid_m /= msg_in. 932 | case: H_trans => [[d [body H_recv]]|H_step]. 933 | * { (* message delivery cases *) 934 | destruct H_recv as (key_ustate & ustate_post & H_step & H_honest 935 | & key_mailbox & H_msg_in_mailbox & ->). 936 | revert H_u. rewrite fnd_set eq_refl. case => {u}<-. 937 | 938 | destruct g1;cbn -[in_mem mem eq_op] in * |- *. 939 | remember (ustate_post,sent) as ustep_out in H_step. 940 | destruct H_step;injection Hequstep_out;clear Hequstep_out;intros <- <-; 941 | try (exfalso;exact (notF msg_in)); 942 | match type of msg_in with 943 | | is_true (_ \in [:: _]) => 944 | unfold in_mem in msg_in; simpl in msg_in; 945 | rewrite Bool.orb_false_r in msg_in; 946 | apply (elimT eqP) in msg_in; 947 | injection msg_in;clear msg_in; 948 | intros -> -> -> -> -> 949 | end. 950 | 951 | autounfold with utransition_unfold in H. decompose record H. 952 | revert H0;subst pre';clear;unfold valid_rps;destruct pre;simpl. 953 | by intuition. 954 | } 955 | * { (* internal transition cases *) 956 | destruct H_step as (key_user & ustate_post & H_honest & H_step & ->). 957 | revert H_u. rewrite fnd_set eq_refl. case => {u}<-. 958 | 959 | destruct g1;cbn -[in_mem mem eq_op] in * |- *. 960 | move/in_memP: msg_in => msg_in. 961 | 962 | clear -msg_in H_step. 963 | remember (ustate_post,sent) as ustep_out in H_step. 964 | destruct H_step; 965 | injection Hequstep_out;clear Hequstep_out;intros <- <-; 966 | let rec use_mem H := 967 | first [exfalso;exact H 968 | |destruct H as [H|H];[injection H as <- <- <- <- <-|use_mem H]] 969 | in use_mem msg_in; 970 | autounfold with utransition_unfold in H; 971 | decompose record H;clear H; 972 | match goal with 973 | | [H:valid_rps _ _ _ _ |- _] => move: H; unfold valid_rps 974 | | [H:advancing_rp _ _ _ |- _] => move: H; unfold advancing_rp 975 | end;clear;destruct pre;simpl;clear;move=> [-> [-> H_step_val]]; 976 | repeat (split || right); 977 | by rewrite addn1 ltnSn. 978 | } 979 | Qed. 980 | 981 | (** ** Definitions for receiving messages *) 982 | 983 | Definition step_at path ix lbl := 984 | exists g1 g2, step_in_path_at g1 g2 ix path /\ related_by lbl g1 g2. 985 | 986 | Definition msg_received uid msg_deadline msg path : Prop := 987 | exists n ms, step_at path n 988 | (lbl_deliver uid msg_deadline msg ms). 989 | 990 | Definition received_next_vote u voter round period step value path : Prop := 991 | exists d, msg_received u d (match value with 992 | | Some v => mkMsg Nextvote_Val (next_val v step) round period voter 993 | | None => mkMsg Nextvote_Open (step_val step) round period voter 994 | end) path. 995 | 996 | (** ** Labeling transitions *) 997 | 998 | (** All global transitions have some label. *) 999 | Lemma transitions_labeled: forall g1 g2, 1000 | g1 ~~> g2 <-> exists lbl, related_by lbl g1 g2. 1001 | Proof. 1002 | split. 1003 | + (* forward - find label for transition *) 1004 | destruct 1;simpl. 1005 | exists (lbl_tick increment);finish_case. 1006 | destruct pending as [deadline msg];exists (lbl_deliver uid deadline msg sent);finish_case. 1007 | exists (lbl_step_internal uid sent);finish_case. 1008 | exists (lbl_exit_partition);finish_case. 1009 | exists (lbl_enter_partition);finish_case. 1010 | exists (lbl_corrupt_user uid);finish_case. 1011 | exists (lbl_replay_msg uid);finish_case. 1012 | exists (lbl_forge_msg sender r p mtype mval);finish_case. 1013 | + (* reverse - find transition from label *) 1014 | destruct 1 as [[] Hrel];simpl in Hrel; case: Hrel. 1015 | * by move => Htick ->; eapply step_tick; eassumption. 1016 | * move => x [H_uid [ustate_post [H_ustep Hg2]]]. 1017 | move: Hg2 => [key_mailbox [Hg1 Hg2]]. 1018 | by subst g2; eapply step_deliver_msg; eassumption. 1019 | * move => x [H_uid [ustate_post [H_corrupt Hg2]]]. 1020 | by subst g2; eapply step_internal; eassumption. 1021 | * move => H_part H_g2. 1022 | by subst g2; eapply step_exit_partition; eassumption. 1023 | * move => H_part H_g2. 1024 | by subst g2; eapply step_enter_partition; eassumption. 1025 | * move => H_in [H_corrupt H_g2]. 1026 | by subst g2; eapply step_corrupt_user; eassumption. 1027 | * move => H_in [msg [H_corrupt [H_msg H_g2]]]. 1028 | by subst g2; eapply step_replay_msg; eassumption. 1029 | * move => H_in [s0 [H_keys [H_comm [H_match H_g2]]]]. 1030 | by subst g2; eapply step_forge_msg; eassumption. 1031 | Qed. 1032 | 1033 | (** Internal transitions change the state - used in [transition_label_unique]. *) 1034 | Lemma internal_not_noop : 1035 | forall s pre post l, s # pre ~> (post, l) -> pre <> post. 1036 | Proof. 1037 | move => s pre post l Hst;inversion Hst;subst. 1038 | all: try (autounfold with utransition_unfold in H2; decompose record H2; clear H2; 1039 | match goal with [H : valid_rps _ _ _ _ |- _] => 1040 | destruct H as [_ [_ H_s]];contradict H_s;rewrite H_s;simpl;clear 1041 | end;try discriminate; by rewrite addn1 => /esym /n_Sn). 1042 | autounfold with utransition_unfold in H3; decompose record H3; clear H3. 1043 | destruct H1 as [_ [_ H_s]];contradict H_s;rewrite H_s;simpl;clear. 1044 | by rewrite addn1 => /esym /n_Sn. 1045 | Qed. 1046 | 1047 | (** [delivery_result] decreases mailbox size - used in [transition_label_unique]. *) 1048 | Lemma deliver_analysis1: 1049 | forall g uid upost r m l 1050 | (key_mbox : uid \in g.(msg_in_transit)), 1051 | (r, m) \in g.(msg_in_transit).[key_mbox] -> 1052 | let g2 := delivery_result g uid key_mbox (r, m) upost l in 1053 | (forall uid2, 1054 | ( size (odflt mset0 (g2.(msg_in_transit).[?uid2])) 1055 | < size (odflt mset0 (g.(msg_in_transit).[?uid2]))) <-> 1056 | uid = uid2) 1057 | /\ [mset (r,m)] =( odflt mset0 (g.(msg_in_transit).[?uid]) 1058 | `\` odflt mset0 (g2.(msg_in_transit).[?uid]))%mset. 1059 | Proof. 1060 | clear. 1061 | move=> g uid upost r m l key_mbox H_pending g2. 1062 | 1063 | set mb1: {mset R*Msg} := odflt mset0 (g.(msg_in_transit).[?uid]). 1064 | set mb2: {mset R*Msg} := odflt mset0 (g2.(msg_in_transit).[?uid]). 1065 | assert (H_singleton: mb1 = (r,m) +` mb2). 1066 | { 1067 | subst mb1 mb2. 1068 | rewrite /g2 /delivery_result send_broadcastsE. 1069 | rewrite updf_update'. 1070 | simpl. by rewrite in_fset1U; apply/orP; left. 1071 | intro H_uid. 1072 | rewrite in_fnd. 1073 | repeat match goal with 1074 | [|- context C[odflt mset0 (Some ?x)]] => 1075 | assert (H :odflt mset0 (Some x) = x) by done; rewrite H; clear H 1076 | end. 1077 | rewrite setfNK; rewrite eq_refl. 1078 | by rewrite msetBDKC;[|rewrite msub1set]. 1079 | by rewrite fsetD11. 1080 | } 1081 | split;[|by move:H_singleton => /(f_equal (msetB^~mb2)) ->;rewrite msetDC msetDKB]. 1082 | 1083 | move => uid2. 1084 | split; last first. 1085 | intros <-. 1086 | fold mb1 mb2. 1087 | by rewrite H_singleton mset_add_size msetn_size leqnn. 1088 | 1089 | intro H_size. 1090 | case H_neq:(uid2 == uid);[by move/eqP: H_neq|exfalso]. 1091 | 1092 | subst g2. 1093 | unfold delivery_result in *. 1094 | simpl in *. 1095 | 1096 | clear mb1 mb2 H_singleton. 1097 | remember ((g.(msg_in_transit)).[uid <- ((g.(msg_in_transit)).[key_mbox] `\ (r, m))%mset]) as mailboxes'. 1098 | case:mailboxes'.[?uid2]/fndP => H_mb. 1099 | 2: { 1100 | assert (H_mb' := H_mb). 1101 | move/not_fnd in H_mb'. 1102 | subst mailboxes'. rewrite fnd_set in H_mb'. 1103 | rewrite H_neq in H_mb'. 1104 | rewrite H_mb' in H_size. 1105 | rewrite size_mset0 in H_size. 1106 | inversion H_size. 1107 | } 1108 | 1109 | assert (H_uid2 : uid2 \in domf g.(msg_in_transit)). 1110 | rewrite -fndSome. 1111 | assert (mailboxes'.[? uid2] = Some mailboxes'.[H_mb]). by rewrite in_fnd. 1112 | subst mailboxes'. 1113 | rewrite fnd_set in H. 1114 | rewrite H_neq in H. rewrite H. 1115 | done. 1116 | 1117 | rewrite send_broadcastsE in H_size. 1118 | destruct (uid2 \in domf (honest_users (g.(users)))) eqn:H_honest; last first. 1119 | { 1120 | rewrite updf_update' in H_size. 1121 | rewrite in_fnd in H_size. 1122 | simpl in H_size. 1123 | subst. 1124 | rewrite setfNK in H_size. 1125 | rewrite H_neq in H_size. 1126 | rewrite ltnn in H_size; discriminate. 1127 | 1128 | rewrite in_fsetD1. 1129 | apply/andP. move => [_ H_honest']. 1130 | by rewrite H_honest in H_honest'. 1131 | } 1132 | 1133 | { 1134 | rewrite updf_update in H_size. 1135 | rewrite in_fnd in H_size. 1136 | simpl in H_size. 1137 | subst. 1138 | rewrite setfNK in H_size. 1139 | rewrite H_neq in H_size. 1140 | simpl in H_size. 1141 | move: H_size. rewrite ltnNge. 1142 | apply/negP/negPn. 1143 | apply/msubset_size. 1144 | move: (g.(msg_in_transit)[`H_uid2]) => mb. 1145 | rewrite -{1}[mb]mset0D. 1146 | by apply msetSD, msub0set. 1147 | 1148 | rewrite in_fsetD1. 1149 | apply/andP. split. 1150 | by move/eqP in H_neq; move/eqP: H_neq. 1151 | by apply/negP; move/negP in H_honest. 1152 | } 1153 | Qed. 1154 | 1155 | (** Message transitions with same resulting state has the same output messages - 1156 | used in [transition_label_unique]. *) 1157 | Lemma utransition_msg_result_analysis uid upre m upost l l' 1158 | (H_step: uid # upre; m ~> (upost, l)) 1159 | (H_step': uid # upre; m ~> (upost, l')) : 1160 | l = l'. 1161 | Proof. 1162 | clear -H_step H_step'. 1163 | remember (upost,l) as ustate_out. 1164 | destruct H_step eqn:H_trans; case: Hequstate_out; 1165 | intros <- <-; inversion H_step'; subst; try (by []); exfalso. 1166 | subst pre'; subst pre'0; clear -H2 H6. 1167 | unfold set_softvotes, certvote_ok, valid_rps in H2; simpl in H2. 1168 | by rewrite <- H6 in H2; intuition auto. 1169 | subst pre'; subst pre'0; clear -c H6. 1170 | unfold set_softvotes, certvote_ok, valid_rps in c; simpl in c. 1171 | by rewrite H6 in c; intuition auto. 1172 | unfold vote_msg in H3; simpl in H3. 1173 | by intuition auto. 1174 | subst pre'; subst pre'0. 1175 | unfold deliver_nonvote_msg_result, certvote_result in H. 1176 | destruct pre; simpl in *. 1177 | case: H; intros <-; intro; clear -H3. 1178 | unfold certvote_ok, set_softvotes, valid_rps in H3; simpl in H3. 1179 | by intuition auto. 1180 | Qed. 1181 | 1182 | (** [delivery_result] on a global state is the same means the message delivery 1183 | transitions are equal - used in [transition_label_unique]. *) 1184 | Lemma deliver_deliver_lbl_unique : 1185 | forall g uid uid' upost upost' r r' m m' l l' 1186 | (key_state : uid \in g.(users)) (key_mbox : uid \in g.(msg_in_transit)) 1187 | (key_state' : uid' \in g.(users)) (key_mbox' : uid' \in g.(msg_in_transit)), 1188 | ~ g.(users).[key_state].(corrupt) -> 1189 | (r, m) \in g.(msg_in_transit).[key_mbox] -> 1190 | uid # g.(users).[key_state] ; m ~> (upost, l) -> 1191 | ~ g.(users).[key_state'].(corrupt) -> 1192 | (r', m') \in g.(msg_in_transit).[key_mbox'] -> 1193 | uid' # g.(users).[key_state'] ; m' ~> (upost', l') -> 1194 | delivery_result g uid key_mbox (r, m) upost l = delivery_result g uid' key_mbox' (r', m') upost' l' -> 1195 | uid = uid' /\ r = r' /\ m = m' /\ l = l'. 1196 | Proof. 1197 | clear. 1198 | move => g uid uid' upost upost' r r' m m' l l' key_state key_mbox key_state' key_mbox' 1199 | H_honest H_pending H_step H_honest' H_pending' H_step' H_results. 1200 | have Fact1 := 1201 | deliver_analysis1 upost l H_pending. 1202 | have Fact1' := 1203 | deliver_analysis1 upost' l' H_pending'. 1204 | have {Fact1 Fact1'}[H_uids H_pendings] : uid = uid' /\ [mset (r,m)] = [mset (r',m')]. 1205 | { 1206 | move: H_results Fact1 Fact1' => <-. 1207 | set g2 := delivery_result g uid key_mbox (r, m) upost l. 1208 | cbv zeta. clearbody g2. clear. 1209 | move => [H_uid H_pending] [H_uid' H_pending']. 1210 | have H: uid = uid by reflexivity. 1211 | rewrite <-H_uid, H_uid' in H;subst uid'. 1212 | by split;[|rewrite H_pending -H_pending']. 1213 | } 1214 | subst uid'. 1215 | have {H_pendings}[H_r H_m]: (r,m) = (r',m') by apply/mset1P;rewrite -H_pendings mset11. 1216 | subst r' m'. 1217 | repeat (split;[reflexivity|]). 1218 | 1219 | have H: upost = upost' 1220 | by move: (f_equal (fun g => g.(users).[?uid]) H_results); 1221 | rewrite !fnd_set eq_refl;clear;congruence. 1222 | subst upost'. 1223 | 1224 | rewrite (bool_irrelevance key_state' key_state) in H_step'. 1225 | move: (g.(users)[`key_state]) H_step H_step' => upre. 1226 | clear. 1227 | 1228 | apply utransition_msg_result_analysis. 1229 | Qed. 1230 | 1231 | (** Message delivery transitions cannot be the same as internal transitions - 1232 | used in [transition_label_unique]. *) 1233 | Lemma deliver_internal_False : 1234 | forall g uid uid' upost upost' r m l l' 1235 | (key_state : uid \in g.(users)) (key_mbox : uid \in g.(msg_in_transit)) 1236 | (key_state' : uid' \in g.(users)), 1237 | ~ g.(users).[key_state].(corrupt) -> 1238 | (r, m) \in g.(msg_in_transit).[key_mbox] -> 1239 | uid # g.(users).[key_state] ; m ~> (upost, l) -> 1240 | ~ g.(users).[key_state'].(corrupt) -> 1241 | uid' # g.(users).[key_state'] ~> (upost', l') -> 1242 | delivery_result g uid key_mbox (r, m) upost l = step_result g uid' upost' l' -> 1243 | False. 1244 | Proof. 1245 | clear. 1246 | move => g uid uid' upost upost' r m l l' key_state key_mbox key_state'. 1247 | move => H_honest H_msg H_step H_honest' H_step'. 1248 | rewrite/delivery_result /= /step_result /= /RecordSet.set /=. 1249 | set us1 := _.[uid <- _]. 1250 | set us2 := _.[uid' <- _]. 1251 | set sb1 := send_broadcasts _ _ _ _. 1252 | set sb2 := send_broadcasts _ _ _ _. 1253 | move => Heq. 1254 | have Hus: us2 = us1 by move: Heq; move: (us1) (us2) => us3 us4; case. 1255 | have Hsb: sb1 = sb2 by case: Heq. 1256 | clear Heq. 1257 | case Hueq: (uid' == uid); last first. 1258 | move/eqP: Hueq => Hueq. 1259 | have Hus1c: us2.[? uid'] = us1.[? uid'] by rewrite Hus. 1260 | move: Hus1c. 1261 | rewrite 2!fnd_set. 1262 | case: ifP; case: ifP. 1263 | - by move/eqP. 1264 | - move => _ _ Hpost. 1265 | suff Hsuff: (users g) [` key_state'] = upost'. 1266 | move: H_step'. 1267 | by move/internal_not_noop. 1268 | apply sym_eq in Hpost. 1269 | move: Hpost. 1270 | rewrite in_fnd. 1271 | by case. 1272 | - by move /eqP. 1273 | - by move => _ /eqP. 1274 | move/eqP: Hueq => Hueq. 1275 | move: Hsb. 1276 | rewrite /sb1 /sb2 Hueq. 1277 | move: H_msg. 1278 | clear. 1279 | set fs := [fset _ | _ in _]. 1280 | set sb1 := send_broadcasts _ _ _ _. 1281 | set sb2 := send_broadcasts _ _ _ _. 1282 | move => H_msg Hsb. 1283 | have Hsb12: sb1.[? uid] = sb2.[? uid] by rewrite Hsb. 1284 | move: Hsb12. 1285 | rewrite send_broadcast_notin_targets; first rewrite send_broadcast_notin_targets //. 1286 | - rewrite fnd_set. 1287 | case: ifP; last by move/eqP. 1288 | move => _. 1289 | rewrite in_fnd; case. 1290 | move: H_msg. 1291 | set ms := (msg_in_transit _ _). 1292 | move => H_msg. 1293 | move/msetP => Hms. 1294 | move: (Hms (r, m)). 1295 | rewrite msetB1E. 1296 | case Hrm: ((r, m) == (r, m)); last by move/eqP: Hrm. 1297 | rewrite /=. 1298 | move: H_msg. 1299 | rewrite -mset_neq0. 1300 | move/eqP. 1301 | case: (ms (r, m)) => //. 1302 | move => n _. 1303 | by lia. 1304 | - rewrite in_fsetE /=. 1305 | apply/negP. 1306 | case/andP => Hf. 1307 | case/negP: Hf. 1308 | by rewrite in_fsetE. 1309 | - rewrite 2!in_fsetE. 1310 | by apply/orP; left. 1311 | - rewrite in_fsetE /= in_fsetE. 1312 | apply/negP. 1313 | case/andP => Hf. 1314 | by case/negP: Hf. 1315 | Qed. 1316 | 1317 | (** Internal transitions with equal post-states with the same messages sent must 1318 | have sent the messages in the same order - used in [transition_label_unique]. *) 1319 | Lemma utransition_result_perm_eq uid upre upost l l' : 1320 | uid # upre ~> (upost, l) -> 1321 | uid # upre ~> (upost, l') -> 1322 | perm_eq l l' -> 1323 | l = l'. 1324 | Proof. 1325 | move => Htr Htr' Hpq. 1326 | case Hs: (size l') => [|n]. 1327 | move: Hs Hpq. 1328 | move/size0nil =>->. 1329 | by move/perm_nilP. 1330 | case Hn: n => [|n']. 1331 | move: Hs. 1332 | rewrite Hn. 1333 | destruct l' => //=. 1334 | case Hl': (size l') => //. 1335 | move: Hpq. 1336 | move/size0nil: Hl' =>->. 1337 | by move/perm_eq_cons1P. 1338 | move: Hs. 1339 | rewrite Hn => Hl'. 1340 | have Heq: size l = size l' by apply perm_size. 1341 | move: Heq. 1342 | rewrite Hl' => Hl. 1343 | have Hll': size l' >= 2 by rewrite Hl'. 1344 | have Hll: size l >= 2 by rewrite Hl. 1345 | clear n n' Hn Hl' Hl. 1346 | inversion Htr; inversion Htr'; subst; simpl in *; try by []. 1347 | move: Hpq. 1348 | set m1 := mkMsg Proposal _ _ _ _. 1349 | set m2 := mkMsg Block _ _ _ _. 1350 | set s1 := [:: _; _]. 1351 | set s2 := [:: _; _]. 1352 | move => Hpm. 1353 | have Hm1: m1 \in s2. 1354 | rewrite -(perm_mem Hpm) /= inE. 1355 | by apply/orP; left. 1356 | have Hm2: m2 \in s2. 1357 | rewrite -(perm_mem Hpm) /= inE. 1358 | apply/orP; right. 1359 | by rewrite inE. 1360 | move: Hm1 Hm2. 1361 | rewrite inE. 1362 | move/orP; case; last by rewrite inE. 1363 | rewrite /s2. 1364 | move/eqP =><-. 1365 | rewrite inE. 1366 | move/orP; case; first by move/eqP. 1367 | rewrite inE. 1368 | by move/eqP =><-. 1369 | Qed. 1370 | 1371 | (** Rule out the possibility that a step that counts as one user sending a 1372 | message cannot also count as a send from a different user or different message. *) 1373 | Lemma transition_label_unique : forall lbl lbl2 g1 g2, 1374 | related_by lbl g1 g2 -> 1375 | related_by lbl2 g1 g2 -> 1376 | match lbl with 1377 | | lbl_deliver _ _ _ _ => 1378 | match lbl2 with 1379 | | lbl_deliver _ _ _ _ => lbl2 = lbl 1380 | | lbl_step_internal _ _=> lbl2 = lbl 1381 | | _ => True 1382 | end 1383 | | lbl_step_internal _ _=> 1384 | match lbl2 with 1385 | | lbl_deliver _ _ _ _ => lbl2 = lbl 1386 | | lbl_step_internal _ _=> lbl2 = lbl 1387 | | _ => True 1388 | end 1389 | | _ => True 1390 | end. 1391 | Proof. 1392 | move => lbl lbl2 g1 g2. 1393 | destruct lbl eqn:H_lbl;try done. 1394 | + (* deliver *) 1395 | (* one user changed, with a message removed from their mailbox *) 1396 | rewrite /=. 1397 | move => [key_ustate [ustate_post [H_step H]]]. 1398 | move: H => [Hcorrupt [key_mailbox [Hmsg Hg2]]]. 1399 | rewrite Hg2 {Hg2} /related_by. 1400 | destruct lbl2;try done. 1401 | * (* deliver/deliver *) 1402 | move => [key_ustate' [ustate_post' [H_step' [Hcorrupt' [key_mailbox' [Hmsg' Heq]]]]]]. 1403 | eapply deliver_deliver_lbl_unique in Heq; eauto. 1404 | move: Heq => [Hs [Hr [Hm Hl]]]. 1405 | by rewrite Hs Hr Hm Hl. 1406 | * (* deliver/internal *) 1407 | move => [key_user [ustate_post' [Hcorrupt' [H_step' Heq]]]]. 1408 | by eapply deliver_internal_False in Heq; eauto. 1409 | + (* step internal *) 1410 | rewrite /=. (* one user changed, no message removed *) 1411 | move => [key_ustate [ustate_post [H_corrupt [Hstep Hres]]]]. 1412 | rewrite Hres {Hres} /related_by. 1413 | destruct lbl2;try done. 1414 | * (* internal/deliver *) 1415 | move => [key_ustate' [upost' [H_step' [H_corrupt' [key_mbox [Hmsg Heq]]]]]]. 1416 | apply sym_eq in Heq. 1417 | by eapply deliver_internal_False in Heq; eauto. 1418 | * (* internal/internal *) 1419 | move => [key_user [ustate_post0 [Hcorrupt0 [Htr0 Heq]]]]. 1420 | case Hs: (s == s0); last first. 1421 | move/eqP: Hs => Hs. 1422 | move: Heq. 1423 | rewrite /step_result /= /step_result /=. 1424 | set us1 := _.[_ <- _]. 1425 | set us2 := _.[_ <- _]. 1426 | move => Heq. 1427 | have Hus: us1 = us2 by move: Heq; move: (us1) (us2) => us3 us4; case. 1428 | clear Heq. 1429 | have Hus1c: us1.[? s0] = us2.[? s0] by rewrite Hus. 1430 | move: Hus1c. 1431 | rewrite 2!fnd_set. 1432 | case: ifP => [|_]; first by move/eqP => Hs'; case: Hs. 1433 | case: ifP => [_|]; last by move/eqP. 1434 | rewrite in_fnd; case => Hg. 1435 | by apply internal_not_noop in Htr0. 1436 | move/eqP: Hs => Hs. 1437 | move: Heq. 1438 | rewrite -Hs. 1439 | rewrite /step_result /= /step_result /=. 1440 | set us1 := _.[_ <- _]. 1441 | set us2 := _.[_ <- _]. 1442 | set mh1 := (_ `+` seq_mset _)%mset. 1443 | set mh2 := (_ `+` seq_mset _)%mset. 1444 | move => Heq. 1445 | have Hus: us1 = us2 by move: Heq; move: (us1) (us2) => us3 us4; case. 1446 | have Hus1c: us1.[? s0] = us2.[? s0] by rewrite Hus. 1447 | move: Hus1c. 1448 | rewrite 2!fnd_set -Hs. 1449 | case: ifP; last by move/eqP. 1450 | move => _; case => Hustate. 1451 | have Hmh: mh1 = mh2 by case: Heq. 1452 | clear Heq Hcorrupt0. 1453 | move: key_user Htr0. 1454 | rewrite -Hs -Hustate => key_user. 1455 | rewrite -(eq_getf key_ustate) => Hstep'. 1456 | move: Hmh. 1457 | rewrite /mh1 /mh2. 1458 | move/msetD_seq_mset_perm_eq => Hprm. 1459 | suff Hsuff: l = l0 by rewrite Hsuff. 1460 | move: Hstep Hstep' Hprm. 1461 | exact: utransition_result_perm_eq. 1462 | Qed. 1463 | 1464 | (** ** User transition lemmas, destructing post state *) 1465 | 1466 | (** Message transition on [uid] results in message sent by [uid]. *) 1467 | Lemma utransition_msg_sender_good uid u msg result: 1468 | uid # u ; msg ~> result -> 1469 | forall m, m \in result.2 -> uid = msg_sender m. 1470 | Proof. 1471 | clear. 1472 | by destruct 1 => /= m /in_memP /=;intuition;subst m. 1473 | Qed. 1474 | 1475 | (** Internal transition on [uid] results in message sent by [uid]. *) 1476 | Lemma utransition_internal_sender_good uid u result: 1477 | uid # u ~> result -> 1478 | forall m, m \in result.2 -> uid = msg_sender m. 1479 | Proof. 1480 | clear. 1481 | by destruct 1 => /= m /in_memP /=;intuition;subst m. 1482 | Qed. 1483 | 1484 | (** ** Definitions of user honesty *) 1485 | 1486 | (** User is honest at step [(r,p,s)]. *) 1487 | Definition honest_at_step (r p s:nat) uid (path : seq GState) := 1488 | exists n, 1489 | match onth path n with 1490 | | None => False 1491 | | Some gstate => 1492 | match gstate.(users).[? uid] with 1493 | | None => False 1494 | | Some ustate => ~ustate.(corrupt) 1495 | /\ (r,p,s) = (step_of_ustate ustate) 1496 | end 1497 | end. 1498 | 1499 | (** User is honest in round [r] and period [p]. *) 1500 | Definition honest_in_period (r p:nat) uid path := 1501 | exists n, 1502 | match @onth GState path n with 1503 | | None => False 1504 | | Some gstate => 1505 | match gstate.(users).[? uid] with 1506 | | None => False 1507 | | Some ustate => 1508 | ~ustate.(corrupt) /\ ustate.(round) = r /\ ustate.(period) = p 1509 | end 1510 | end. 1511 | 1512 | (** User is honest at all points [<= step] in the path. *) 1513 | Definition honest_during_step (step:nat * nat * nat) uid (path : seq GState) := 1514 | all (upred' uid (fun u => step_leb (step_of_ustate u) step ==> ~~u.(corrupt))) path. 1515 | 1516 | (** ** Preserving honesty through transitions *) 1517 | 1518 | (** Internal user transitions preserves [corrupt] flag. *) 1519 | Lemma utransition_internal_preserves_corrupt uid pre post sent: 1520 | uid # pre ~> (post,sent) -> pre.(corrupt) = post.(corrupt). 1521 | Proof. 1522 | set result:=(post,sent). change post with (result.1). clearbody result. 1523 | destruct 1;reflexivity. 1524 | Qed. 1525 | 1526 | (** Message transitions preserve [corrupt] flag. *) 1527 | Lemma utransition_msg_preserves_corrupt uid msg pre post sent: 1528 | uid # pre ; msg ~> (post,sent) -> pre.(corrupt) = post.(corrupt). 1529 | Proof. 1530 | set result:=(post,sent). change post with (result.1). clearbody result. 1531 | destruct 1;try reflexivity. 1532 | + unfold deliver_nonvote_msg_result;simpl. 1533 | by destruct msg, msg_ev, msg_type. 1534 | Qed. 1535 | 1536 | (** The sender of a message is honest in the pre-state. *) 1537 | Lemma user_sent_honest_pre uid msg g1 g2 1538 | (H_send: user_sent uid msg g1 g2): 1539 | (g1.(users)[` user_sent_in_pre H_send]).(corrupt) = false. 1540 | Proof. 1541 | move: (user_sent_in_pre H_send) => H_in. 1542 | case:H_send => [ms [H_in_ms [[d [inc H_ustep]]|H_ustep]]]. 1543 | - case: H_ustep => [H_uid [ustate_post [H_ustep [H_corrupt [key_mailbox [H_mail H_g2]]]]]]. 1544 | apply/negP. contradict H_corrupt; move: H_corrupt. 1545 | by rewrite (bool_irrelevance H_in H_uid). 1546 | - case: H_ustep => [H_uid [ustate_post [H_corrupt [H_ustep H_g2]]]]. 1547 | apply/negP;contradict H_corrupt;move: H_corrupt. 1548 | by rewrite (bool_irrelevance H_in H_uid). 1549 | Qed. 1550 | 1551 | (** The sender of message is honest in the post-state. *) 1552 | Lemma user_sent_honest_post uid msg g1 g2 1553 | (H_send: user_sent uid msg g1 g2): 1554 | (g2.(users)[` user_sent_in_post H_send]).(corrupt) = false. 1555 | Proof. 1556 | set H_in := user_sent_in_post H_send. 1557 | clearbody H_in. 1558 | suff: user_honest uid g2 by rewrite /user_honest in_fnd => /negbTE. 1559 | move:H_send => [ms [H_in_ms [[d [inc H_ustep]]|H_ustep]]]; simpl in H_ustep. 1560 | - case: H_ustep => [H_uid [ustate_post [H_ustep [H_corrupt [key_mailbox [H_mail H_g2]]]]]]. 1561 | subst g2; unfold user_honest, delivery_result;simpl. 1562 | rewrite fnd_set eq_refl. 1563 | move: H_ustep H_corrupt. clear. 1564 | move/utransition_msg_preserves_corrupt =>->. 1565 | move => Hcorrupt. 1566 | by apply/negP. 1567 | - case: H_ustep => [H_uid [ustate_post [H_corrupt [H_ustep H_g2]]]]. 1568 | subst g2; unfold user_honest, step_result;simpl. 1569 | rewrite fnd_set eq_refl. 1570 | move: H_ustep H_corrupt. clear. 1571 | move/utransition_internal_preserves_corrupt =>->. 1572 | move => Hcorrupt. 1573 | by apply/negP. 1574 | Qed. 1575 | 1576 | (** The sender of a message is honest in the period of the message. *) 1577 | Lemma user_honest_in_from_send ix trace uid msg 1578 | (H_vote: user_sent_at ix trace uid msg): 1579 | let: (r,p,_) := msg_step msg in 1580 | honest_in_period r p uid trace. 1581 | Proof. 1582 | destruct H_vote as (g1_v & g2_v & H_vote_step & H_vote_send). 1583 | 1584 | set H_in: uid \in g1_v.(users) := user_sent_in_pre H_vote_send. 1585 | have H_u := in_fnd H_in. 1586 | set u: UState := (g1_v.(users)[` H_in]) in H_u. 1587 | 1588 | have:= utransition_label_start H_vote_send H_u. 1589 | move: (msg_step msg) => [[r p] s] [H_r H_p _]. 1590 | 1591 | by exists ix;rewrite (step_in_path_onth_pre H_vote_step) H_u (user_sent_honest_pre H_vote_send). 1592 | Qed. 1593 | 1594 | (** ** Propagating honesty *) 1595 | 1596 | (** Propagate [honest_during_step] backwards. *) 1597 | Lemma honest_during_le s1 s2 uid trace: 1598 | step_le s1 s2 -> 1599 | honest_during_step s2 uid trace -> 1600 | honest_during_step s1 uid trace. 1601 | Proof. 1602 | clear. 1603 | move => H_le. 1604 | unfold honest_during_step. 1605 | apply sub_all => g. 1606 | unfold upred'. case: (g.(users).[?uid]) => [u|];[|done]. 1607 | move => /implyP H. 1608 | apply /implyP => /step_leP H1. 1609 | apply /H /step_leP /(step_le_trans H1 H_le). 1610 | Qed. 1611 | 1612 | (** Propagate [user_honest] backwards through transitions. *) 1613 | Lemma honest_backwards_gstep : forall (g1 g2 : GState), 1614 | GTransition g1 g2 -> 1615 | forall uid, user_honest uid g2 -> user_honest uid g1. 1616 | Proof. 1617 | move => g1 g2 Hstep uid. 1618 | destruct Hstep;unfold user_honest;destruct pre; 1619 | unfold tick_update,tick_users; simpl algorand_model.users in * |- *; try done. 1620 | + (* step_tick *) 1621 | destruct (fndP users uid). 1622 | by rewrite updf_update //;destruct (users.[kf]), corrupt. 1623 | by rewrite not_fnd // -[uid \in _]/(uid \in domf _) -updf_domf. 1624 | + (* step_deliver_msg UTransitionMsg *) 1625 | rewrite fnd_set. 1626 | destruct (@eqP (Finite.choiceType UserId) uid uid0);[|done]. 1627 | subst uid0;rewrite (in_fnd key_ustate). 1628 | by move/negP: H0. 1629 | + (* step_internal UTransitionInternal *) 1630 | rewrite fnd_set. 1631 | destruct (@eqP (Finite.choiceType UserId) uid uid0);[|done]. 1632 | subst uid0;rewrite (in_fnd ustate_key). 1633 | apply/contraNN => H1. by apply utransition_internal_preserves_corrupt in H0. 1634 | + (* step_corrupt_user *) 1635 | rewrite fnd_set. 1636 | by destruct (@eqP (Finite.choiceType UserId) uid uid0). 1637 | Qed. 1638 | 1639 | (** [user_honest] at the last state implies [user_honest] in all states in the path. *) 1640 | Lemma honest_last_all uid g0 p (H_path : is_trace g0 p): 1641 | user_honest uid (last g0 p) -> 1642 | all (user_honest uid) (g0 :: p). 1643 | Proof. 1644 | move => H_honest. 1645 | destruct p. inversion H_path. 1646 | destruct H_path as [H_g0 H_path]; subst. 1647 | revert H_honest. 1648 | elim/last_ind: p H_path => [|s x IH] /=; first by move=> _ ->. 1649 | rewrite rcons_path last_rcons all_rcons. 1650 | move/andP => [Hpath Hstep] Hx. 1651 | specialize (IH Hpath). 1652 | rewrite Hx. 1653 | apply IH. by apply/honest_backwards_gstep /asboolP: Hx. 1654 | Qed. 1655 | Arguments honest_last_all uid [g0] [p]. 1656 | 1657 | (** Honesty is monotone. *) 1658 | Lemma honest_monotone uid g1 g2: 1659 | greachable g1 g2 -> 1660 | user_honest uid g2 -> 1661 | user_honest uid g1. 1662 | Proof. 1663 | move => [p H_path H_last] H_honest2. 1664 | subst g2. 1665 | pose proof (honest_last_all uid H_path H_honest2). 1666 | by move: H => /andP []. 1667 | Qed. 1668 | 1669 | (** ** Lemmas on manipulation of traces *) 1670 | 1671 | (** A non-empty prefix of a trace is a trace. *) 1672 | Lemma is_trace_prefix : forall trace g0 n, 1673 | is_trace g0 trace -> n > 0 -> is_trace g0 (take n trace). 1674 | Proof. 1675 | clear. 1676 | induction trace;[done|]. 1677 | destruct n. done. 1678 | simpl. 1679 | unfold is_trace. 1680 | move => [H_g0 H_path] _. 1681 | split;[done|by apply path_prefix]. 1682 | Qed. 1683 | 1684 | (** Dropping elements from a trace still results in a trace. *) 1685 | Lemma is_trace_drop g0 g0' trace trace' (H_trace: is_trace g0 trace) n: 1686 | drop n trace = g0' :: trace' -> is_trace g0' (g0' :: trace'). 1687 | Proof. 1688 | move => H_drop. 1689 | destruct trace. inversion H_trace. 1690 | destruct H_trace as [H_g0 H_trace]; subst. 1691 | eapply path_drop' with (n:=n) in H_trace. 1692 | unfold is_trace. 1693 | destruct n. 1694 | by rewrite drop0 in H_trace; rewrite drop0 in H_drop; inversion H_drop; subst. 1695 | by rewrite H_drop in H_trace. 1696 | Qed. 1697 | 1698 | (** If some predicate is not true initially and then becomes true for some state [g_p], 1699 | this means there must have been a step from [g1] to [g2] where it became true. *) 1700 | Lemma path_gsteps_onth 1701 | g0 trace (H_path : is_trace g0 trace) 1702 | ix_p g_p (H_g_p : onth trace ix_p = Some g_p): 1703 | forall (P : pred GState), 1704 | ~~ P g0 -> P g_p -> 1705 | exists n g1 g2, step_in_path_at g1 g2 n trace /\ ~~ P g1 /\ P g2. 1706 | Proof. 1707 | destruct trace;[by contradict H_path|]. 1708 | move: H_path => [H_g0 H_path];subst g. 1709 | move=> P H_NPg0 H_Pg. 1710 | have H_path' := path_prefix ix_p H_path. 1711 | destruct ix_p as [|ix_p]; 1712 | first by exfalso;move:H_g_p H_NPg0;case => ->;rewrite H_Pg. 1713 | change (onth trace ix_p = Some g_p) in H_g_p. 1714 | 1715 | pose proof (path_steps H_path' H_NPg0). 1716 | have H_size_trace := onth_size H_g_p. 1717 | rewrite -nth_last nth_take size_takel // (onth_nth H_g_p) in H. 1718 | specialize (H H_Pg). 1719 | move:H;clear -H_NPg0;move => [n H]. 1720 | 1721 | exists n. 1722 | unfold step_in_path_at. 1723 | destruct (drop n (g0 :: take ix_p.+1 trace)) as [|x l] eqn: H_eq;[|destruct l];[done..|]. 1724 | rewrite -[g0::trace](cat_take_drop ix_p.+2). 1725 | move/andP in H;exists x, g;split;[|assumption]. 1726 | rewrite drop_cat. 1727 | case:ifP;[rewrite H_eq;done|]. 1728 | move => /negP /negP /=;rewrite ltnS -ltnNge => H_oversize. 1729 | by rewrite drop_oversize // in H_eq. 1730 | Qed. 1731 | 1732 | (** ** Preservation of users *) 1733 | 1734 | (** Global transitions preserve the set of active users. *) 1735 | Lemma gtrans_preserves_users: forall gs1 gs2, 1736 | gs1 ~~> gs2 -> domf gs1.(users) = domf gs2.(users). 1737 | Proof. 1738 | move => gs1 gs2. 1739 | elim => //. 1740 | - move => increment pre Htick. 1741 | by rewrite -tick_users_domf. 1742 | - move => pre uid msg_key pending Hpending key_ustate ustate_post sent Hcorrupt Huser /=. 1743 | by rewrite mem_fset1U //. 1744 | - move => pre uid ustate_key Hcorrupt ustate_post sent Huser /=. 1745 | by rewrite mem_fset1U //. 1746 | - move => pre uid ustate_key Hcorrupt /=. 1747 | by rewrite mem_fset1U //. 1748 | Qed. 1749 | 1750 | Lemma gtrans_domf_users: forall gs1 gs2, 1751 | gs1 ~~> gs2 -> domf gs1.(users) `<=` domf gs2.(users). 1752 | Proof. 1753 | move => gs1 gs2 H_trans. 1754 | apply gtrans_preserves_users in H_trans. 1755 | move/eqP in H_trans; rewrite eqEfsubset in H_trans; move/andP in H_trans. 1756 | tauto. 1757 | Qed. 1758 | 1759 | (** ** Transitions do not decrease step-of-ustate *) 1760 | 1761 | (** A one-step user-level transition never decreases round-period-step. *) 1762 | Lemma utr_rps_non_decreasing_msg : forall uid m us1 us2 ms, 1763 | uid # us1 ; m ~> (us2, ms) -> ustate_after us1 us2. 1764 | Proof. 1765 | move => uid m us1 us2 ms utrH. 1766 | inversion_clear utrH. 1767 | - rewrite /pre'. 1768 | unfold ustate_after => /=. 1769 | do 2! [right]. by do 2! [split; auto]. 1770 | - case: H => tH [vH oH]. 1771 | case: vH => rH [pH sH]. 1772 | unfold ustate_after => /=. 1773 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1774 | - rewrite /pre'. 1775 | unfold ustate_after => /=. 1776 | do 2! [right]. by do 2! [split; auto]. 1777 | - rewrite /pre'. 1778 | unfold ustate_after => /=. 1779 | right. left. split ; first by []. 1780 | rewrite addn1. by []. 1781 | - rewrite /pre'. 1782 | unfold ustate_after => /=. 1783 | do 2! [right]. do 2! [split; auto]. 1784 | - case: H => vH oH. 1785 | case: vH => rH [pH sH]. 1786 | unfold ustate_after => /=. 1787 | right. left. split ; first by []. 1788 | rewrite addn1. by []. 1789 | - rewrite /pre'. 1790 | unfold ustate_after => /=. 1791 | do 2! [right]. by do 2! [split; auto]. 1792 | - unfold ustate_after => /=. 1793 | left. unfold certify_ok in H. decompose record H;clear H. 1794 | revert H0;unfold pre';clear. 1795 | destruct us1;simpl. rewrite addn1 ltnS. 1796 | unfold advancing_rp. simpl. 1797 | by move => [|[->] _];[apply ltnW|apply leqnn]. 1798 | - destruct (msg_ev m) eqn:E. 1799 | destruct (msg_type m) eqn:E'. 1800 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1801 | do 2! [right]. do 2! [split; auto]. 1802 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1803 | do 2! [right]. do 2! [split; auto]. 1804 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1805 | do 2! [right]. do 2! [split; auto]. 1806 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1807 | do 2! [right]. do 2! [split; auto]. 1808 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1809 | do 2! [right]. do 2! [split; auto]. 1810 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1811 | do 2! [right]. do 2! [split; auto]. 1812 | unfold deliver_nonvote_msg_result. rewrite E. rewrite E'. unfold ustate_after => /=. 1813 | do 2! [right]. do 2! [split; auto]. 1814 | unfold deliver_nonvote_msg_result. rewrite E. unfold ustate_after => /=. 1815 | do 2! [right]. do 2! [split; auto]. 1816 | unfold deliver_nonvote_msg_result. rewrite E. unfold ustate_after => /=. 1817 | do 2! [right]. do 2! [split; auto]. 1818 | unfold deliver_nonvote_msg_result. rewrite E. unfold ustate_after => /=. 1819 | do 2! [right]. by do 2! [split; auto]. 1820 | Qed. 1821 | 1822 | (** A one-step user-level transition never decreases round-period-step. *) 1823 | Lemma utr_rps_non_decreasing_internal : forall uid us1 us2 ms, 1824 | uid # us1 ~> (us2, ms) -> ustate_after us1 us2. 1825 | Proof. 1826 | move => uid us1 us2 ms utrH. 1827 | inversion_clear utrH. 1828 | - case: H => tH [vH oH]. 1829 | case: vH => rH [pH sH]. 1830 | unfold ustate_after => /=. 1831 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1832 | - case: H => tH [vH oH]. 1833 | case: vH => rH [pH sH]. 1834 | unfold ustate_after => /=. 1835 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1836 | - case: H => tH [vH oH]. 1837 | case: vH => rH [pH sH]. 1838 | unfold ustate_after => /=. 1839 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1840 | - case: H => tH [vH oH]. 1841 | case: vH => rH [pH sH]. 1842 | unfold ustate_after => /=. 1843 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1844 | - case: H => tH [vH oH]. 1845 | case: vH => rH [pH sH]. 1846 | unfold ustate_after => /=. 1847 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1848 | - case: H => tH [vH oH]. 1849 | case: vH => rH [pH sH]. 1850 | unfold ustate_after => /=. 1851 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1852 | - case: H => tH [vH oH]. 1853 | case: vH => rH [pH sH]. 1854 | unfold ustate_after => /=. 1855 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1856 | - case: H => tH [vH oH]. 1857 | case: vH => rH [pH sH]. 1858 | unfold ustate_after => /=. 1859 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1860 | - elim: H => tH [vH [vbH [svH oH]]]. 1861 | elim: vH => rH [pH sH]. 1862 | unfold ustate_after => /=. 1863 | do 2! [right]. do 2! [split; auto]. 1864 | rewrite addn1. by subst. 1865 | - case: H => tH [vH [vbH [svH oH]]]. 1866 | case: vH => rH [pH sH]. 1867 | unfold ustate_after => /=. 1868 | do 2! [right]. do 2! [split; auto]. 1869 | rewrite addn1. by subst. 1870 | - move: H0 => v'H. 1871 | case: H => tH [vH [vbH [svH oH]]]. 1872 | case: vH => rH [pH sH]. 1873 | unfold ustate_after => /=. 1874 | do 2! [right]. do 2! [split; auto]. 1875 | rewrite addn1. by subst. 1876 | - case: H => H [vH cH]. 1877 | case: vH => rH [pH sH]. 1878 | unfold ustate_after => /=. 1879 | do 2! [right]. do 2! [split; auto]. 1880 | rewrite addn1. by subst. 1881 | - case: H => tH [vH oH]. 1882 | case: vH => rH [pH sH]. 1883 | unfold ustate_after => /=. 1884 | do 2! [right]. do 2! [split; auto]. by rewrite sH. 1885 | Qed. 1886 | 1887 | (** A one-step global transition never decreases round-period-step of any user. *) 1888 | Lemma gtr_rps_non_decreasing : forall g1 g2 uid us1 us2, 1889 | g1 ~~> g2 -> 1890 | g1.(users).[? uid] = Some us1 -> g2.(users).[? uid] = Some us2 -> 1891 | ustate_after us1 us2. 1892 | Proof. 1893 | move => g1 g2 uid us1 us2. 1894 | elim => //. 1895 | - move => increment pre Htick. 1896 | move => Hu. 1897 | case Hd: (uid \in domf (users pre)); last first. 1898 | by move/negP/negP: Hd => Hd; move: Hu; rewrite not_fnd. 1899 | rewrite tick_users_upd //. 1900 | case =><-; move: Hu. 1901 | rewrite in_fnd; case =>->. 1902 | rewrite /user_advance_timer /= /ustate_after /=. 1903 | by case: ifP => //=; right; right. 1904 | - move => pre uid0. 1905 | move => msg_key [r m] Hpend key_ustate ustate_post sent Hloc. 1906 | move/utr_rps_non_decreasing_msg => Hst. 1907 | case Huid_eq: (uid == uid0). 1908 | move/eqP: Huid_eq =>->. 1909 | rewrite in_fnd //; case =><-. 1910 | rewrite fnd_set /=. 1911 | have ->: (uid0 == uid0) by apply/eqP. 1912 | by case =><-. 1913 | move => Hus. 1914 | rewrite fnd_set /= Huid_eq Hus. 1915 | by case =>->; right; right. 1916 | - move => pre uid0. 1917 | move => ustate_key Hloc ustate_post sent. 1918 | move/utr_rps_non_decreasing_internal => Hst. 1919 | case Huid_eq: (uid == uid0). 1920 | move/eqP: Huid_eq =>->. 1921 | rewrite in_fnd //; case =><-; rewrite fnd_set /=. 1922 | have ->: (uid0 == uid0) by apply/eqP. 1923 | by case =><-. 1924 | move => Hus. 1925 | rewrite fnd_set /= Huid_eq Hus. 1926 | by case =>->; right; right. 1927 | - move => pre Hpre. 1928 | rewrite /= -/users => Hus1. 1929 | by rewrite Hus1; case =>->; right; right. 1930 | - move => pre Hpre. 1931 | rewrite /= -/users => Hus1. 1932 | by rewrite Hus1; case =>->; right; right. 1933 | - move => pre uid0 ustate_key. 1934 | move => Hcorrupt Hst; move: Hst Hcorrupt. 1935 | case Huid_eq: (uid == uid0). 1936 | move/eqP: Huid_eq =>->. 1937 | rewrite in_fnd //. 1938 | rewrite fnd_set /=. 1939 | have ->: (uid0 == uid0) by apply/eqP. 1940 | rewrite -/(users pre). 1941 | by case =>-> => Hcorrupt; case =><-; right; right. 1942 | rewrite fnd_set /= Huid_eq -/(users pre). 1943 | by move =>-> => Hcorrupt; case =>->; right; right. 1944 | - move => pre uid0. 1945 | move => ustate_key m Hc Hm. 1946 | rewrite /= =>->; case =>->. 1947 | by right; right. 1948 | - move => pre sender. 1949 | move => sender_key r p s mtype mval Hhave Hcomm Hmatch. 1950 | rewrite /= =>->; case =>->. 1951 | by right; right. 1952 | Qed. 1953 | 1954 | (** Generalization of non-decreasing round-period-step results to paths. *) 1955 | Lemma greachable_rps_non_decreasing : forall g1 g2 uid us1 us2, 1956 | greachable g1 g2 -> 1957 | g1.(users).[? uid] = Some us1 -> g2.(users).[? uid] = Some us2 -> 1958 | ustate_after us1 us2. 1959 | Proof. 1960 | move => g1 g2 uid us1 us2. 1961 | case => gtrace Hpath Hlast. 1962 | destruct gtrace. inversion Hpath. 1963 | destruct Hpath as [H_g0 Hpath]; subst g. 1964 | elim: gtrace g1 g2 uid us1 us2 Hpath Hlast => //=. 1965 | move => g1 g2 uid us1 us2 Htr ->->; case =>->. 1966 | by right; right. 1967 | move => g gtrace IH. 1968 | move => g1 g2 uid us1 us2. 1969 | move/andP => [Htrans Hpath] Hlast Hg1 Hg2. 1970 | move/asboolP: Htrans => Htrans. 1971 | case Hg: (users g).[? uid] => [u|]. 1972 | have IH' := IH _ _ _ _ _ Hpath Hlast Hg Hg2. 1973 | have Haft := gtr_rps_non_decreasing Htrans Hg1 Hg. 1974 | move: Haft IH'. 1975 | exact: ustate_after_transitive. 1976 | move/gtrans_domf_users: Htrans => Hdomf. 1977 | case Hd: (uid \in domf (users g1)); last first. 1978 | by move/negP/negP: Hd => Hd; move: Hg1; rewrite not_fnd. 1979 | move/idP: Hd => Hd. 1980 | move: Hdomf. 1981 | move/fsubsetP => Hsub. 1982 | move: Hd; move/Hsub => Hdom. 1983 | move: Hg. 1984 | by rewrite in_fnd. 1985 | Qed. 1986 | 1987 | (** ** Monotonicity and preservation lemmas *) 1988 | 1989 | (** Softvotes are monotone over internal user transitions. *) 1990 | Lemma softvotes_utransition_internal: 1991 | forall uid pre post msgs, uid # pre ~> (post, msgs) -> 1992 | forall r p, {subset pre.(softvotes) (r, p) <= post.(softvotes) (r, p)}. 1993 | Proof. 1994 | move => uid pre post msgs step r p. 1995 | remember (post,msgs) as result eqn:H_result; 1996 | destruct step;case:H_result => [? ?];subst;done. 1997 | Qed. 1998 | 1999 | (** Softvotes are monotone over user message transitions. *) 2000 | Lemma softvotes_utransition_deliver: 2001 | forall uid pre post m msgs, uid # pre ; m ~> (post, msgs) -> 2002 | forall r p, 2003 | {subset pre.(softvotes) (r, p) <= post.(softvotes) (r, p)}. 2004 | Proof. 2005 | move => uid pre post m msgs step r p. 2006 | remember (post,msgs) as result eqn:H_result. 2007 | destruct step;case:H_result => [? ?];subst. 2008 | all: destruct pre;simpl;autounfold with utransition_unfold. 2009 | all: repeat match goal with [ |- context C[ match ?b with _ => _ end]] => destruct b end. 2010 | all: move => x H_x //. 2011 | - rewrite fsfun_withE. 2012 | case Hrp: (_ == _) => //. 2013 | by move/eqP: Hrp; case =><--<-; rewrite mem_undup. 2014 | - rewrite fsfun_withE. 2015 | case Hrp: (_ == _) => //. 2016 | move/eqP: Hrp; case =><--<-. 2017 | by rewrite in_cons mem_undup H_x orbT. 2018 | - rewrite fsfun_withE. 2019 | case Hrp: (_ == _) => //. 2020 | by move/eqP: Hrp; case =><--<-; rewrite mem_undup. 2021 | - rewrite fsfun_withE. 2022 | case Hrp: (_ == _) => //. 2023 | move/eqP: Hrp; case =><--<-. 2024 | by rewrite in_cons mem_undup H_x orbT. 2025 | Qed. 2026 | 2027 | (** Softvotes are monotone over global transitions. *) 2028 | Lemma softvotes_gtransition g1 g2 (H_step:g1 ~~> g2) uid: 2029 | forall u1, g1.(users).[?uid] = Some u1 -> 2030 | exists u2, g2.(users).[?uid] = Some u2 /\ 2031 | forall r p, {subset u1.(softvotes) (r, p) <= u2.(softvotes) (r, p)}. 2032 | Proof. 2033 | clear -H_step => u1 H_u1. 2034 | have H_in1: (uid \in g1.(users)) by rewrite -fndSome H_u1. 2035 | have H_in1': g1.(users)[`H_in1] = u1 by rewrite in_fnd in H_u1;case:H_u1. 2036 | destruct H_step;simpl users;autounfold with gtransition_unfold; 2037 | try (rewrite fnd_set;case H_eq:(uid == uid0); 2038 | [move/eqP in H_eq;subst uid0|]); 2039 | try (eexists;split;[eassumption|done]); 2040 | first rewrite updf_update //; 2041 | (eexists;split;[eauto|]); try by intuition auto. 2042 | * (* tick *) 2043 | move => r p v Hv. 2044 | rewrite H_in1' /user_advance_timer. 2045 | by match goal with [ |- context C[ match ?b with _ => _ end]] => destruct b end. 2046 | * (* deliver *) 2047 | move:H1. rewrite ?(eq_getf _ H_in1) H_in1'. 2048 | exact: softvotes_utransition_deliver. 2049 | * (* internal *) 2050 | move:H0. rewrite ?(eq_getf _ H_in1) H_in1'. 2051 | exact: softvotes_utransition_internal. 2052 | * (* corrupt *) 2053 | by rewrite ?(eq_getf _ H_in1) /= H_in1' => r p v Hv. 2054 | Qed. 2055 | 2056 | (** Softvotes are monotone between reachable states. *) 2057 | Lemma softvotes_monotone g1 g2 (H_reach:greachable g1 g2) uid: 2058 | forall u1, g1.(users).[?uid] = Some u1 -> 2059 | forall u2, g2.(users).[?uid] = Some u2 -> 2060 | forall r p, {subset u1.(softvotes) (r, p) <= u2.(softvotes) (r, p)}. 2061 | Proof. 2062 | clear -H_reach. 2063 | move => u1 H_u1 u2 H_u2. 2064 | destruct H_reach as [trace H_path H_last]. 2065 | destruct trace. inversion H_path. 2066 | destruct H_path as [H_g0 H_path]. subst g. 2067 | move: g1 H_path H_last u1 H_u1. 2068 | induction trace. 2069 | * simpl. by move => g1 _ <- u1;rewrite H_u2{H_u2};case => -> r p v Hv. 2070 | * cbn [path last] => g1 /andP [/asboolP H_step H_path] H_last u1 H_u1 r p v Hv. 2071 | specialize (IHtrace a H_path H_last). 2072 | have [umid [H_umid H_sub]] := softvotes_gtransition H_step H_u1. 2073 | specialize (H_sub r p). 2074 | specialize (IHtrace umid H_umid r p). 2075 | apply IHtrace. 2076 | exact: H_sub. 2077 | Qed. 2078 | 2079 | (** The weight of softvotes is monotone between reachable states. *) 2080 | Lemma soft_weight_monotone g1 g2 (H_reach:greachable g1 g2) uid: 2081 | forall u1, g1.(users).[?uid] = Some u1 -> 2082 | forall u2, g2.(users).[?uid] = Some u2 -> 2083 | forall v r p, soft_weight v u1 r p <= soft_weight v u2 r p. 2084 | Proof. 2085 | move => u1 H_u1 u2 H_u2 v r p. 2086 | have H_mono := softvotes_monotone H_reach H_u1 H_u2. 2087 | apply fsubset_leq_card. 2088 | unfold softvoters_for. 2089 | move: (u1.(softvotes)) (u2.(softvotes)) H_mono. 2090 | clear => s1 s2 H_mono. 2091 | apply subset_imfset. 2092 | simpl. 2093 | move => x /andP [H_x_s1 H_val]. 2094 | by apply/andP;split;[apply/H_mono|]. 2095 | Qed. 2096 | 2097 | (** Blocks are monotone over internal user transitions. *) 2098 | Lemma blocks_utransition_internal: 2099 | forall uid pre post msgs, uid # pre ~> (post, msgs) -> 2100 | forall r, {subset pre.(blocks) r <= post.(blocks) r}. 2101 | Proof. 2102 | move => uid pre post msgs step r. 2103 | remember (post,msgs) as result eqn:H_result; 2104 | destruct step;case:H_result => [? ?];subst;done. 2105 | Qed. 2106 | 2107 | (** Blocks are monotone over user message transition. *) 2108 | Lemma blocks_utransition_deliver: 2109 | forall uid pre post m msgs, uid # pre ; m ~> (post, msgs) -> 2110 | forall r, {subset pre.(blocks) r <= post.(blocks) r}. 2111 | Proof. 2112 | move => uid pre post m msgs step r; 2113 | remember (post,msgs) as result eqn:H_result; 2114 | destruct step;case:H_result => [? ?];subst; 2115 | destruct pre;simpl;autounfold with utransition_unfold; 2116 | repeat match goal with [ |- context C[ match ?b with _ => _ end]] => destruct b 2117 | | _ => progress simpl end; 2118 | try (by apply subxx_hint); 2119 | try (by move => x H_x). 2120 | - rewrite fsfun_withE => b Hb. 2121 | case Hr: (r == r0) => //; move/eqP: Hr =><-. 2122 | by rewrite mem_undup. 2123 | - rewrite fsfun_withE => b Hb. 2124 | case Hr: (r == r0) => //; move/eqP: Hr =><-. 2125 | by rewrite in_cons mem_undup Hb orbT. 2126 | Qed. 2127 | 2128 | (** Blocks are monotone over global transition. *) 2129 | Lemma blocks_gtransition g1 g2 (H_step:g1 ~~> g2) uid: 2130 | forall u1, g1.(users).[?uid] = Some u1 -> 2131 | exists u2, g2.(users).[?uid] = Some u2 /\ 2132 | forall r, {subset u1.(blocks) r <= u2.(blocks) r}. 2133 | Proof. 2134 | clear -H_step => u1 H_u1. 2135 | have H_in1: (uid \in g1.(users)) by rewrite -fndSome H_u1. 2136 | have H_in1': g1.(users)[`H_in1] = u1 by rewrite in_fnd in H_u1;case:H_u1. 2137 | destruct H_step;simpl users;autounfold with gtransition_unfold; 2138 | try (rewrite fnd_set;case H_eq:(uid == uid0); 2139 | [move/eqP in H_eq;subst uid0|]); 2140 | try (eexists;split;[eassumption|done]); 2141 | first rewrite updf_update //; 2142 | (eexists;split;[eauto|]); try by intuition auto. 2143 | * (* tick *) 2144 | move => r p Hp. 2145 | rewrite H_in1' /user_advance_timer. 2146 | by match goal with [ |- context C[ match ?b with _ => _ end]] => destruct b end. 2147 | * (* deliver *) 2148 | move:H1. rewrite ?(eq_getf _ H_in1) H_in1'. 2149 | exact: blocks_utransition_deliver. 2150 | * (* internal *) 2151 | move:H0. rewrite ?(eq_getf _ H_in1) H_in1'. 2152 | exact: blocks_utransition_internal. 2153 | * (* corrupt *) 2154 | by rewrite ?(eq_getf _ H_in1) H_in1' => r p Hp. 2155 | Qed. 2156 | 2157 | (** Blocks are monotone between reachable states. *) 2158 | Lemma blocks_monotone g1 g2 (H_reach: greachable g1 g2) uid: 2159 | forall u1, g1.(users).[? uid] = Some u1 -> 2160 | forall u2, g2.(users).[? uid] = Some u2 -> 2161 | forall r, {subset u1.(blocks) r <= u2.(blocks) r}. 2162 | Proof. 2163 | clear -H_reach. 2164 | move => u1 H_u1 u2 H_u2. 2165 | destruct H_reach as [trace H_path H_last]. 2166 | destruct trace. inversion H_path. 2167 | destruct H_path as [H_g0 H_path]. subst g. 2168 | move: g1 H_path H_last u1 H_u1. 2169 | induction trace. 2170 | * simpl. by move => g1 _ <- u1;rewrite H_u2{H_u2};case => -> r p Hp. 2171 | * cbn [path last] => g1 /andP [/asboolP H_step H_path] H_last u1 H_u1 r p Hp. 2172 | specialize (IHtrace a H_path H_last). 2173 | have [umid [H_umid H_sub]] := blocks_gtransition H_step H_u1. 2174 | specialize (H_sub r). 2175 | specialize (IHtrace umid H_umid r). 2176 | apply IHtrace. 2177 | exact: H_sub. 2178 | Qed. 2179 | 2180 | (** Starting values are preserved over internal user transition. *) 2181 | Lemma stv_utransition_internal: 2182 | forall uid pre post msgs, uid # pre ~> (post, msgs) -> 2183 | pre.(round) = post.(round) -> 2184 | pre.(period) = post.(period) -> 2185 | forall p, pre.(stv).[? p] = post.(stv).[? p]. 2186 | Proof. 2187 | move => uid pre post msgs step. 2188 | remember (post,msgs) as result eqn:H_result; 2189 | destruct step;case:H_result => [? ?];subst;done. 2190 | Qed. 2191 | 2192 | (** Starting values are preserved by message user transitions. *) 2193 | Lemma stv_utransition_deliver: 2194 | forall uid pre post m msgs, uid # pre ; m ~> (post, msgs) -> 2195 | pre.(round) = post.(round) -> 2196 | pre.(period) = post.(period) -> 2197 | forall p, pre.(stv).[? p] = post.(stv).[? p]. 2198 | Proof. 2199 | move => uid pre post m msgs step H_round H_period. 2200 | remember (post,msgs) as result eqn:H_result; 2201 | destruct step;case:H_result => [? ?];subst; 2202 | try by (destruct pre;simpl;autounfold with utransition_unfold;done). 2203 | * { 2204 | exfalso;move: H_period;clear;destruct pre;simpl;clear. 2205 | rewrite -[period in period = _]addn0. move/addnI. done. 2206 | } 2207 | * { 2208 | exfalso;move: H_period;clear;destruct pre;simpl;clear. 2209 | rewrite -[period in period = _]addn0. move/addnI. done. 2210 | } 2211 | * { exfalso;unfold certify_ok in H;decompose record H;clear H. 2212 | move:H0. rewrite /advancing_rp H_round;clear;simpl. 2213 | by case =>[|[]];[rewrite ltnNge leq_addr 2214 | |rewrite -[r in _ = r]addn0;move/addnI]. 2215 | } 2216 | * { clear. 2217 | unfold deliver_nonvote_msg_result. 2218 | by destruct msg, msg_ev, msg_type. 2219 | } 2220 | Qed. 2221 | 2222 | (** Starting values are preserved by global transitions. *) 2223 | Lemma stv_gtransition g1 g2 (H_step:g1 ~~> g2) uid: 2224 | forall u1, g1.(users).[?uid] = Some u1 -> 2225 | exists u2, g2.(users).[?uid] = Some u2 /\ 2226 | (u1.(round) = u2.(round) -> 2227 | u1.(period) = u2.(period) -> 2228 | forall p, u1.(stv).[? p] = u2.(stv).[? p]). 2229 | Proof. 2230 | clear -H_step => u1 H_u1. 2231 | have H_in1: (uid \in g1.(users)) by rewrite -fndSome H_u1. 2232 | have H_in1': g1.(users)[`H_in1] = u1 by rewrite in_fnd in H_u1;case:H_u1. 2233 | destruct H_step;simpl users;autounfold with gtransition_unfold; 2234 | try (rewrite fnd_set;case H_eq:(uid == uid0); 2235 | [move/eqP in H_eq;subst uid0|]); 2236 | try (eexists;split;[eassumption|done]); 2237 | first rewrite updf_update //; 2238 | (eexists;split;[reflexivity|]). 2239 | * (* tick *) 2240 | rewrite H_in1' /user_advance_timer. 2241 | by match goal with [ |- context C[ match ?b with _ => _ end]] => destruct b end. 2242 | * (* deliver *) 2243 | move:H1. rewrite ?(eq_getf _ H_in1) H_in1'. apply stv_utransition_deliver. 2244 | * (* internal *) 2245 | move:H0. rewrite ?(eq_getf _ H_in1) H_in1'. apply stv_utransition_internal. 2246 | * (* corrupt *) 2247 | rewrite ?(eq_getf _ H_in1) H_in1'. done. 2248 | Qed. 2249 | 2250 | (** Starting values are preserved between reachable states. *) 2251 | Lemma stv_forward 2252 | g1 g2 (H_reach : greachable g1 g2) 2253 | uid u1 u2: 2254 | g1.(users).[?uid] = Some u1 -> 2255 | g2.(users).[?uid] = Some u2 -> 2256 | u1.(round) = u2.(round) -> 2257 | u1.(period) = u2.(period) -> 2258 | forall p, u1.(stv).[? p] = u2.(stv).[? p]. 2259 | Proof. 2260 | clear -H_reach. 2261 | move => H_u1 H_u2 H_r H_p. 2262 | destruct H_reach as [trace H_path H_last]. 2263 | 2264 | destruct trace. inversion H_path. 2265 | destruct H_path as [H_g0 H_path]. subst g. 2266 | 2267 | move: g1 H_path H_last u1 H_u1 H_r H_p. 2268 | induction trace. 2269 | * simpl. by move => g1 _ <- u1;rewrite H_u2{H_u2};case => ->. 2270 | * cbn [path last] => g1 /andP [/asboolP H_step H_path] H_last u1 H_u1 H_r H_p p. 2271 | 2272 | assert (H_reach : greachable a g2). 2273 | by eapply ex_intro2 with (a::trace); unfold is_trace. 2274 | 2275 | specialize (IHtrace a H_path H_last). 2276 | have [umid [H_umid H_sub]] := stv_gtransition H_step H_u1. 2277 | specialize (IHtrace umid H_umid). 2278 | have H_le_u1_umid := gtr_rps_non_decreasing H_step H_u1 H_umid. 2279 | have H_le_umid_u2 := greachable_rps_non_decreasing H_reach H_umid H_u2. 2280 | have H_r': u1.(round) = umid.(round). { 2281 | move: H_r H_p H_le_u1_umid H_le_umid_u2. 2282 | unfold ustate_after. destruct u1,umid,u2;simpl;clear;intros;subst. 2283 | by intuition lia. 2284 | } 2285 | have H_p': u1.(period) = umid.(period). { 2286 | move: H_r H_p H_le_u1_umid H_le_umid_u2. 2287 | unfold ustate_after. destruct u1,umid,u2;simpl;clear;intros;subst. 2288 | by intuition lia. 2289 | } 2290 | specialize (H_sub H_r' H_p'). 2291 | rewrite H_sub. clear H_sub. 2292 | apply IHtrace;congruence. 2293 | Qed. 2294 | 2295 | (** ** Lemmas for deducing reachability between global states *) 2296 | 2297 | (** If the index of [g1] is less than the index of [g2], and both are in a 2298 | trace, this implies [g2] is reachable from [g1]. *) 2299 | Lemma at_greachable 2300 | g0 states (H_path: is_trace g0 states) 2301 | ix1 ix2 (H_le : ix1 <= ix2) 2302 | g1 (H_g1 : onth states ix1 = Some g1) 2303 | g2 (H_g2 : onth states ix2 = Some g2) : 2304 | greachable g1 g2. 2305 | Proof. 2306 | clear -H_path H_le H_g1 H_g2. 2307 | assert (ix2 < size states) by 2308 | (rewrite -subn_gt0 -size_drop; 2309 | move: H_g2;clear;unfold onth; 2310 | by destruct (drop ix2 states)). 2311 | 2312 | exists (g1 :: (drop ix1.+1 (take ix2.+1 states))). 2313 | { 2314 | eapply is_trace_prefix with (n:=ix2.+1) in H_path; try (by intuition). 2315 | eapply is_trace_drop with (g0':=g1) (n:=ix1) in H_path; try eassumption. 2316 | rewrite {1}(drop_nth g2). 2317 | rewrite nth_take //. 2318 | rewrite (onth_nth H_g1) //. 2319 | rewrite size_take. 2320 | destruct (ix2.+1 < size states); by lia. 2321 | } 2322 | { 2323 | simpl. 2324 | rewrite (last_nth g1) size_drop size_takel //. 2325 | move:(H_le). rewrite leq_eqVlt. 2326 | move/orP => [H_eq | H_lt]. 2327 | by move/eqP in H_eq;subst;rewrite subnn;simpl;congruence. 2328 | by rewrite subSn //= nth_drop subnKC // nth_take ?ltnS // (onth_nth H_g2). 2329 | } 2330 | Qed. 2331 | 2332 | (** [step_in_path_at] from [pre] to [post] and [pre2] to [post2] 2333 | implies [pre2] reachable from [post]. *) 2334 | Lemma steps_greachable 2335 | g0 path (H_path : is_trace g0 path) 2336 | ix ix2 (H_lt : ix < ix2) 2337 | pre post (H_step : step_in_path_at pre post ix path) 2338 | pre2 post2 (H_step2 : step_in_path_at pre2 post2 ix2 path): 2339 | greachable post pre2. 2340 | Proof. 2341 | apply step_in_path_onth_post in H_step. 2342 | apply step_in_path_onth_pre in H_step2. 2343 | eapply at_greachable;eassumption. 2344 | Qed. 2345 | 2346 | (** ** Lemmas about order of indices in a trace *) 2347 | 2348 | (** If the step of a user is smaller in [g1] than [g2], this 2349 | implies that the index of [g1] is less than the index of [g2]. *) 2350 | Lemma order_ix_from_steps g0 trace (H_path: is_trace g0 trace): 2351 | forall ix1 g1, onth trace ix1 = Some g1 -> 2352 | forall ix2 g2, onth trace ix2 = Some g2 -> 2353 | forall uid (key1: uid \in g1.(users)) (key2: uid \in g2.(users)), 2354 | step_lt (step_of_ustate (g1.(users)[`key1])) (step_of_ustate (g2.(users)[`key2])) -> 2355 | ix1 < ix2. 2356 | Proof. 2357 | move => ix1 g1 H_g1 ix2 g2 H_g2 uid key1 key2 H_step_lt. 2358 | rewrite ltnNge. apply /negP => H_ix_le. 2359 | 2360 | suff: ustate_after (g2.(users)[`key2]) (g1.(users)[`key1]) 2361 | by move/ustate_after_iff_step_le /(step_lt_le_trans H_step_lt);apply step_lt_irrefl. 2362 | 2363 | have H_reach: greachable g2 g1 by eapply at_greachable;eassumption. 2364 | exact (greachable_rps_non_decreasing H_reach (in_fnd _) (in_fnd _)). 2365 | Qed. 2366 | 2367 | (** step of [msg_step] for [msg1] smaller than [msg2] implies index of [msg1] less than index of [msg2]. *) 2368 | Lemma order_sends g0 trace (H_path: is_trace g0 trace) uid 2369 | ix1 msg1 (H_send1: user_sent_at ix1 trace uid msg1) 2370 | ix2 msg2 (H_send2: user_sent_at ix2 trace uid msg2): 2371 | step_le (msg_step msg1) (msg_step msg2) -> 2372 | ix1 <= ix2. 2373 | Proof. 2374 | move => H_step_le. 2375 | move: H_send1 => [pre1 [post1 [H_step1 H_send1]]]. 2376 | move: H_send2 => [pre2 [post2 [H_step2 H_send2]]]. 2377 | 2378 | rewrite leqNgt. apply /negP => H_lt. 2379 | have H_reach: greachable post2 pre1. 2380 | eapply (at_greachable H_path H_lt);eauto using step_in_path_onth_pre, step_in_path_onth_post. 2381 | have := greachable_rps_non_decreasing H_reach 2382 | (in_fnd (user_sent_in_post H_send2)) 2383 | (in_fnd (user_sent_in_pre H_send1)). 2384 | move/ustate_after_iff_step_le. 2385 | have:= utransition_label_end H_send2 (in_fnd (user_sent_in_post H_send2)). 2386 | have -> := utransition_label_start H_send1 (in_fnd (user_sent_in_pre H_send1)). 2387 | move => H_step_lt H_step_le1. 2388 | have {H_step_le1}H_step_lt1 := step_lt_le_trans H_step_lt H_step_le1. 2389 | have:= step_le_lt_trans H_step_le H_step_lt1. 2390 | clear. 2391 | move: (msg_step msg1) => [[r p] s]. 2392 | by apply step_lt_irrefl. 2393 | Qed. 2394 | 2395 | (** ** Additional lemmas about honesty *) 2396 | 2397 | (** Honest at all points less than or equal to step implies honest at [g1]. *) 2398 | Lemma user_honest_from_during g0 trace (H_path: is_trace g0 trace): 2399 | forall ix g1, 2400 | onth trace ix = Some g1 -> 2401 | forall uid (H_in : uid \in g1.(users)), 2402 | honest_during_step (step_of_ustate (g1.(users)[`H_in])) uid trace -> 2403 | user_honest uid g1. 2404 | Proof. 2405 | move => ix g1 H_onth uid H_in /all_nthP. 2406 | move/(_ g1 ix (onth_size H_onth)). 2407 | rewrite (onth_nth H_onth g1) /user_honest /upred' (in_fnd H_in). 2408 | move/implyP;apply. 2409 | by apply /step_leP /step_le_refl. 2410 | Qed. 2411 | 2412 | (** Honest at all [(r,p,s)] less than step of [u] implies honest_during [(r,p,s)]. *) 2413 | Lemma honest_during_from_ustate trace g0 (H_path : is_trace g0 trace): 2414 | forall ix g, 2415 | onth trace ix = Some g -> 2416 | forall uid u, 2417 | g.(users).[? uid] = Some u -> 2418 | ~~ u.(corrupt) -> 2419 | forall r p s, 2420 | step_lt (r,p,s) (step_of_ustate u) -> 2421 | honest_during_step (r,p,s) uid trace. 2422 | Proof. 2423 | move => ix g H_g uid u H_u H_honest r p s H_lt. 2424 | have H_g_honest: user_honest uid g by rewrite /user_honest H_u. 2425 | apply/allP => x H_in_x. 2426 | unfold upred'. 2427 | case:fndP => // key_x. 2428 | apply/implyP => /step_leP /step_le_lt_trans /(_ H_lt) H_x_lt. 2429 | suff: user_honest uid x by rewrite /user_honest (in_fnd key_x). 2430 | apply/honest_monotone:H_g_honest. 2431 | have H_x := onth_index H_in_x. 2432 | refine (at_greachable H_path (ltnW _) H_x H_g). 2433 | have H_inu: uid \in (g.(users)) by rewrite -fndSome H_u. 2434 | have H_u_eq: g.(users)[`H_inu] = u. 2435 | by pose proof (in_fnd H_inu) as H_fnd; rewrite H_u in H_fnd; inversion H_fnd. 2436 | eapply order_ix_from_steps with (key1:=key_x) (key2:=H_inu); try eassumption. 2437 | by rewrite H_u_eq. 2438 | Qed. 2439 | 2440 | (** Honest_during [(r,p,s)], [u] is at index of [n] in trace, 2441 | and step of [u] less than or equal to [(r,p,s)] implies [user_honest_at n]. *) 2442 | Lemma honest_at_from_during r p s uid trace: 2443 | honest_during_step (r,p,s) uid trace -> 2444 | forall g0 (H_path: is_trace g0 trace), 2445 | forall n g, onth trace n = Some g -> 2446 | forall u, g.(users).[? uid] = Some u -> 2447 | step_le (step_of_ustate u) (r,p,s) -> 2448 | user_honest_at n trace uid. 2449 | Proof. 2450 | clear. 2451 | move => H_honest g0 H_path n g H_onth u H_u H_le. 2452 | apply (onth_at_step H_onth). 2453 | move: H_honest => /all_nthP - /(_ g n (onth_size H_onth)). 2454 | rewrite (onth_nth H_onth) /upred' /user_honest H_u => /implyP. 2455 | by apply;apply /step_leP. 2456 | Qed. 2457 | 2458 | (** User honest during step means user sends a message. *) 2459 | Lemma honest_during_from_sent 2460 | g0 trace (H_path: is_trace g0 trace) 2461 | ix uid mty mval r p (H_send: user_sent_at ix trace uid (mkMsg mty mval r p uid)): 2462 | honest_during_step (msg_step (mkMsg mty mval r p uid)) uid trace. 2463 | Proof. 2464 | move: H_send => [g1 [g2 [H_step H_send]]]. 2465 | have H_honest := negbT (user_sent_honest_post H_send). 2466 | have H_in := in_fnd (user_sent_in_post H_send). 2467 | apply (honest_during_from_ustate H_path (step_in_path_onth_post H_step) H_in H_honest). 2468 | exact (utransition_label_end H_send H_in). 2469 | Qed. 2470 | 2471 | (** User sends message at [r,p] and [msg_step <= (r,p,s)] means user is honest at [r,p]. *) 2472 | Lemma honest_in_from_during_and_send: forall r p s uid trace, 2473 | honest_during_step (r,p,s) uid trace -> 2474 | forall g0 (H_path : is_trace g0 trace), 2475 | forall ix g1 g2, 2476 | step_in_path_at g1 g2 ix trace -> 2477 | forall mt v, 2478 | user_sent uid (mkMsg mt v r p uid) g1 g2 -> 2479 | step_le (msg_step (mkMsg mt v r p uid)) (r,p,s) -> 2480 | honest_in_period r p uid trace. 2481 | Proof. 2482 | move => r p s uid trace H_honest g0 H_path ix g1 g2 H_step mt v H_sent H_msg_step. 2483 | have H_g1 := step_in_path_onth_pre H_step. 2484 | exists ix. rewrite H_g1. 2485 | have key1 := user_sent_in_pre H_sent. 2486 | rewrite (in_fnd key1). 2487 | have H_step1 := utransition_label_start H_sent (in_fnd key1). 2488 | lapply (user_honest_from_during H_path H_g1 (H_in:=key1)). 2489 | - rewrite /user_honest (in_fnd key1) => /negP H_honest_g1. 2490 | split;[assumption|]. 2491 | by injection H_step1. 2492 | - revert H_honest. 2493 | apply honest_during_le. 2494 | by rewrite H_step1. 2495 | Qed. 2496 | --------------------------------------------------------------------------------