├── .gitignore ├── CONTRIBUTING.md ├── LICENSE.txt ├── LibraBFT.agda-lib ├── README.md ├── SECURITY.md ├── STYLE.md ├── Scripts ├── clean.sh ├── gen-everything.sh ├── remove-trailing-whitespace.sh └── run-everything.sh ├── THIRD_PARTY_LICENSES.txt ├── TODO.md ├── docs ├── .gitignore ├── PeerHandlerContracts.org └── README.org └── src ├── Dijkstra ├── AST │ ├── Branching.agda │ ├── Core.agda │ ├── Either.agda │ ├── Examples │ │ ├── Either │ │ │ └── Bind.agda │ │ ├── Maybe │ │ │ ├── Bind.agda │ │ │ ├── Branching.agda │ │ │ └── Partiality.agda │ │ ├── PaperIntro.agda │ │ └── RWS.agda │ ├── Maybe.agda │ ├── Prelude.agda │ ├── RWS.agda │ └── Syntax.agda ├── All.agda ├── EitherD.agda ├── EitherD │ └── Syntax.agda ├── EitherLike.agda ├── RWS.agda ├── RWS │ └── Syntax.agda └── Syntax.agda ├── FunctorApplicativeMonad.agda ├── Haskell ├── Modules │ ├── Either.agda │ ├── Eq.agda │ ├── RWS.agda │ ├── RWS │ │ ├── Lens.agda │ │ └── RustAnyHow.agda │ └── ToBool.agda └── Prelude.agda ├── LibraBFT ├── Abstract │ ├── Abstract.agda │ ├── BFT.agda │ ├── Properties.agda │ ├── RecordChain.agda │ ├── RecordChain │ │ ├── Assumptions.agda │ │ └── Properties.agda │ ├── Records.agda │ ├── Records │ │ └── Extends.agda │ ├── System.agda │ ├── Types.agda │ └── Types │ │ └── EpochConfig.agda ├── Base │ ├── Types.agda │ └── Util.agda ├── Concrete │ ├── Intermediate.agda │ ├── Obligations.agda │ ├── Obligations │ │ ├── PreferredRound.agda │ │ └── VotesOnce.agda │ ├── Properties.agda │ ├── Properties │ │ ├── Common.agda │ │ ├── PreferredRound.agda │ │ └── VotesOnce.agda │ ├── Records.agda │ ├── System.agda │ └── System │ │ └── Parameters.agda ├── Impl │ ├── Consensus │ │ ├── BlockStorage │ │ │ ├── BlockRetriever.agda │ │ │ ├── BlockStore.agda │ │ │ ├── BlockTree-AST.agda │ │ │ ├── BlockTree.agda │ │ │ ├── Properties │ │ │ │ ├── BlockStore.agda │ │ │ │ ├── BlockTree-AST.agda │ │ │ │ ├── BlockTree.agda │ │ │ │ └── SyncManager.agda │ │ │ └── SyncManager.agda │ │ ├── ConsensusProvider.agda │ │ ├── ConsensusTypes │ │ │ ├── Block.agda │ │ │ ├── BlockData.agda │ │ │ ├── BlockRetrieval.agda │ │ │ ├── ExecutedBlock.agda │ │ │ ├── Properties │ │ │ │ ├── QuorumCert.agda │ │ │ │ ├── SyncInfo.agda │ │ │ │ └── VoteData.agda │ │ │ ├── ProposalMsg.agda │ │ │ ├── QuorumCert.agda │ │ │ ├── SyncInfo.agda │ │ │ ├── TimeoutCertificate.agda │ │ │ ├── Vote.agda │ │ │ ├── VoteData.agda │ │ │ └── VoteMsg.agda │ │ ├── EpochManager.agda │ │ ├── EpochManager │ │ │ └── Properties.agda │ │ ├── EpochManagerTypes.agda │ │ ├── LedgerRecoveryData.agda │ │ ├── Liveness │ │ │ ├── ExponentialTimeInterval.agda │ │ │ ├── Properties │ │ │ │ └── ProposerElection.agda │ │ │ ├── ProposalGenerator.agda │ │ │ ├── ProposerElection.agda │ │ │ └── RoundState.agda │ │ ├── MetricsSafetyRules.agda │ │ ├── Network.agda │ │ ├── Network │ │ │ └── Properties.agda │ │ ├── PendingVotes.agda │ │ ├── PersistentLivenessStorage.agda │ │ ├── PersistentLivenessStorage │ │ │ └── Properties.agda │ │ ├── Properties │ │ │ ├── ConsensusProvider.agda │ │ │ └── MetricsSafetyRules.agda │ │ ├── RecoveryData.agda │ │ ├── RoundManager.agda │ │ ├── RoundManager │ │ │ └── Properties.agda │ │ ├── SafetyRules │ │ │ ├── PersistentSafetyStorage.agda │ │ │ ├── Properties │ │ │ │ └── SafetyRules.agda │ │ │ ├── SafetyRules.agda │ │ │ └── SafetyRulesManager.agda │ │ ├── StateComputerByteString.agda │ │ └── TestUtils │ │ │ ├── MockSharedStorage.agda │ │ │ └── MockStorage.agda │ ├── Crypto │ │ └── Crypto │ │ │ └── Hash.agda │ ├── Execution │ │ └── ExecutorTypes │ │ │ └── StateComputeResult.agda │ ├── Handle.agda │ ├── Handle │ │ ├── InitProperties.agda │ │ └── Properties.agda │ ├── IO │ │ └── OBM │ │ │ ├── GenKeyFile.agda │ │ │ ├── InputOutputHandlers.agda │ │ │ ├── Messages.agda │ │ │ ├── ObmNeedFetch.agda │ │ │ ├── Properties │ │ │ ├── InputOutputHandlers.agda │ │ │ └── Start.agda │ │ │ └── Start.agda │ ├── OBM │ │ ├── ConfigHardCoded.agda │ │ ├── Crypto.agda │ │ ├── ECP-LBFT-OBM-Diff │ │ │ ├── ECP-LBFT-OBM-Diff-0.agda │ │ │ ├── ECP-LBFT-OBM-Diff-1.agda │ │ │ └── ECP-LBFT-OBM-Diff-2.agda │ │ ├── Genesis.agda │ │ ├── Logging │ │ │ └── Logging.agda │ │ ├── Prelude.agda │ │ ├── Rust │ │ │ ├── Duration.agda │ │ │ └── RustTypes.agda │ │ ├── Time.agda │ │ └── Util.agda │ ├── Properties │ │ ├── Common.agda │ │ ├── PreferredRound.agda │ │ ├── Util.agda │ │ └── VotesOnce.agda │ ├── Storage │ │ └── DiemDB │ │ │ ├── DiemDB.agda │ │ │ └── LedgerStore │ │ │ └── LedgerStore.agda │ └── Types │ │ ├── BlockInfo.agda │ │ ├── CryptoProxies.agda │ │ ├── EpochChangeProof.agda │ │ ├── EpochState.agda │ │ ├── Ledger2WaypointConverter.agda │ │ ├── LedgerInfo.agda │ │ ├── LedgerInfoWithSignatures.agda │ │ ├── OnChainConfig │ │ └── ValidatorSet.agda │ │ ├── Properties │ │ └── LedgerInfoWithSignatures.agda │ │ ├── ValidatorSigner.agda │ │ ├── ValidatorVerifier.agda │ │ ├── Verifier.agda │ │ └── Waypoint.agda └── ImplShared │ ├── Base │ └── Types.agda │ ├── Consensus │ ├── Types.agda │ └── Types │ │ ├── EpochDep.agda │ │ └── EpochIndep.agda │ ├── Interface │ └── Output.agda │ ├── LBFT.agda │ ├── NetworkMsg.agda │ └── Util │ ├── Crypto.agda │ ├── Dijkstra │ └── All.agda │ └── HashCollisions.agda ├── Optics ├── All.agda ├── Example.agda ├── Functorial.agda └── Reflection.agda ├── Util ├── ByteString.agda ├── Encode.agda ├── FunctionOverride.agda ├── Hash.agda ├── KVMap.agda ├── Lemmas.agda ├── PKCS.agda └── Prelude.agda └── Yasm ├── Base.agda ├── Properties.agda ├── System.agda ├── Types.agda └── Yasm.agda /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | *.agdai 3 | *~ 4 | Everything.agda 5 | /LibraBFT/.projectile 6 | /MAlonzo/* 7 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to this repository 2 | 3 | We welcome your contributions! There are multiple ways to contribute. 4 | 5 | ## Opening issues 6 | 7 | For bugs or enhancement requests, please file a GitHub issue unless it's 8 | security related. When filing a bug remember that the better written the bug is, 9 | the more likely it is to be fixed. If you think you've found a security 10 | vulnerability, do not raise a GitHub issue and follow the instructions in our 11 | [security policy](./SECURITY.md). 12 | 13 | ## Contributing code 14 | 15 | We welcome your code contributions. Before submitting code via a pull request, 16 | you will need to have signed the [Oracle Contributor Agreement][OCA] (OCA) and 17 | your commits need to include the following line using the name and e-mail 18 | address you used to sign the OCA: 19 | 20 | ```text 21 | Signed-off-by: Your Name 22 | ``` 23 | 24 | This can be automatically added to pull requests by committing with `--sign-off` 25 | or `-s`, e.g. 26 | 27 | ```text 28 | git commit --signoff 29 | ``` 30 | 31 | Only pull requests from committers that can be verified as having signed the OCA 32 | can be accepted. 33 | 34 | ## Pull request process 35 | 36 | 1. Ensure there is an issue created to track and discuss the fix or enhancement 37 | you intend to submit. 38 | 1. Fork this repository. 39 | 1. Create a branch in your fork to implement the changes. We recommend using 40 | the issue number as part of your branch name, e.g. `1234-fixes`. 41 | 1. Ensure that any documentation is updated with the changes that are required 42 | by your change. 43 | 1. Ensure that any samples are updated if the base image has been changed. 44 | 1. Submit the pull request. *Do not leave the pull request blank*. Explain exactly 45 | what your changes are meant to do and provide simple steps on how to validate. 46 | your changes. Ensure that you reference the issue you created as well. 47 | 1. We will assign the pull request to 2-3 people for review before it is merged. 48 | 49 | ## Code of conduct 50 | 51 | Follow the [Golden Rule](https://en.wikipedia.org/wiki/Golden_Rule). If you'd 52 | like more specific guidelines, see the [Contributor Covenant Code of Conduct][COC]. 53 | 54 | [OCA]: https://oca.opensource.oracle.com 55 | [COC]: https://www.contributor-covenant.org/version/1/4/code-of-conduct/ 56 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Oracle and/or its affiliates. 2 | 3 | The Universal Permissive License (UPL), Version 1.0 4 | 5 | Subject to the condition set forth below, permission is hereby granted to any 6 | person obtaining a copy of this software, associated documentation and/or data 7 | (collectively the "Software"), free of charge and under any and all copyright 8 | rights in the Software, and any and all patent rights owned or freely 9 | licensable by each licensor hereunder covering either (i) the unmodified 10 | Software as contributed to or provided by such licensor, or (ii) the Larger 11 | Works (as defined below), to deal in both 12 | 13 | (a) the Software, and 14 | (b) any piece of software and/or hardware listed in the lrgrwrks.txt file if 15 | one is included with the Software (each a "Larger Work" to which the Software 16 | is contributed by such licensors), 17 | 18 | without restriction, including without limitation the rights to copy, create 19 | derivative works of, display, perform, and distribute the Software and make, 20 | use, sell, offer for sale, import, export, have made, and have sold the 21 | Software and the Larger Work(s), and to sublicense the foregoing rights on 22 | either these or other terms. 23 | 24 | This license is subject to the following condition: 25 | The above copyright notice and either this complete permission notice or at 26 | a minimum a reference to the UPL must be included in all copies or 27 | substantial portions of the Software. 28 | 29 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 30 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 31 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 32 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 33 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 34 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 35 | SOFTWARE. 36 | -------------------------------------------------------------------------------- /LibraBFT.agda-lib: -------------------------------------------------------------------------------- 1 | name: LibraBFT 2 | depend: standard-library 3 | include: ./src 4 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Reporting security vulnerabilities 2 | 3 | Oracle values the independent security research community and believes that 4 | responsible disclosure of security vulnerabilities helps us ensure the security 5 | and privacy of all our users. 6 | 7 | Please do NOT raise a GitHub Issue to report a security vulnerability. If you 8 | believe you have found a security vulnerability, please submit a report to 9 | [secalert_us@oracle.com][1] preferably with a proof of concept. Please review 10 | some additional information on [how to report security vulnerabilities to Oracle][2]. 11 | We encourage people who contact Oracle Security to use email encryption using 12 | [our encryption key][3]. 13 | 14 | We ask that you do not use other channels or contact the project maintainers 15 | directly. 16 | 17 | Non-vulnerability related security issues including ideas for new or improved 18 | security features are welcome on GitHub Issues. 19 | 20 | ## Security updates, alerts and bulletins 21 | 22 | Security updates will be released on a regular cadence. Many of our projects 23 | will typically release security fixes in conjunction with the 24 | Oracle Critical Patch Update program. Additional 25 | information, including past advisories, is available on our [security alerts][4] 26 | page. 27 | 28 | ## Security-related information 29 | 30 | We will provide security related information such as a threat model, considerations 31 | for secure use, or any known security issues in our documentation. Please note 32 | that labs and sample code are intended to demonstrate a concept and may not be 33 | sufficiently hardened for production use. 34 | 35 | [1]: mailto:secalert_us@oracle.com 36 | [2]: https://www.oracle.com/corporate/security-practices/assurance/vulnerability/reporting.html 37 | [3]: https://www.oracle.com/security-alerts/encryptionkey.html 38 | [4]: https://www.oracle.com/security-alerts/ 39 | -------------------------------------------------------------------------------- /STYLE.md: -------------------------------------------------------------------------------- 1 | # Style Guide 2 | 3 | ## Coding style conventions 4 | We are not aware of any official Agda "style guide" or similar; please let us know if you know of one. Otherwise, please try to be consistent with style used in the repo so far and/or contribute here by helping to establish more detailed guidance. 5 | 6 | We will maintain style-related conventions here; please try to adhere to them where possible before creating a pull request. 7 | 8 | - *Trailing spaces*: ensure that there are none; [this script](./Scripts/remove-trailing-whitespace.sh) is useful for this purpose. 9 | - *Module structure*: ensure that each module follows this structure and order: 10 | - Copyright notice 11 | - Pragmas, if any 12 | - Imports 13 | - In general, list all imports in the earliest place possible. For example, the top of file should include all imports required by the file's modules except those that must be imported within the module due to a dependence on module parameters or a requirement to open public. 14 | - List imports alphabetically where possible. 15 | - Use blank lines to avoid any confusion due to non-alpha order imports. 16 | - When a module must be imported in order to define the module parameters *and* must be imported within the module, if necessary, limit the first import with `using` or using a module qualifier; this helps to avoid conflicts with subset imports within the module. 17 | - Comment with overview of the module 18 | - Module definition 19 | - *Syntax conventions* 20 | - Example `with` abstraction (note alignment and no space between `...` and `|`) 21 | 22 | ``` 23 | Example : ExampleSignature 24 | Example x y 25 | with ExampleValue 26 | ...| ExampleName = ... 27 | ``` 28 | 29 | ## Assumptions, warnings and overrides 30 | Ultimately, we aim for a clean proof with all assumptions well justified and minimal warnings and overrides thereof. While this repo is "work in progress", it is natural that we don't always keep everything perfect in this regard. 31 | 32 | However, each of these issues left unresolved is a threat to the validity of the overall proof, so we want to keep technical debt associated with them to a minimum. Where practical, we will adhere to the following guidelines (and ask contributors to do so as well). 33 | 34 | To help keep track of valid assumptions (as opposed to those made temporarily to support progress in other areas), we aim to annotate any outstanding issues to indicate whether they are temporary (and thus a [`TODO-n`](./TODO.md) can be created for addressing them), are considered valid assumptions that need not be proved, or if there is some technical issue preventing us from addressing them. 35 | 36 | Here we list some relevant types of issues and discuss how they should be annotated: 37 | 38 | - `postulate`s 39 | - For valid assumptions, include comment `valid assumption` on the same line as the `postulate` keyword (enabling easy exclusion from searches for issues that remain to be resolved, as well as easy searching for assumptions on which our proof depends). 40 | - For properties that are `postulate`d simply because nobody has proved them yet, include comment `TODO-n: prove` (where `n` is chosen following [these guidelines](./TODO.md)). 41 | - For any others, include comment `temporary`, along with an explanation of the reason for the `postulate` and a summary of issues relevant to eliminating it. 42 | - Pragmas to override warnings/errors should be commented and explained, similar to "other" `postulate`s above. Examples include: 43 | - `{-# TERMINATING #-}` 44 | - `{-# OPTIONS --allow-unsolved-metas #-}` 45 | - Similarly, warnings (represented by different font faces) should be eliminated where possible, and if any remain, they should be explained and justified. Examples include: 46 | - Unsolved metas 47 | - Catchall clauses 48 | - Unreachable clauses 49 | -------------------------------------------------------------------------------- /Scripts/clean.sh: -------------------------------------------------------------------------------- 1 | # Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | # 3 | # Copyright (c) 2020 Oracle and/or its affiliates. 4 | # Licensed under the Universal Permissive License v 1.0 as shown at https://oss.oracle.com/licenses/upl/ 5 | 6 | # This script deletes all .agdai files, causing all type checking to be repeated when 7 | # run-everything.sh is executed, for example. 8 | 9 | find . -name "*.agdai" -exec rm {} \; 10 | -------------------------------------------------------------------------------- /Scripts/gen-everything.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | # Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 4 | # 5 | # Copyright (c) 2020 Oracle and/or its affiliates. 6 | # Licensed under the Universal Permissive License v 1.0 as shown at https://oss.oracle.com/licenses/upl/ 7 | 8 | # This script generates a module that imports every .agda file 9 | # under src, so we can typecheck all files with one command 10 | # (see run-everything.sh) 11 | echo "module Everything where" > tmp.$$ 12 | for f in $(find src -name "*.agda") 13 | do 14 | echo $f \ 15 | | sed 's/\.agda//' \ 16 | | sed 's/src.//' \ 17 | | sed 's!/!\.!g' \ 18 | | sed 's/^/open import /' >> tmp.$$ 19 | done 20 | 21 | # Well, not quite *everything* 22 | grep -v "open import Everything" tmp.$$ > src/Everything.agda 23 | rm tmp.$$ 24 | 25 | -------------------------------------------------------------------------------- /Scripts/remove-trailing-whitespace.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | find . \( -name "*.sh" -o -name "*.agda" \) -type f -print0 | xargs -0 sed -i '' -E "s/[[:space:]]*$//" 4 | -------------------------------------------------------------------------------- /Scripts/run-everything.sh: -------------------------------------------------------------------------------- 1 | # Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | # 3 | # Copyright (c) 2020 Oracle and/or its affiliates. 4 | # Licensed under the Universal Permissive License v 1.0 as shown at https://oss.oracle.com/licenses/upl/ 5 | 6 | # This script runs agda over the Everything.agda file. If it is given any argument, it first 7 | # generates Everything.agda using the gen-everything.sh script in the same directory. 8 | 9 | if [ $# -ne 0 ] 10 | then 11 | echo "Generating Everything.agda" 12 | dir=`dirname $0` 13 | ${dir}/gen-everything.sh 14 | fi 15 | 16 | if [ ! -f src/Everything.agda ] 17 | then 18 | echo "Everything.agda does not exist. Rerun with any argument to generate it." 19 | exit 1 20 | fi 21 | 22 | agda --no-main src/Everything.agda 23 | -------------------------------------------------------------------------------- /THIRD_PARTY_LICENSES.txt: -------------------------------------------------------------------------------- 1 | agda-stdlib 2 | 3 | Copyright (c) 2007-2020 Nils Anders Danielsson, Ulf Norell, Shin-Cheng 4 | Mu, Bradley Hardy, Samuel Bronson, Dan Doel, Patrik Jansson, 5 | Liang-Ting Chen, Jean-Philippe Bernardy, Andrés Sicard-Ramírez, 6 | Nicolas Pouillard, Darin Morrison, Peter Berry, Daniel Brown, 7 | Simon Foster, Dominique Devriese, Andreas Abel, Alcatel-Lucent, 8 | Eric Mertens, Joachim Breitner, Liyang Hu, Noam Zeilberger, Érdi Gergő, 9 | Stevan Andjelkovic, Helmut Grohne, Guilhem Moulin, Noriyuki Ohkawa, 10 | Evgeny Kotelnikov, James Chapman, Wen Kokke, Matthew Daggitt, Jason Hu, 11 | Sandro Stucki, Milo Turner, Zack Grannan, Lex van der Stoep, 12 | Jacques Carette and some anonymous contributors. 13 | 14 | Permission is hereby granted, free of charge, to any person obtaining a 15 | copy of this software and associated documentation files (the 16 | "Software"), to deal in the Software without restriction, including 17 | without limitation the rights to use, copy, modify, merge, publish, 18 | distribute, sublicense, and/or sell copies of the Software, and to 19 | permit persons to whom the Software is furnished to do so, subject to 20 | the following conditions: 21 | 22 | The above copyright notice and this permission notice shall be included 23 | in all copies or substantial portions of the Software. 24 | 25 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 26 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 27 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 28 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 29 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 30 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 31 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 32 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # Looking for ways to contribute? 2 | 3 | We aim to maintain some pointers here for ways people could contribute. We assume that you are reasonably conversant with Agda, though you don't necessarily need to be super expert to contribute. We recommend [this tutorial](https://plfa.github.io/) as a great place to start or build on your Agda journey. 4 | 5 | Initially, we have sprinkled `TODO-n` comments throughout the repo, coded as follows, based on our assessment of the scope of the task. 6 | 7 | * `TODO-1`: Relatively easy (we think/hope) task that should be addressable locally, without propagating effects to other files. 8 | * `TODO-2`: Somewhat more challenging, may propagate to a few other places, but relatively self-contained. 9 | * `TODO-3`: Even more challenging, may require broader understanding of the overall repo and approach, and/or some more widespread changes. 10 | * `TODO-4`: More substantial tasks at the level of the proof architecture, may require intimate knowledge of the overall approach and/or deeper Agda expertise. 11 | 12 | You could contribute by: 13 | * tackling a `TODO-n` task or an existing issue 14 | * filing a new issue 15 | * suggesting additional `TODO-n` tasks 16 | * improving comments, organization, etc. 17 | 18 | Our [Contribution Guide](./CONTRIBUTING.md) provides details on how to contribute code. 19 | 20 | If you would like guidance on where you might contribute, please consider filing an issue to introduce yourself, and let us know a bit about your background and describe how you envisage contributing. -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | PeerHandlerContracts.html -------------------------------------------------------------------------------- /docs/README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Documentation and papers 2 | 3 | The following documentation and papers related to this repository are available. Links will be provided when they are finalised. 4 | 5 | ** [[file:PeerHandlerContracts.org][Formal verification of the LibraBFT consensus algorithm]] 6 | - Christopher Jenkins and Mark Moir 7 | - Local documentation of some key aspects of the verification effort 8 | 9 | ** Towards Formal Verification of HotStuff-based Byzantine Fault Tolerant Consensus in Agda 10 | - Harold Carr, Christopher Jenkins, Mark Moir, Victor Cacciari Miraldo, and Lisandra Silva 11 | - Proceedings of the 14th NASA Formal Methods Symposium (NFM 2022), Pasadena, California, May 2022 12 | - There is an [[https://arxiv.org/abs/2203.14711][extended version]], with additional material including proof overviews 13 | 14 | ** An approach to translating Haskell programs to Agda and reasoning about them 15 | - Harold Carr, Christopher Jenkins, Mark Moir, Victor Cacciari Miraldo, and Lisandra Silva 16 | - Available [[http://arxiv.org/abs/2205.08718][here]] 17 | 18 | 19 | -------------------------------------------------------------------------------- /src/Dijkstra/AST/Examples/Either/Bind.agda: -------------------------------------------------------------------------------- 1 | module Dijkstra.AST.Examples.Either.Bind where 2 | 3 | open import Dijkstra.AST.Prelude 4 | 5 | module TwoEitherBindsExample where 6 | open import Dijkstra.AST.Either ⊤ 7 | open EitherBase 8 | open import Data.Nat 9 | 10 | module _ (en1 en2 : EitherAST ℕ) where 11 | 12 | prog : EitherAST (List ℕ) 13 | prog = do 14 | n1 ← en1 15 | n2 ← en2 16 | return (n1 ∷ n2 ∷ []) 17 | 18 | ProgPost : Unit → Either ⊤ (List ℕ) → Set 19 | ProgPost _ (left l) = l ≡ tt 20 | ProgPost _ (right r) = length r ≡ 2 21 | 22 | progPostWP : predTrans prog (ProgPost unit) unit 23 | progPostWP = predTransMono prog runPost _ ⊆ₒProgPost unit PT1 24 | where 25 | runPost : Post (List ℕ) 26 | runPost = runEitherAST prog unit ≡_ 27 | 28 | ⊆ₒProgPost : runPost ⊆ₒ ProgPost unit 29 | ⊆ₒProgPost (left _) _ = refl 30 | ⊆ₒProgPost (right r) Right_n1∷n2∷[]≡Right_r with runEitherAST en1 unit 31 | ... | (right n1) with runEitherAST en2 unit 32 | ... | (right n2) rewrite inj₂-injective (sym Right_n1∷n2∷[]≡Right_r) = refl 33 | 34 | PT1 : predTrans prog runPost unit 35 | PT1 = necessary prog _ unit refl 36 | -------------------------------------------------------------------------------- /src/Dijkstra/AST/Examples/Maybe/Bind.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2022, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Dijkstra.AST.Prelude 8 | open import Data.Nat renaming (ℕ to Nat) 9 | 10 | module Dijkstra.AST.Examples.Maybe.Bind where 11 | 12 | module OneMaybeBindExample where 13 | open import Dijkstra.AST.Maybe 14 | module _ (mn1 mn2 : MaybeAST Nat) where 15 | prog : MaybeAST (List Nat) 16 | prog = do 17 | n1 <- mn1 18 | return (n1 ∷ []) 19 | 20 | ProgPost : Maybe (List Nat) -> Set 21 | ProgPost nothing = ⊤ 22 | ProgPost (just l) = length l ≡ 1 23 | 24 | mn1Post : Post Nat 25 | mn1Post nothing = ⊤ 26 | mn1Post (just n) = runMaybeAST mn1 unit ≡ just n 27 | 28 | -- Here is the property we want to prove 29 | progPostWP : predTrans prog ProgPost unit 30 | -- This long-winded proof was helpful in understanding how to make the proof work 31 | -- Agda knows the Goal postcondition because it knows that prog is a bind, and knows the rest of 32 | -- the program. To help us understand what it is that Agda figures out to enable putting _ for 33 | -- the goal argument below, we define Goal below, and we can replace _ by Goal and see that it's 34 | -- right. 35 | progPostWP = predTransMono mn1 mn1Post _ {- Goal -} mn1Post⇒Goal unit PT1 36 | where 37 | 38 | Goal : Post Nat 39 | Goal x = -- The following goal is determined by: 40 | -- bindPT (λ x → predTrans (Monad.return MonadAST (x ∷ []))) unit ProgPost 41 | -- because prog is an AST-bind at the top level 42 | ∀ r → r ≡ x → MaybebindPost (λ x → predTrans (return (x ∷ []))) ProgPost r 43 | 44 | PT1 : _ 45 | PT1 with runAST mn1 unit | inspect (runAST mn1) unit 46 | ... | nothing | [ R ] = necessary mn1 mn1Post unit (subst mn1Post (sym R) tt) 47 | ... | just x | [ R ] = necessary mn1 mn1Post unit (subst mn1Post (sym R) R) 48 | 49 | mn1Post⇒Goal : _ 50 | mn1Post⇒Goal nothing mn1Postnothing .nothing refl = tt 51 | mn1Post⇒Goal (just x₁) mn1Postjust .(just x₁) refl = refl 52 | 53 | -- Here is an alternative proof showing how maybePTLemma makes it easy for the user to provide the 54 | -- needed cases for a proof about a bind 55 | progPostWP2 : predTrans prog ProgPost unit 56 | progPostWP2 = maybePTBindLemma prog refl nothingCase justCase 57 | where 58 | nothingCase : _ 59 | nothingCase _ = tt 60 | justCase : _ 61 | justCase _ _ = refl 62 | 63 | module TwoMaybeBindsExample where 64 | open import Dijkstra.AST.Maybe 65 | 66 | module _ (mn1 mn2 : MaybeAST Nat) where 67 | prog : MaybeAST (List Nat) 68 | prog = do 69 | n1 <- mn1 70 | n2 <- mn2 71 | return (n1 ∷ n2 ∷ []) 72 | 73 | ProgPost : Unit -> Maybe (List Nat) -> Set 74 | ProgPost _ nothing = ⊤ 75 | ProgPost _ (just l) = length l ≡ 2 76 | 77 | progPostWP : predTrans prog (ProgPost unit) unit 78 | progPostWP = 79 | predTransMono 80 | prog (λ o → runMaybeAST prog unit ≡ o) _ ⊆ₒProgPost unit PT1 81 | where 82 | ⊆ₒProgPost : (λ o → runMaybeAST prog unit ≡ o) ⊆ₒ ProgPost unit 83 | ⊆ₒProgPost nothing _ = tt 84 | ⊆ₒProgPost (just l) just_n1∷n2∷[]≡just_l with runMaybeAST mn1 unit 85 | ... | just n1 with runMaybeAST mn2 unit 86 | ... | just n2 rewrite just-injective (sym just_n1∷n2∷[]≡just_l) = refl 87 | 88 | PT1 : predTrans prog _ unit 89 | PT1 = necessary prog (runMaybeAST prog unit ≡_) unit refl 90 | 91 | -- A nicer proof using maybePTBindLemma (twice) 92 | progPostWP2 : predTrans prog (ProgPost unit) unit 93 | progPostWP2 = maybePTBindLemma prog refl nothingCase justCase 94 | where 95 | 96 | nothingCase : _ 97 | nothingCase _ = tt 98 | 99 | justCase : _ 100 | justCase x _ = let f = bindCont prog refl x 101 | in sufficient f 102 | (ProgPost unit) 103 | unit 104 | (maybePTBindLemma f refl (const tt) (λ x2 rm≡j → refl)) 105 | 106 | progPost : ProgPost unit (runMaybeAST prog unit) 107 | progPost = 108 | sufficient prog (ProgPost unit) unit progPostWP 109 | 110 | -------------------------------------------------------------------------------- /src/Dijkstra/AST/Examples/RWS.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2022, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.AST.Examples.RWS where 8 | 9 | import Data.Nat 10 | open import Dijkstra.AST.Prelude 11 | 12 | module Example1 (A : Set) where 13 | 14 | open import Data.Nat renaming (ℕ to Nat) using (_+_ ; suc ; zero) 15 | open import Dijkstra.AST.RWS A A (List A) 16 | 17 | prog : RWSAST (List A) 18 | prog = do 19 | ev <- ask 20 | tell (ev ∷ []) 21 | st <- gets (λ x -> x) 22 | tell (ev ∷ []) 23 | _ <- puts λ s -> (ev ∷ s) 24 | st' <- gets (λ x -> x) 25 | tell (ev ∷ []) 26 | return (ev ∷ st') 27 | 28 | ProgPost : (A × List A) -> (List A × List A × List A) -> Set 29 | ProgPost (_ , si) (a , so , w) = length a ≡ 1 + length so 30 | × length so ≡ 1 + length si 31 | × length w ≡ 3 32 | 33 | progPost : ∀ i -> ProgPost i (runRWSAST prog i) 34 | progPost (e , s) with runRWSAST prog (e , s) 35 | ... | (a , st , wr) 36 | = refl , refl , refl 37 | 38 | -- Proving this WP is straightforward compared to sum types (e.g., Maybe, Either). 39 | -- When proving sum types, it is necessary to break the proof obligations down into cases. 40 | -- With this usage of RWS, there are no cases. Here, an equality (e.g., r₅≡1∷si) 41 | -- established by the RWS bind definition is used. 42 | progPostWP : ∀ i -> predTrans prog (ProgPost i) i 43 | progPostWP (c , si) _ _ _ _ _ _ _ _ _ _ r₅ r₅≡1∷si _ _ 44 | rewrite r₅≡1∷si 45 | = refl , refl , refl 46 | 47 | -- C-c C-n 48 | -- Example1.runProg 49 | -- returns : λ A a → a ∷ a ∷ [] , a ∷ [] , a ∷ a ∷ a ∷ [] 50 | runProg : A -> (List A × List A × List A) 51 | runProg a = runRWSAST prog (a , []) 52 | -------------------------------------------------------------------------------- /src/Dijkstra/AST/Prelude.agda: -------------------------------------------------------------------------------- 1 | module Dijkstra.AST.Prelude where 2 | 3 | open import Agda.Builtin.Unit 4 | public 5 | open import Data.Bool 6 | using (Bool; true; false; not) 7 | public 8 | open import Data.Sum 9 | using (_⊎_ ; inj₁ ; inj₂) 10 | renaming ([_,_] to either) 11 | open import Data.Sum.Properties 12 | using (inj₂-injective) 13 | public 14 | open import Data.Empty 15 | using (⊥ ; ⊥-elim) 16 | public 17 | open import Data.Empty 18 | renaming (⊥ to Void) 19 | public 20 | open import Data.List 21 | using (List ; length ; [] ; _∷_ ; _++_) 22 | public 23 | open import Data.Maybe 24 | using (Maybe ; maybe ; just ; nothing) 25 | public 26 | open import Data.Maybe.Properties 27 | using (just-injective) 28 | renaming (≡-dec to Maybe-≡-dec) 29 | public 30 | open import Data.Product 31 | using (_×_ ; _,_ ; proj₁ ; proj₂) 32 | public 33 | open import Data.Unit.NonEta 34 | using (Unit; unit) 35 | public 36 | open import Function 37 | public 38 | open import Level as Level 39 | renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_) 40 | public 41 | import Level.Literals as Level using (#_) 42 | open import Relation.Binary.PropositionalEquality 43 | public 44 | 45 | -- NOTE: This function is defined to give extra documentation when discharging 46 | -- absurd cases where Agda can tell by pattern matching that `A` is not 47 | -- inhabited. For example: 48 | -- > absurd (just v ≡ nothing) case impossibleProof of λ () 49 | infix 0 absurd_case_of_ 50 | absurd_case_of_ : ∀ {ℓ₁ ℓ₂} (A : Set ℓ₁) {B : Set ℓ₂} → A → (A → ⊥) → B 51 | absurd A case x of f = ⊥-elim (f x) 52 | 53 | Either : ∀ {a b} → Set a → Set b → Set (a ℓ⊔ b) 54 | Either A B = A ⊎ B 55 | pattern left x = inj₁ x 56 | pattern right x = inj₂ x 57 | -------------------------------------------------------------------------------- /src/Dijkstra/AST/Syntax.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2022, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.AST.Syntax where 8 | 9 | open import FunctorApplicativeMonad public 10 | open import Dijkstra.Syntax public 11 | 12 | instance 13 | open import Dijkstra.AST.Core 14 | 15 | MonadAST : ∀ {OP : ASTOps} → Monad (AST OP) 16 | Monad.return MonadAST = ASTreturn 17 | Monad._>>=_ MonadAST = ASTbind 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/Dijkstra/All.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.All where 8 | 9 | open import Dijkstra.Syntax public 10 | open import Dijkstra.RWS public 11 | open import Dijkstra.RWS.Syntax public 12 | open import Dijkstra.EitherD public 13 | open import Dijkstra.EitherD.Syntax public 14 | open import Dijkstra.EitherLike public 15 | 16 | -------------------------------------------------------------------------------- /src/Dijkstra/EitherD/Syntax.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.EitherD.Syntax where 8 | 9 | open import Dijkstra.EitherD 10 | open import Dijkstra.EitherLike 11 | open import Dijkstra.Syntax 12 | open import Haskell.Prelude 13 | 14 | private 15 | variable 16 | E : Set 17 | A B C : Set 18 | 19 | -- From this instance declaration, we get _<$>_, pure, and _<*>_ also. 20 | instance 21 | Monad-EitherD : ∀ {E : Set} → Monad (EitherD E) 22 | Monad.return Monad-EitherD = EitherD-return 23 | Monad._>>=_ Monad-EitherD = EitherD-bind 24 | 25 | -- These instance declarations give us variant conditional operations that we 26 | -- can define to play nice with `EitherD-weakestPre` 27 | 28 | instance 29 | EitherD-MonadIfD : MonadIfD{ℓ₃ = ℓ0} (EitherD E) 30 | MonadIfD.monad EitherD-MonadIfD = Monad-EitherD 31 | MonadIfD.ifD‖ EitherD-MonadIfD = EitherD-if 32 | 33 | EitherD-MonadMaybeD : MonadMaybeD (EitherD E) 34 | MonadMaybeD.monad EitherD-MonadMaybeD = Monad-EitherD 35 | MonadMaybeD.maybeD EitherD-MonadMaybeD = EitherD-maybe 36 | 37 | EitherD-MonadEitherD : MonadEitherD (EitherD E) 38 | MonadEitherD.monad EitherD-MonadEitherD = Monad-EitherD 39 | MonadEitherD.eitherD EitherD-MonadEitherD = EitherD-either 40 | 41 | -- `EitherD` is Either-like 42 | instance 43 | EitherD-EitherLike : EitherLike EitherD 44 | EitherLike.fromEither EitherD-EitherLike (Left a) = EitherD-bail a 45 | EitherLike.fromEither EitherD-EitherLike (Right b) = EitherD-return b 46 | 47 | EitherLike.toEither EitherD-EitherLike = EitherD-run 48 | -------------------------------------------------------------------------------- /src/Dijkstra/EitherLike.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.EitherLike where 8 | 9 | open import Haskell.Prelude 10 | 11 | open import Level 12 | renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_) 13 | public 14 | 15 | module _ {ℓ₀ ℓ₁ ℓ₂ : Level} where 16 | EL-type = Set ℓ₁ → Set ℓ₂ → Set ℓ₀ 17 | EL-level = ℓ₁ ℓ⊔ ℓ₂ ℓ⊔ ℓ₀ 18 | 19 | -- Utility to make passing between `Either` and `EitherD` more convenient 20 | record EitherLike (E : EL-type) : Set (ℓ+1 EL-level) where 21 | field 22 | fromEither : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → Either A B → E A B 23 | toEither : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → E A B → Either A B 24 | open EitherLike ⦃ ... ⦄ public 25 | 26 | EL-func : EL-type → Set (ℓ+1 EL-level) 27 | EL-func EL = ⦃ mel : EitherLike EL ⦄ → Set EL-level 28 | 29 | instance 30 | EitherLike-Either : ∀ {ℓ₁ ℓ₂} → EitherLike{ℓ₁ ℓ⊔ ℓ₂}{ℓ₁}{ℓ₂} Either 31 | EitherLike.fromEither EitherLike-Either = id 32 | EitherLike.toEither EitherLike-Either = id 33 | 34 | -------------------------------------------------------------------------------- /src/Dijkstra/RWS/Syntax.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | -- This module contains definitions allowing RWS programs to be written using 8 | -- Agda's do-notation, as well as convenient short names for operations 9 | -- (including lens operations). 10 | module Dijkstra.RWS.Syntax where 11 | 12 | open import Dijkstra.RWS 13 | open import Dijkstra.Syntax 14 | open import Haskell.Modules.RWS public 15 | open import Haskell.Modules.RWS.Lens public 16 | open import Haskell.Modules.RWS.RustAnyHow public 17 | open import Haskell.Prelude 18 | 19 | open import Level 20 | renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_) 21 | public 22 | 23 | private 24 | variable 25 | Ev Wr St : Set 26 | A B C : Set 27 | 28 | -- These instance declarations give us variant conditional operations that we 29 | -- can define to play nice with `RWS-weakestPre` 30 | 31 | instance 32 | RWS-MonadIfD : MonadIfD{ℓ₃ = ℓ0} (RWS Ev Wr St) 33 | MonadIfD.monad RWS-MonadIfD = RWS-Monad 34 | MonadIfD.ifD‖ RWS-MonadIfD = RWS-if 35 | 36 | RWS-MonadMaybeD : MonadMaybeD (RWS Ev Wr St) 37 | MonadMaybeD.monad RWS-MonadMaybeD = RWS-Monad 38 | MonadMaybeD.maybeD RWS-MonadMaybeD = RWS-maybe 39 | 40 | RWS-MonadEitherD : MonadEitherD (RWS Ev Wr St) 41 | MonadEitherD.monad RWS-MonadEitherD = RWS-Monad 42 | MonadEitherD.eitherD RWS-MonadEitherD = RWS-either 43 | 44 | maybeM : RWS Ev Wr St B → (A → RWS Ev Wr St B) → RWS Ev Wr St (Maybe A) → RWS Ev Wr St B 45 | maybeM mb f mma = do 46 | x ← mma 47 | caseMD x of λ where 48 | nothing → mb 49 | (just j) → f j 50 | 51 | maybeMP-RWS : B → (A → RWS Ev Wr St B) 52 | → RWS Ev Wr St (Maybe A) 53 | → RWS Ev Wr St B 54 | maybeMP-RWS b f ma = do 55 | x ← ma 56 | caseMD x of λ where 57 | nothing → pure b 58 | (just j) → f j 59 | 60 | RWS-weakestPre-∙^∙Post : (ev : Ev) (e : C → C) → RWS-Post Wr St (Either C A) → RWS-Post Wr St (Either C A) 61 | RWS-weakestPre-∙^∙Post ev e Post = 62 | RWS-weakestPre-bindPost ev (either (bail ∘ e) ok) Post 63 | 64 | -------------------------------------------------------------------------------- /src/Dijkstra/Syntax.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Dijkstra.Syntax where 8 | 9 | open import Dijkstra.EitherD 10 | open import Dijkstra.EitherLike 11 | open import Dijkstra.RWS 12 | open import Haskell.Prelude 13 | open import Optics.All 14 | 15 | {- 16 | Within a "Dijkstra-fied" monad `M`, `if` and `ifD` are semantically interchangeable. 17 | 18 | The difference is in how proof obligations are generated 19 | - with the *D variants generating new weakestPre obligations for each case. 20 | 21 | In some cases, this is helpful for structuring proofs, while in other cases it is 22 | unnecessary and introduces more structure to the proof without adding any benefit. 23 | 24 | A rule of thumb is that, if the "scrutinee" (whatever we are doing case analysis on, 25 | i.e., the first argument) is the value provided via >>= (bind) by a previous code block, 26 | then we already have a weakestPre proof obligation, so introducing additional ones via the 27 | *D variants only creates more work and provides no additional benefit. 28 | -} 29 | 30 | record MonadIfD {ℓ₁ ℓ₂ ℓ₃ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁ ℓ⊔ ℓ+1 ℓ₃) where 31 | infix 1 ifD‖_ 32 | field 33 | ⦃ monad ⦄ : Monad M 34 | ifD‖_ : ∀ {A : Set ℓ₁} → Guards{ℓ₂}{ℓ₃} (M A) → M A 35 | 36 | open MonadIfD ⦃ ... ⦄ public 37 | 38 | module _ {ℓ₁ ℓ₂ ℓ₃} {M : Set ℓ₁ → Set ℓ₂} where 39 | 40 | private 41 | variable 42 | A : Set ℓ₁ 43 | B : Set ℓ₃ 44 | 45 | infix 0 ifD_then_else_ 46 | ifD_then_else_ : ⦃ _ : MonadIfD{ℓ₃ = ℓ₃} M ⦄ ⦃ _ : ToBool B ⦄ → B → (c₁ c₂ : M A) → M A 47 | ifD b then c₁ else c₂ = 48 | ifD‖ b ≔ c₁ 49 | ‖ otherwise≔ c₂ 50 | 51 | whenD : ∀ {ℓ₂ ℓ₃} {M : Set → Set ℓ₂} {B : Set ℓ₃} ⦃ _ : MonadIfD{ℓ0}{ℓ₂}{ℓ₃} M ⦄ ⦃ _ : ToBool B ⦄ → B → M Unit → M Unit 52 | whenD b f = ifD b then f else pure unit 53 | 54 | module _ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} where 55 | private 56 | variable A B : Set ℓ₁ 57 | 58 | ifMD : ⦃ mi : MonadIfD{ℓ₃ = ℓ₁} M ⦄ ⦃ _ : ToBool B ⦄ → M B → (c₁ c₂ : M A) → M A 59 | ifMD{B = B} ⦃ mi ⦄ m c₁ c₂ = do 60 | x ← m 61 | ifD x then c₁ else c₂ 62 | 63 | record MonadMaybeD {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 64 | field 65 | ⦃ monad ⦄ : Monad M 66 | -- This is the standard order for maybe arguments in Haskell; 67 | -- see maybeSD below for the argument order we prefer in some 68 | -- contexts 69 | maybeD : ∀ {A B : Set ℓ₁} → M B → (A → M B) → Maybe A → M B 70 | 71 | open MonadMaybeD ⦃ ... ⦄ public 72 | 73 | -- A maybeD variant with different argument order, which is favoured in 74 | -- some use cases 75 | maybeSD : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ mmd : MonadMaybeD M ⦄ 76 | → ∀ {A B : Set ℓ₁} → Maybe A → M B → (A → M B) → M B 77 | maybeSD ⦃ mmd ⦄ x y z = maybeD y z x 78 | 79 | infix 0 caseMD_of_ 80 | caseMD_of_ : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : MonadMaybeD M ⦄ {A B : Set ℓ₁} → Maybe A → (Maybe A → M B) → M B 81 | caseMD m of f = maybeD (f nothing) (f ∘ just) m 82 | 83 | record MonadEitherD {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 84 | field 85 | ⦃ monad ⦄ : Monad M 86 | eitherD : ∀ {E A B : Set ℓ₁} → (E → M B) → (A → M B) → Either E A → M B 87 | 88 | open MonadEitherD ⦃ ... ⦄ public hiding (eitherD) 89 | 90 | eitherD 91 | : ∀ {ℓ₁ ℓ₂ ℓ₃} {M : Set ℓ₁ → Set ℓ₂} ⦃ med : MonadEitherD M ⦄ → 92 | ∀ {EL : Set ℓ₁ → Set ℓ₁ → Set ℓ₃} ⦃ _ : EitherLike EL ⦄ → 93 | ∀ {E A B : Set ℓ₁} → (E → M B) → (A → M B) → EL E A → M B 94 | eitherD ⦃ med = med ⦄ f₁ f₂ e = 95 | MonadEitherD.eitherD med f₁ f₂ (toEither e) 96 | 97 | infix 0 case⊎D_of_ 98 | case⊎D_of_ 99 | : ∀ {ℓ₁ ℓ₂ ℓ₃} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : MonadEitherD M ⦄ → 100 | ∀ {EL : Set ℓ₁ → Set ℓ₁ → Set ℓ₃} ⦃ _ : EitherLike EL ⦄ → 101 | ∀ {E A B : Set ℓ₁} → EL E A → (EL E A → M B) → M B 102 | case⊎D e of f = eitherD (f ∘ fromEither ∘ Left) (f ∘ fromEither ∘ Right) e 103 | -------------------------------------------------------------------------------- /src/FunctorApplicativeMonad.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, 2022, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | -- This module contains simple support fort Functor, Applicative and Monad. We should probably 8 | -- elminate this and use the versions in the Agda Standard Library. 9 | 10 | module FunctorApplicativeMonad where 11 | 12 | open import Data.List 13 | open import Data.Maybe renaming (_>>=_ to _Maybe->>=_) 14 | import Data.Sum as DS renaming ([_,_] to either) 15 | open import Function 16 | open import Level renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_) 17 | open import Relation.Binary.PropositionalEquality 18 | 19 | record Functor {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 20 | infixl 4 _<$>_ 21 | field 22 | _<$>_ : ∀ {A B : Set ℓ₁} → (A → B) → F A → F B 23 | fmap = _<$>_ 24 | open Functor ⦃ ... ⦄ public 25 | 26 | record Applicative {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 27 | infixl 4 _<*>_ 28 | field 29 | pure : ∀ {A : Set ℓ₁} → A → F A 30 | _<*>_ : ∀ {A B : Set ℓ₁} → F (A → B) → F A → F B 31 | open Applicative ⦃ ... ⦄ public 32 | instance 33 | ApplicativeFunctor : ∀ {ℓ₁ ℓ₂} {F : Set ℓ₁ → Set ℓ₂} ⦃ _ : Applicative F ⦄ → Functor F 34 | Functor._<$>_ ApplicativeFunctor f xs = pure f <*> xs 35 | 36 | record Monad {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 37 | infixl 1 _>>=_ _>>_ 38 | field 39 | return : ∀ {A : Set ℓ₁} → A → M A 40 | _>>=_ : ∀ {A B : Set ℓ₁} → M A → (A → M B) → M B 41 | 42 | _>>_ : ∀ {A B : Set ℓ₁} → M A → M B → M B 43 | m₁ >> m₂ = m₁ >>= λ _ → m₂ 44 | open Monad ⦃ ... ⦄ public 45 | 46 | record MonadLaws 47 | {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) ⦃ m : Monad M ⦄ 48 | (_~_ : {A : Set ℓ₁} → M A → M A → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where 49 | field 50 | idLeft : ∀ {A B : Set ℓ₁} → (x : A) (f : A → M B) 51 | → (return x >>= f) ~ f x 52 | idRight : ∀ {A : Set ℓ₁} → (m : M A) 53 | → (m >>= return) ~ m 54 | assoc : ∀ {A B C : Set ℓ₁} → (m : M A) (f : A → M B) (g : B → M C) 55 | → ((m >>= f) >>= g) ~ (m >>= (λ x → f x >>= g)) 56 | 57 | instance 58 | MonadApplicative : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄ → Applicative M 59 | Applicative.pure MonadApplicative = return 60 | Applicative._<*>_ MonadApplicative fs xs = do 61 | f ← fs 62 | x ← xs 63 | return (f x) 64 | 65 | instance 66 | Monad-Either : ∀ {ℓ}{C : Set ℓ} → Monad{ℓ}{ℓ} (C DS.⊎_) 67 | Monad.return (Monad-Either{ℓ}{C}) = DS.inj₂ 68 | Monad._>>=_ (Monad-Either{ℓ}{C}) = DS.either (const ∘ DS.inj₁) _|>_ 69 | 70 | Monad-Maybe : ∀ {ℓ} → Monad {ℓ} {ℓ} Maybe 71 | Monad.return (Monad-Maybe{ℓ}) = just 72 | Monad._>>=_ (Monad-Maybe{ℓ}) = _Maybe->>=_ 73 | 74 | Monad-List : ∀ {ℓ} → Monad {ℓ}{ℓ} List 75 | Monad.return Monad-List x = x ∷ [] 76 | Monad._>>=_ Monad-List x f = concat (Data.List.map f x) 77 | 78 | -------------------------------------------------------------------------------- /src/Haskell/Modules/Either.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Haskell.Modules.Either where 8 | 9 | open import Data.Bool using (Bool; true; false; not) 10 | import Data.Sum as DS renaming ([_,_] to either) 11 | open import Function using (_∘_) 12 | open import Level renaming (_⊔_ to _ℓ⊔_) 13 | 14 | Either : ∀ {a b} → Set a → Set b → Set (a ℓ⊔ b) 15 | Either A B = A DS.⊎ B 16 | pattern Left x = DS.inj₁ x 17 | pattern Right x = DS.inj₂ x 18 | 19 | either = DS.either 20 | 21 | isLeft : ∀ {a b} {A : Set a} {B : Set b} → Either A B → Bool 22 | isLeft (Left _) = true 23 | isLeft (Right _) = false 24 | 25 | isRight : ∀ {a b} {A : Set a} {B : Set b} → Either A B → Bool 26 | isRight = not ∘ isLeft 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/Haskell/Modules/Eq.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Haskell.Modules.Eq where 8 | 9 | open import Haskell.Modules.ToBool 10 | ------------------------------------------------------------------------------ 11 | open import Data.Bool hiding (_≟_; not) 12 | open import Data.List as DL 13 | open import Data.Maybe using (Maybe; just; nothing) 14 | import Data.Nat as DN 15 | open import Function using (_$_; _∘_) 16 | import Relation.Binary.PropositionalEquality as PE using (_≡_; refl) 17 | import Relation.Nullary as RN 18 | 19 | record Eq {a} (A : Set a) : Set a where 20 | infix 4 _≟_ _==_ _/=_ 21 | field 22 | _≟_ : (a b : A) → RN.Dec (a PE.≡ b) 23 | 24 | _==_ : A → A → Bool 25 | a == b = toBool $ a ≟ b 26 | 27 | _/=_ : A → A → Bool 28 | a /= b = not (a == b) 29 | open Eq ⦃ ... ⦄ public 30 | 31 | import Data.List.Relation.Unary.Any as Any using (any) 32 | 33 | elem : ∀ {ℓ} {A : Set ℓ} ⦃ _ : Eq A ⦄ → A → DL.List A → Bool 34 | elem x = toBool ∘ Any.any (x ≟_) 35 | 36 | instance 37 | Eq-Nat : Eq DN.ℕ 38 | Eq._≟_ Eq-Nat = DN._≟_ 39 | 40 | Eq-Maybe : ∀ {a} {A : Set a} ⦃ _ : Eq A ⦄ → Eq (Maybe A) 41 | Eq._≟_ Eq-Maybe nothing nothing = RN.yes PE.refl 42 | Eq._≟_ Eq-Maybe (just _) nothing = RN.no λ () 43 | Eq._≟_ Eq-Maybe nothing (just _) = RN.no λ () 44 | Eq._≟_ Eq-Maybe (just a) (just b) 45 | with a ≟ b 46 | ... | RN.no proof = RN.no λ where PE.refl → proof PE.refl 47 | ... | RN.yes PE.refl = RN.yes PE.refl 48 | 49 | -------------------------------------------------------------------------------- /src/Haskell/Modules/RWS/Lens.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Haskell.Modules.RWS.Lens where 8 | 9 | open import Haskell.Modules.RWS 10 | open import Haskell.Prelude 11 | open import Optics.All 12 | 13 | private 14 | variable 15 | Ev Wr St : Set 16 | A B C : Set 17 | 18 | -- Lens functionality 19 | -- 20 | -- If we make RWS work for different level State types, we will break use and 21 | -- modify because Lens does not support different levels, we define use and 22 | -- modify' here for RoundManager. We are ok as long as we can keep 23 | -- RoundManager in Set. If we ever need to make RoundManager at some higher 24 | -- Level, we will have to consider making Lens level-agnostic. Preliminary 25 | -- exploration by @cwjnkins showed this to be somewhat painful in particular 26 | -- around composition, so we are not pursuing it for now. 27 | use : Lens St A → RWS Ev Wr St A 28 | use f = gets (_^∙ f) 29 | 30 | modifyL : Lens St A → (A → A) → RWS Ev Wr St Unit 31 | modifyL l f = modify (over l f) 32 | syntax modifyL l f = l %= f 33 | 34 | setL : Lens St A → A → RWS Ev Wr St Unit 35 | setL l x = l %= const x 36 | syntax setL l x = l ∙= x 37 | 38 | setL? : Lens St (Maybe A) → A → RWS Ev Wr St Unit 39 | setL? l x = l ∙= just x 40 | syntax setL? l x = l ?= x 41 | -------------------------------------------------------------------------------- /src/Haskell/Modules/RWS/RustAnyHow.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Haskell.Modules.RWS.RustAnyHow where 8 | 9 | open import Haskell.Modules.RWS 10 | open import Haskell.Prelude 11 | 12 | private 13 | variable 14 | Ev Wr St : Set 15 | A B C : Set 16 | 17 | ok : A → RWS Ev Wr St (Either B A) 18 | ok = pure ∘ Right 19 | 20 | bail : B → RWS Ev Wr St (Either B A) 21 | bail = pure ∘ Left 22 | 23 | infixl 4 _∙?∙_ 24 | _∙?∙_ : RWS Ev Wr St (Either C A) → (A → RWS Ev Wr St (Either C B)) → RWS Ev Wr St (Either C B) 25 | _∙?∙_ = RWS-ebind 26 | 27 | infixl 4 _∙^∙_ 28 | _∙^∙_ : RWS Ev Wr St (Either B A) → (B → B) → RWS Ev Wr St (Either B A) 29 | m ∙^∙ f = do 30 | x ← m 31 | either (bail ∘ f) ok x 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/Haskell/Modules/ToBool.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module Haskell.Modules.ToBool where 8 | 9 | open import Data.Bool hiding (not) 10 | import Function 11 | import Relation.Nullary as RN 12 | import Relation.Nullary.Decidable.Core as RNDC 13 | 14 | record ToBool {a}(A : Set a) : Set a where 15 | field 16 | toBool : A → Bool 17 | open ToBool {{ ... }} public 18 | 19 | not : ∀ {b} {B : Set b} ⦃ _ : ToBool B ⦄ → B → Bool 20 | not b = Data.Bool.not (toBool b) 21 | 22 | instance 23 | ToBool-Bool : ToBool Bool 24 | ToBool-Bool = record { toBool = Function.id } 25 | 26 | ToBool-Dec : ∀{a}{A : Set a} → ToBool (RN.Dec A) 27 | ToBool-Dec = record { toBool = RNDC.⌊_⌋ } 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /src/LibraBFT/Abstract/Abstract.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Abstract.Types.EpochConfig 8 | open import Util.Prelude 9 | open WithAbsVote 10 | 11 | -- This module provides a convenient way for modules in other namespaces to import 12 | -- everything from Abstract. 13 | 14 | module LibraBFT.Abstract.Abstract 15 | (UID : Set) 16 | (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁)) 17 | (NodeId : Set) 18 | (𝓔 : EpochConfig UID NodeId) 19 | (𝓥 : VoteEvidence UID NodeId 𝓔) 20 | where 21 | open import LibraBFT.Abstract.Types UID NodeId 𝓔 public 22 | open import LibraBFT.Abstract.RecordChain UID _≟UID_ NodeId 𝓔 𝓥 public 23 | open import LibraBFT.Abstract.RecordChain.Assumptions UID _≟UID_ NodeId 𝓔 𝓥 public 24 | open import LibraBFT.Abstract.Records UID _≟UID_ NodeId 𝓔 𝓥 public 25 | open import LibraBFT.Abstract.Records.Extends UID _≟UID_ NodeId 𝓔 𝓥 public 26 | open import LibraBFT.Abstract.Properties UID _≟UID_ NodeId 𝓔 𝓥 public 27 | open import LibraBFT.Abstract.System UID _≟UID_ NodeId 𝓔 𝓥 public 28 | -------------------------------------------------------------------------------- /src/LibraBFT/Abstract/Records/Extends.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Abstract.Types 8 | open import LibraBFT.Abstract.Types.EpochConfig 9 | open import Util.Lemmas 10 | open import Util.Prelude 11 | open WithAbsVote 12 | 13 | -- This module defines the notion of one Record r "extending" another 14 | -- Record r' (denoted r' ← r), ensuring rules about rounds and that r 15 | -- correctly identifies r' 16 | 17 | module LibraBFT.Abstract.Records.Extends 18 | (UID : Set) 19 | (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁)) 20 | (NodeId : Set) 21 | (𝓔 : EpochConfig UID NodeId) 22 | (𝓥 : VoteEvidence UID NodeId 𝓔) 23 | where 24 | 25 | open import LibraBFT.Abstract.Records UID _≟UID_ NodeId 𝓔 𝓥 26 | 27 | -- Most of the conditions in section 4.2 of the paper (see 28 | -- LibraBFT.Abstract.RecordChain.Properties) would be checked 29 | -- by the implementation to validate data received. 30 | -- 31 | -- In the Abstract model, however, we are only concerned with 32 | -- proving the properties; only round numbers and identifiers 33 | -- for previous records are actually critical to thm S5! 34 | data _←_ : Record → Record → Set where 35 | I←B : {b : Block} 36 | → 0 < getRound b 37 | → bPrevQC b ≡ nothing 38 | → I ← B b 39 | Q←B : {q : QC} {b : Block} 40 | → getRound q < getRound b 41 | → just (qCertBlockId q) ≡ bPrevQC b 42 | → Q q ← B b 43 | B←Q : {b : Block} {q : QC} 44 | → getRound q ≡ getRound b 45 | → bId b ≡ qCertBlockId q 46 | → B b ← Q q 47 | 48 | -- Equivalent records extend equivalent records (modulo injectivity 49 | -- failure of bId). 50 | ←-≈Rec : ∀{r₀ r₁ s₀ s₁} → (ext₀ : s₀ ← r₀) → (ext₁ : s₁ ← r₁) 51 | → r₀ ≈Rec r₁ 52 | → NonInjective-≡-preds ((s₀ ≡_) ∘ B) ((s₁ ≡_) ∘ B) bId ⊎ (s₀ ≈Rec s₁) 53 | ←-≈Rec (I←B x x₁) (I←B x₂ x₃) hyp = inj₂ eq-I 54 | ←-≈Rec (I←B x x₁) (Q←B x₂ x₃) (eq-B refl) 55 | = ⊥-elim (maybe-⊥ (sym x₃) x₁) 56 | ←-≈Rec (Q←B x x₁) (I←B x₂ x₃) (eq-B refl) 57 | = ⊥-elim (maybe-⊥ (sym x₁) x₃) 58 | ←-≈Rec (Q←B {q₀} x refl) (Q←B {q₁} x₂ refl) (eq-B refl) 59 | = inj₂ (eq-Q refl) -- Here is where we wouldn't be able to 60 | -- complete the proof if we required round equality 61 | -- in eq-Q 62 | ←-≈Rec (B←Q {b₀} x refl) (B←Q {b₁} w refl) (eq-Q refl) 63 | with b₀ ≟Block b₁ 64 | ...| no hb = inj₁ (((b₀ , b₁) , (λ x → hb x) , refl) , refl , refl) 65 | ...| yes prf = inj₂ (eq-B prf) 66 | 67 | ←-irrelevant : Irrelevant _←_ 68 | ←-irrelevant (I←B r₁ h₁) (I←B r₂ h₂) 69 | = cong₂ I←B (≤-irrelevant r₁ r₂) (≡-irrelevant h₁ h₂) 70 | ←-irrelevant (Q←B r₁ h₁) (Q←B r₂ h₂) 71 | = cong₂ Q←B (≤-irrelevant r₁ r₂) (≡-irrelevant h₁ h₂) 72 | ←-irrelevant (B←Q r₁ h₁) (B←Q r₂ h₂) 73 | = cong₂ B←Q (≡-irrelevant r₁ r₂) (≡-irrelevant h₁ h₂) 74 | 75 | ←-round-≤ : ∀{r₀ r₁} → r₀ ← r₁ → round r₀ ≤ round r₁ 76 | ←-round-≤ (I←B r h) = z≤n 77 | ←-round-≤ (Q←B r h) = <⇒≤ r 78 | ←-round-≤ (B←Q refl h) = ≤-refl 79 | 80 | ←←-round-< : ∀{r r₀ r₁} → r ← r₀ → r₀ ← r₁ 81 | → round r < round r₁ 82 | ←←-round-< (I←B r h) (B←Q refl _) = r 83 | ←←-round-< (Q←B r h) rr = ≤-trans r (←-round-≤ rr) 84 | ←←-round-< (B←Q refl h) (Q←B prf _) = prf 85 | 86 | -- LemmaS1, clause 2: injectivity of _←_ 87 | lemmaS1-2 : ∀{r₀ r₁ r₂ r₂'} 88 | → r₂ ≈Rec r₂' 89 | → r₀ ← r₂ → r₁ ← r₂' 90 | → uid r₀ ≡ uid r₁ 91 | lemmaS1-2 {i₀} {i₁} {b} hyp (I←B _ i₀←b) (I←B _ i₁←b) = refl 92 | lemmaS1-2 {q} {i} {b} (eq-B refl) (Q←B _ ()) (I←B _ refl) 93 | lemmaS1-2 {i} {q} {b} (eq-B refl) (I←B _ refl) (Q←B _ ()) 94 | lemmaS1-2 {q₀} {q₁} {b} (eq-B refl) (Q←B _ refl) (Q←B _ refl) = refl 95 | lemmaS1-2 {b₀} {b₁} {q} (eq-Q refl) (B←Q _ refl) (B←Q _ refl) = refl 96 | 97 | -- A better name for lemmaS1-2 98 | ←-inj : ∀{r₀ r₁ r₂} 99 | → r₀ ← r₂ → r₁ ← r₂ 100 | → uid r₀ ≡ uid r₁ 101 | ←-inj = lemmaS1-2 ≈Rec-refl 102 | -------------------------------------------------------------------------------- /src/LibraBFT/Abstract/System.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Abstract.Types.EpochConfig 8 | open import Util.Prelude 9 | open WithAbsVote 10 | 11 | -- This module defines and abstract view if a system, encompassing only a predicate for Records, 12 | -- another for Votes and a proof that, if a Vote is included in a QC in the system, then and 13 | -- equivalent Vote is also in the system. It further defines a notion "Complete", which states that 14 | -- if an honest vote is included in a QC in the system, then there is a RecordChain up to the block 15 | -- that the QC extends, such that all Records in the RecordChain are also in the system. The latter 16 | -- property is used to extend correctness conditions on RecordChains to correctness conditions that 17 | -- require only a short suffix of a RecordChain. 18 | 19 | module LibraBFT.Abstract.System 20 | (UID : Set) 21 | (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁)) 22 | (NodeId : Set) 23 | (𝓔 : EpochConfig UID NodeId) 24 | (𝓥 : VoteEvidence UID NodeId 𝓔) 25 | where 26 | 27 | open import LibraBFT.Abstract.Types UID NodeId 𝓔 28 | open import LibraBFT.Abstract.Records UID _≟UID_ NodeId 𝓔 𝓥 29 | open import LibraBFT.Abstract.Records.Extends UID _≟UID_ NodeId 𝓔 𝓥 30 | open import LibraBFT.Abstract.RecordChain UID _≟UID_ NodeId 𝓔 𝓥 31 | 32 | module All-InSys-props {ℓ}(InSys : Record → Set ℓ) where 33 | 34 | All-InSys : ∀ {o r} → RecordChainFrom o r → Set ℓ 35 | All-InSys rc = {r' : Record} → r' ∈RC-simple rc → InSys r' 36 | 37 | All-InSys⇒last-InSys : ∀ {r} → {rc : RecordChain r} → All-InSys rc → InSys r 38 | All-InSys⇒last-InSys {rc = empty} a∈s = a∈s here 39 | All-InSys⇒last-InSys {r = r'} {step {r' = .r'} rc ext} a∈s = a∈s here 40 | 41 | All-InSys-unstep : ∀ {o r r' rc ext } → All-InSys (step {o} {r} {r'} rc ext) → All-InSys rc 42 | All-InSys-unstep {ext = ext} a∈s r'∈RC = a∈s (there ext r'∈RC) 43 | 44 | All-InSys-step : ∀ {r r' }{rc : RecordChain r} 45 | → All-InSys rc → (ext : r ← r') → InSys r' 46 | → All-InSys (step rc ext) 47 | All-InSys-step hyp ext r here = r 48 | All-InSys-step hyp ext r (there .ext r∈rc) = hyp r∈rc 49 | 50 | 51 | -- We say an InSys predicate has NoCollisions if there are no two different Blocks that satisfy 52 | -- InSys and have different ids. 53 | NoCollisions : ∀{ℓ} → (Record → Set ℓ) → Set ℓ 54 | NoCollisions ∈sys = ∀ {b₀ b₁} → ∈sys (B b₀) → ∈sys (B b₁) → bId b₀ ≡ bId b₁ → b₀ ≡ b₁ 55 | 56 | -- We say an InSys predicate is /Complete/ when we can construct a record chain 57 | -- from any vote by an honest participant. This essentially says that whenever 58 | -- an honest participant casts a vote, they have checked that the voted-for 59 | -- block is in a RecordChain whose records are all in the system. This notion 60 | -- is used to extend correctness conditions on RecordChains to correctness conditions that 61 | -- require only a short suffix of a RecordChain. 62 | Complete : ∀{ℓ} → (Record → Set ℓ) → Set ℓ 63 | Complete ∈sys = ∀{α q} 64 | → Meta-Honest-Member α 65 | → α ∈QC q 66 | → ∈sys (Q q) 67 | → ∃[ b ] ( Σ (RecordChain (B b)) All-InSys 68 | × B b ← Q q) 69 | where open All-InSys-props ∈sys 70 | -------------------------------------------------------------------------------- /src/LibraBFT/Abstract/Types.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Abstract.Types.EpochConfig 8 | open import LibraBFT.Base.Types 9 | -- TODO-2: The following import should be eliminated and replaced 10 | -- with the necessary module parameters (PK and MetaHonestPK) 11 | open import Util.Lemmas 12 | open import Util.PKCS 13 | open import Util.Prelude 14 | 15 | -- This module brings in the base types used through libra 16 | -- and those necessary for the abstract model. 17 | module LibraBFT.Abstract.Types 18 | (UID : Set) 19 | (NodeId : Set) 20 | (𝓔 : EpochConfig UID NodeId) 21 | where 22 | open EpochConfig 𝓔 23 | 24 | -- A member of an epoch is considered "honest" iff its public key is honest. 25 | Meta-Honest-Member : EpochConfig.Member 𝓔 → Set 26 | Meta-Honest-Member α = Meta-Honest-PK (getPubKey α) 27 | 28 | -- Naturally, if two witnesses that two authors belong 29 | -- in the epoch are the same, then the authors are also the same. 30 | -- 31 | -- This proof is very Galois-like, because of the way we structured 32 | -- our partial isos. It's actually pretty nice! :) 33 | member≡⇒author≡ : ∀{α β} 34 | → (authorα : Is-just (isMember? α)) 35 | → (authorβ : Is-just (isMember? β)) 36 | → to-witness authorα ≡ to-witness authorβ 37 | → α ≡ β 38 | member≡⇒author≡ {α} {β} a b prf 39 | with isMember? α | inspect isMember? α 40 | ...| nothing | [ _ ] = ⊥-elim (maybe-any-⊥ a) 41 | member≡⇒author≡ {α} {β} (just _) b prf 42 | | just ra | [ RA ] 43 | with isMember? β | inspect isMember? β 44 | ...| nothing | [ _ ] = ⊥-elim (maybe-any-⊥ b) 45 | member≡⇒author≡ {α} {β} (just _) (just _) prf 46 | | just ra | [ RA ] 47 | | just rb | [ RB ] 48 | = trans (sym (author-nodeid-id RA)) 49 | (trans (cong toNodeId prf) 50 | (author-nodeid-id RB)) 51 | -------------------------------------------------------------------------------- /src/LibraBFT/Abstract/Types/EpochConfig.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | -- TODO-2: The following import should be eliminated and replaced 8 | -- with the necessary module parameters (PK and MetaHonestPK) 9 | open import Util.Lemmas 10 | open import Util.PKCS 11 | open import Util.Prelude 12 | 13 | -- This module brings in the base types used through libra 14 | -- and those necessary for the abstract model. 15 | module LibraBFT.Abstract.Types.EpochConfig 16 | (UID : Set) 17 | (NodeId : Set) 18 | where 19 | 20 | open import LibraBFT.Base.Types 21 | 22 | ℓ-EC : Level 23 | ℓ-EC = ℓ+1 0ℓ 24 | 25 | -- An epoch-configuration carries only simple data about the epoch; the complicated 26 | -- parts will be provided by the System, defined below. 27 | -- 28 | -- The reason for the separation is that we should be able to provide 29 | -- an EpochConfig from a single peer state. 30 | record EpochConfig : Set ℓ-EC where 31 | constructor EpochConfig∙new 32 | field 33 | genesisUID : UID 34 | epoch : Epoch 35 | authorsN : ℕ 36 | 37 | -- The set of members of this epoch. 38 | Member : Set 39 | Member = Fin authorsN 40 | 41 | -- There is a partial isomorphism between NodeIds and the 42 | -- authors participating in this epoch. 43 | field 44 | toNodeId : Member → NodeId 45 | isMember? : NodeId → Maybe Member 46 | 47 | nodeid-author-id : ∀{α} → isMember? (toNodeId α) ≡ just α 48 | author-nodeid-id : ∀{nid α} → isMember? nid ≡ just α 49 | → toNodeId α ≡ nid 50 | 51 | getPubKey : Member → PK 52 | 53 | PK-inj : ∀ {m1 m2} → getPubKey m1 ≡ getPubKey m2 → m1 ≡ m2 54 | 55 | IsQuorum : List Member → Set 56 | 57 | bft-property : ∀ {xs ys} 58 | → IsQuorum xs → IsQuorum ys 59 | → ∃[ α ] (α ∈ xs × α ∈ ys × Meta-Honest-PK (getPubKey α)) 60 | 61 | open EpochConfig 62 | 63 | PK-inj-same-ECs : ∀ {𝓔₁ 𝓔₂ : EpochConfig}{mbr₁ mbr₂} 64 | → 𝓔₁ ≡ 𝓔₂ 65 | → getPubKey 𝓔₁ mbr₁ ≡ getPubKey 𝓔₂ mbr₂ 66 | → toNodeId 𝓔₁ mbr₁ ≡ toNodeId 𝓔₂ mbr₂ 67 | PK-inj-same-ECs {𝓔₁} refl pks≡ = cong (toNodeId 𝓔₁) (PK-inj 𝓔₁ pks≡) 68 | 69 | EC-member-cast : ∀ {𝓔₁ 𝓔₂ : EpochConfig} 70 | → 𝓔₁ ≡ 𝓔₂ 71 | → Member 𝓔₁ 72 | → Member 𝓔₂ 73 | EC-member-cast refl m = m 74 | 75 | module _ (ec : EpochConfig) where 76 | NodeId-PK-OK : PK → NodeId → Set 77 | NodeId-PK-OK pk pid = ∃[ m ] (toNodeId ec m ≡ pid × getPubKey ec m ≡ pk) 78 | 79 | NodeId-PK-OK-injective : ∀ {pk pid1 pid2} 80 | → NodeId-PK-OK pk pid1 81 | → NodeId-PK-OK pk pid2 82 | → pid1 ≡ pid2 83 | NodeId-PK-OK-injective (m1 , pid1 , pk1) (m2 , pid2 , pk2) 84 | rewrite PK-inj ec (trans pk1 (sym pk2)) = trans (sym pid1) pid2 85 | 86 | module WithAbsVote (𝓔 : EpochConfig) where 87 | -- The abstract model is connected to the implementaton by means of 88 | -- 'VoteEvidence'. The record module will be parameterized by a 89 | -- v of type 'VoteEvidence 𝓔 UID'; this v will provide evidence 90 | -- that a given author voted for a given block (identified by the UID) 91 | -- on the specified round. 92 | -- 93 | -- When it comes time to instantiate the v above concretely, it will 94 | -- be something that states that we have a signature from the specified 95 | -- author voting for the specified block. 96 | record AbsVoteData : Set where 97 | constructor AbsVoteData∙new 98 | field 99 | abs-vRound : Round 100 | abs-vMember : EpochConfig.Member 𝓔 101 | abs-vBlockUID : UID 102 | open AbsVoteData public 103 | 104 | AbsVoteData-η : ∀ {r1 r2 : Round} {m1 m2 : EpochConfig.Member 𝓔} {b1 b2 : UID} 105 | → r1 ≡ r2 106 | → m1 ≡ m2 107 | → b1 ≡ b2 108 | → AbsVoteData∙new r1 m1 b1 ≡ AbsVoteData∙new r2 m2 b2 109 | AbsVoteData-η refl refl refl = refl 110 | 111 | VoteEvidence : Set₁ 112 | VoteEvidence = AbsVoteData → Set 113 | -------------------------------------------------------------------------------- /src/LibraBFT/Base/Util.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Level using (0ℓ) 8 | open import Data.String 9 | 10 | -- This module defines utility functions to help working on proofs. 11 | 12 | module LibraBFT.Base.Util where 13 | 14 | -- These should obviously not be used in any legitimate proof. They are just for convenience when 15 | -- we want to avoid importing a module with open holes while working on something else. 16 | 17 | -- This variant allows a comment to be attached conveniently 18 | obm-dangerous-magic' : ∀ {ℓ} {A : Set ℓ} → String → A 19 | obm-dangerous-magic' {ℓ} {A} _ = magic 20 | where postulate magic : A 21 | 22 | obm-dangerous-magic! : ∀ {ℓ} {A : Set ℓ} → A 23 | obm-dangerous-magic! {ℓ} {A} = obm-dangerous-magic' "" 24 | 25 | -------------------------------------------------------------------------------- /src/LibraBFT/Concrete/Intermediate.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | -- This module defines an intermediate (between an implementation and Abstract) notion 7 | -- of a system state. The goal is to enable proving for a particular implementation 8 | -- the properties required to provide to Abstract.Properties in order to get the high 9 | -- level correctness conditions, while moving the obligations for the implementation 10 | -- closer to notions more directly provable for an implementation. 11 | 12 | open import LibraBFT.ImplShared.Base.Types 13 | open import Util.Prelude 14 | 15 | open import LibraBFT.Abstract.Types.EpochConfig UID NodeId 16 | open WithAbsVote 17 | 18 | module LibraBFT.Concrete.Intermediate 19 | (𝓔 : EpochConfig) 20 | (𝓥 : VoteEvidence 𝓔) 21 | where 22 | open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 𝓥 23 | 24 | -- Since the invariants we want to specify (votes-once and preferred-round-rule), 25 | -- are predicates over a /System State/, we must factor out the necessary 26 | -- functionality. 27 | -- 28 | -- An /IntermediateSystemState/ supports a few different notions; namely, 29 | record IntermediateSystemState (ℓ : Level) : Set (ℓ+1 ℓ) where 30 | field 31 | -- A notion of membership of records 32 | InSys : Record → Set ℓ 33 | 34 | -- A predicate about whether votes have been transfered 35 | -- amongst participants 36 | HasBeenSent : Vote → Set ℓ 37 | 38 | -- Such that, the votes that belong to honest participants inside a 39 | -- QC that exists in the system must have been sent 40 | ∈QC⇒HasBeenSent : ∀{q α} → InSys (Q q) → Meta-Honest-Member α 41 | → (va : α ∈QC q) → HasBeenSent (∈QC-Vote q va) 42 | open IntermediateSystemState 43 | -------------------------------------------------------------------------------- /src/LibraBFT/Concrete/Obligations.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Base.Types 8 | 9 | open import LibraBFT.Abstract.Types.EpochConfig UID NodeId 10 | open import LibraBFT.Concrete.System.Parameters 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import LibraBFT.ImplShared.Consensus.Types.EpochDep 13 | open import Util.PKCS 14 | open import Util.Prelude 15 | open import Yasm.Base 16 | 17 | -- This module collects in one place the obligations an 18 | -- implementation must meet in order to enjoy the properties 19 | -- proved in Abstract.Properties. 20 | 21 | 22 | module LibraBFT.Concrete.Obligations (iiah : SystemInitAndHandlers ℓ-RoundManager ConcSysParms) (𝓔 : EpochConfig) where 23 | import LibraBFT.Concrete.Properties.PreferredRound iiah as PR 24 | import LibraBFT.Concrete.Properties.VotesOnce iiah as VO 25 | import LibraBFT.Concrete.Properties.Common iiah as Common 26 | 27 | 28 | open SystemTypeParameters ConcSysParms 29 | open SystemInitAndHandlers iiah 30 | open ParamsWithInitAndHandlers iiah 31 | open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms iiah 32 | PeerCanSignForPK PeerCanSignForPK-stable 33 | 34 | record ImplObligations : Set (ℓ+1 ℓ-RoundManager) where 35 | field 36 | -- Structural obligations: 37 | sps-cor : StepPeerState-AllValidParts 38 | 39 | -- Semantic obligations: 40 | -- 41 | -- VotesOnce: 42 | bsvc : Common.ImplObl-bootstrapVotesConsistent 𝓔 43 | bsvr : Common.ImplObl-bootstrapVotesRound≡0 𝓔 44 | v≢0 : Common.ImplObl-NewVoteRound≢0 𝓔 45 | ∈BI? : (sig : Signature) → Dec (∈BootstrapInfo bootstrapInfo sig) 46 | v4rc : PR.ImplObligation-RC 𝓔 47 | iro : Common.IncreasingRoundObligation 𝓔 48 | vo₂ : VO.ImplObligation₂ 𝓔 49 | 50 | -- PreferredRound: 51 | pr₁ : PR.ImplObligation₁ 𝓔 52 | pr₂ : PR.ImplObligation₂ 𝓔 53 | -------------------------------------------------------------------------------- /src/LibraBFT/Concrete/Obligations/VotesOnce.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.ImplShared.Base.Types 9 | open import Util.Prelude 10 | 11 | open import LibraBFT.Abstract.Types.EpochConfig UID NodeId 12 | open WithAbsVote 13 | 14 | module LibraBFT.Concrete.Obligations.VotesOnce 15 | (𝓔 : EpochConfig) 16 | (𝓥 : VoteEvidence 𝓔) 17 | where 18 | open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 𝓥 19 | open import LibraBFT.Concrete.Intermediate 𝓔 𝓥 20 | 21 | ------------------- 22 | -- * VotesOnce * -- 23 | ------------------- 24 | 25 | module _ {ℓ}(𝓢 : IntermediateSystemState ℓ) where 26 | open IntermediateSystemState 𝓢 27 | Type : Set ℓ 28 | Type = ∀{α v v'} 29 | → Meta-Honest-Member α 30 | → vMember v ≡ α → HasBeenSent v 31 | → vMember v' ≡ α → HasBeenSent v' 32 | → vRound v ≡ vRound v' 33 | → vBlockUID v ≡ vBlockUID v' 34 | -- NOTE: It is interesting that this does not require the timeout signature (or even 35 | -- presence/lack thereof) to be the same. The abstract proof goes through without out it, so I 36 | -- am leaving it out for now, but I'm curious what if anything could go wrong if an honest 37 | -- author can send different votes for the same epoch and round that differ on timeout 38 | -- signature. Maybe something for liveness? 39 | 40 | proof : Type → VotesOnlyOnceRule InSys 41 | proof glob-inv α hα {q} {q'} q∈sys q'∈sys va va' VO≡ 42 | with ∈QC⇒HasBeenSent q∈sys hα va 43 | | ∈QC⇒HasBeenSent q'∈sys hα va' 44 | ...| sent-cv | sent-cv' 45 | with glob-inv hα (sym (∈QC-Member q va)) sent-cv 46 | (sym (∈QC-Member q' va')) sent-cv' 47 | VO≡ 48 | ...| bId≡ 49 | = Vote-η VO≡ (trans (sym (∈QC-Member q va)) (∈QC-Member q' va')) 50 | bId≡ 51 | 52 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/BlockStorage/BlockRetriever.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Haskell.Modules.RWS.RustAnyHow 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.BlockRetrieval as BlockRetrieval 9 | import LibraBFT.Impl.IO.OBM.ObmNeedFetch as ObmNeedFetch 10 | open import LibraBFT.Impl.OBM.Logging.Logging 11 | open import LibraBFT.Impl.OBM.Rust.RustTypes 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 14 | open import LibraBFT.ImplShared.Util.Dijkstra.All 15 | open import Optics.All 16 | import Util.KVMap as Map 17 | open import Util.Prelude 18 | ------------------------------------------------------------------------------ 19 | import Data.String as String 20 | 21 | module LibraBFT.Impl.Consensus.BlockStorage.BlockRetriever where 22 | 23 | pickPeer : ℕ → List Author → Either ErrLog (Author × List Author) 24 | 25 | -- LBFT-OBM-DIFF : this lives in sync_manager.rs (in this file to isolate IO) 26 | -- TODO-1 PROVE IT TERMINATES 27 | {-# TERMINATING #-} 28 | retrieveBlockForQCM : BlockRetriever → QuorumCert → U64 → LBFT (Either ErrLog (List Block)) 29 | retrieveBlockForQCM _retriever qc numBlocks = 30 | loop (qc ^∙ qcCertifiedBlock ∙ biId) 0 (Map.kvm-keys (qc ^∙ qcLedgerInfo ∙ liwsSignatures)) 31 | where 32 | doLoop : HashValue → ℕ → List Author → LBFT (Either ErrLog (List Block)) 33 | logIt : InfoLog → LBFT Unit 34 | here' : List String.String → List String.String 35 | 36 | loop : HashValue → ℕ → List Author → LBFT (Either ErrLog (List Block)) 37 | loop blockId attempt = λ where 38 | [] → bail fakeErr -- [ "failed to fetch block, no more peers available" 39 | -- , lsHV blockId, show attempt ] 40 | peers0@(_ ∷ _) → do 41 | mme ← use (lRoundManager ∙ rmObmMe) 42 | maybeSD mme (bail fakeErr) $ λ me → do 43 | nf ← use lObmNeedFetch 44 | eitherS (pickPeer attempt peers0) bail $ λ (peer , peers) → do 45 | let request = BlockRetrievalRequest∙new me blockId numBlocks 46 | logIt fakeInfo -- ["to", lsA peer, lsBRQ request] 47 | let response = ObmNeedFetch.writeRequestReadResponseUNSAFE nf me peer request 48 | -- TODO : sign response and check sig on response 49 | case response ^∙ brpStatus of λ where 50 | BRSSucceeded → do 51 | logIt fakeInfo -- (here [lsBRP response]) 52 | vv ← use (lRoundManager ∙ rmEpochState ∙ esVerifier) 53 | -- LBFT-OBM-DIFF/TODO : this should live in a "network" module 54 | case BlockRetrieval.verify response (request ^∙ brqBlockId) (request ^∙ brqNumBlocks) vv of λ where 55 | (Left e) → bail (withErrCtx (here' []) e) 56 | (Right _) → ok (response ^∙ brpBlocks) 57 | BRSIdNotFound → doLoop blockId attempt peers 58 | BRSNotEnoughBlocks → doLoop blockId attempt peers 59 | 60 | doLoop blockId attempt peers = do 61 | logIt fakeInfo -- (here' ["trying another peer", lsBRP response]) 62 | loop blockId (attempt + 1) peers 63 | 64 | here' t = "BlockRetriever" ∷ "retrieveBlockForQCM" ∷ "NeedFetch" ∷ t 65 | logIt l = -- do 66 | logInfo l 67 | -- let x = Unsafe.unsafePerformIO (putStrLn @Text (show l)) 68 | -- x `seq` pure x 69 | 70 | pickPeer _ = λ where 71 | [] → Left fakeErr -- ["no more peers"] 72 | (p ∷ ps) → pure (p , ps) 73 | 74 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/Block.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.BlockData as BlockData 9 | import LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert as QuorumCert 10 | import LibraBFT.Impl.Types.BlockInfo as BlockInfo 11 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 12 | open import LibraBFT.Impl.OBM.Crypto 13 | open import LibraBFT.Impl.OBM.Logging.Logging 14 | open import LibraBFT.ImplShared.Base.Types 15 | open import LibraBFT.ImplShared.Consensus.Types 16 | open import Optics.All 17 | open import Util.Hash 18 | open import Util.PKCS 19 | open import Util.Prelude 20 | ------------------------------------------------------------------------------ 21 | open import Data.String using (String) 22 | 23 | module LibraBFT.Impl.Consensus.ConsensusTypes.Block where 24 | 25 | genBlockInfo : Block → HashValue → Version → Maybe EpochState → BlockInfo 26 | genBlockInfo b executedStateId version nextEpochState = BlockInfo∙new 27 | (b ^∙ bEpoch) (b ^∙ bRound) (b ^∙ bId) executedStateId version nextEpochState 28 | 29 | isGenesisBlock : Block → Bool 30 | isGenesisBlock b = BlockData.isGenesisBlock (b ^∙ bBlockData) 31 | 32 | isNilBlock : Block → Bool 33 | isNilBlock b = BlockData.isNilBlock (b ^∙ bBlockData) 34 | 35 | makeGenesisBlockFromLedgerInfo : LedgerInfo → Either ErrLog Block 36 | makeGenesisBlockFromLedgerInfo li = do 37 | blockData <- BlockData.newGenesisFromLedgerInfo li 38 | pure (Block∙new (hashBD blockData) blockData nothing) 39 | 40 | newNil : Round → QuorumCert → Block 41 | newNil r qc = Block∙new (hashBD blockData) blockData nothing 42 | where blockData = BlockData.newNil r qc 43 | 44 | newProposalFromBlockDataAndSignature : BlockData → Signature → Block 45 | newProposalFromBlockDataAndSignature blockData signature = 46 | Block∙new (hashBD blockData) blockData (just signature) 47 | 48 | validateSignature : Block → ValidatorVerifier → Either ErrLog Unit 49 | validateSignature self validator = case self ^∙ bBlockData ∙ bdBlockType of λ where 50 | Genesis → Left fakeErr -- (ErrL (here' ["do not accept genesis from others"])) 51 | NilBlock → QuorumCert.verify (self ^∙ bQuorumCert) validator 52 | (Proposal _ author) → do 53 | fromMaybeM 54 | (Left fakeErr) -- (ErrL (here' ["Missing signature in Proposal"]))) 55 | (pure (self ^∙ bSignature)) >>= λ sig -> withErrCtx' (here' []) 56 | (ValidatorVerifier.verify validator author (self ^∙ bBlockData) sig) 57 | QuorumCert.verify (self ^∙ bQuorumCert) validator 58 | where 59 | here' : List String → List String 60 | here' t = "Block" ∷ "validateSignatures" {-∷ lsB self-} ∷ t 61 | 62 | verifyWellFormed : Block → Either ErrLog Unit 63 | verifyWellFormed self = do 64 | lcheck (not (isGenesisBlock self)) 65 | (here' ("Do not accept genesis from others" ∷ [])) 66 | let parent = self ^∙ bQuorumCert ∙ qcCertifiedBlock 67 | lcheck (parent ^∙ biRound ? 0) 28 | (here' ("Proposal for has round <= 0" ∷ [])) 29 | lcheck (self ^∙ pmProposal ∙ bEpoch == self ^∙ pmSyncInfo ∙ siEpoch) 30 | (here' ("ProposalMsg has different epoch than SyncInfo" ∷ [])) -- lsSI (self ^∙ pmSyncInfo) 31 | 32 | lcheck (self ^∙ pmProposal ∙ bParentId == self ^∙ pmSyncInfo ∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biId) 33 | (here' ( "Proposal SyncInfo HQC CertifiedBlock id not eq to block parent id" ∷ [])) 34 | -- lsSI (self ^∙ pmSyncInfo) 35 | let previousRound = self ^∙ pmProposal ∙ bRound ∸ 1 -- NOTE: monus usage 36 | let highestCertifiedRound = 37 | max (self ^∙ pmProposal ∙ bQuorumCert ∙ qcCertifiedBlock ∙ biRound) 38 | (maybe 0 (_^∙ tcRound) (self ^∙ pmSyncInfo ∙ siHighestTimeoutCert)) 39 | lcheck (previousRound == highestCertifiedRound) 40 | (here' ("Proposal does not have a certified round" ∷ [])) 41 | -- lsMTC (self ^∙ pmSyncInfo ∙ siHighestTimeoutCert) 42 | lcheck (is-just (self ^∙ pmProposal ∙ bAuthor)) 43 | (here' ("Proposal does not have an author" ∷ [])) 44 | -- LBFT-DIFF : this check used to live in EventProcessor ∙ processProposedBlockM 45 | -- TODO: is it needed? 46 | -- Safety invariant: For any valid proposed block 47 | -- , its parent block == the block pointed to by its QC. 48 | lcheck (self ^∙ pmProposal ∙ bParentId == self ^∙ pmProposal ∙ bQuorumCert ∙ qcCertifiedBlock ∙ biId) 49 | (here' ("parent id /= qcCB" ∷ [])) -- show (self ^∙ pmProposal) 50 | where 51 | here' : List String → List String 52 | here' t = "ProposalMsg" ∷ "verifyWellFormed" {-∷ lsPM self-} ∷ t 53 | 54 | 55 | verify : ProposalMsg → ValidatorVerifier → Either ErrLog Unit 56 | verify self validator = do 57 | Block.validateSignature (self ^∙ pmProposal) validator 58 | TimeoutCertificate.verify' (self ^∙ pmSyncInfo ∙ siHighestTimeoutCert) validator 59 | verifyWellFormed self 60 | 61 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/QuorumCert.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.VoteData as VoteData 9 | open import LibraBFT.Impl.OBM.Logging.Logging 10 | import LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures 11 | open import LibraBFT.ImplShared.Base.Types 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import Optics.All 14 | open import Util.Hash 15 | import Util.KVMap as Map 16 | open import Util.Prelude 17 | ------------------------------------------------------------------------------ 18 | open import Data.String using (String) 19 | 20 | module LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert where 21 | 22 | certificateForGenesisFromLedgerInfo : LedgerInfo → HashValue → QuorumCert 23 | certificateForGenesisFromLedgerInfo ledgerInfo genesisId = 24 | let ancestor = BlockInfo∙new 25 | (ledgerInfo ^∙ liEpoch + 1) 26 | 0 27 | genesisId 28 | (ledgerInfo ^∙ liTransactionAccumulatorHash) 29 | (ledgerInfo ^∙ liVersion) 30 | --(ledgerInfo ^∙ liTimestamp) 31 | nothing 32 | voteData = VoteData.new ancestor ancestor 33 | li = LedgerInfo∙new ancestor (hashVD voteData) 34 | in QuorumCert∙new 35 | voteData 36 | (LedgerInfoWithSignatures∙new li Map.empty) 37 | 38 | verify : QuorumCert → ValidatorVerifier → Either ErrLog Unit 39 | verify self validator = do 40 | let voteHash = hashVD (self ^∙ qcVoteData) 41 | lcheck (self ^∙ qcSignedLedgerInfo ∙ liwsLedgerInfo ∙ liConsensusDataHash == voteHash) 42 | (here' ("Quorum Cert's hash mismatch LedgerInfo" ∷ [])) 43 | if (self ^∙ qcCertifiedBlock ∙ biRound == 0) 44 | -- TODO-?: It would be nice not to require the parens around the do block 45 | then (do 46 | lcheck (self ^∙ qcParentBlock == self ^∙ qcCertifiedBlock) 47 | (here' ("Genesis QC has inconsistent parent block with certified block" ∷ [])) 48 | lcheck (self ^∙ qcCertifiedBlock == self ^∙ qcLedgerInfo ∙ liwsLedgerInfo ∙ liCommitInfo) 49 | (here' ("Genesis QC has inconsistent commit block with certified block" ∷ [])) 50 | lcheck (Map.kvm-size (self ^∙ qcLedgerInfo ∙ liwsSignatures) == 0) 51 | (here' ("Genesis QC should not carry signatures" ∷ [])) 52 | ) 53 | else do 54 | withErrCtx' 55 | ("fail to verify QuorumCert" ∷ []) 56 | (LedgerInfoWithSignatures.verifySignatures (self ^∙ qcLedgerInfo) validator) 57 | VoteData.verify (self ^∙ qcVoteData) 58 | where 59 | here' : List String → List String 60 | here' t = "QuorumCert" ∷ "verify" {- ∷ lsQC self-} ∷ t 61 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/SyncInfo.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert as QuorumCert 9 | import LibraBFT.Impl.Consensus.ConsensusTypes.TimeoutCertificate as TimeoutCertificate 10 | open import LibraBFT.Impl.OBM.Logging.Logging 11 | import LibraBFT.Impl.Types.BlockInfo as BlockInfo 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.LBFT 14 | open import Optics.All 15 | open import Util.Hash 16 | open import Util.Prelude 17 | ------------------------------------------------------------------------------ 18 | open import Data.String using (String) 19 | 20 | module LibraBFT.Impl.Consensus.ConsensusTypes.SyncInfo where 21 | 22 | highestRound : SyncInfo → Round 23 | highestRound self = max (self ^∙ siHighestCertifiedRound) (self ^∙ siHighestTimeoutRound) 24 | 25 | verify : SyncInfo → ValidatorVerifier → Either ErrLog Unit 26 | 27 | verifyM : SyncInfo → ValidatorVerifier → LBFT (Either ErrLog Unit) 28 | verifyM self validator = pure (verify self validator) 29 | 30 | module verify (self : SyncInfo) (validator : ValidatorVerifier) where 31 | step₀ step₁ step₂ step₃ step₄ step₅ step₆ : Either ErrLog Unit 32 | here' : List String → List String 33 | 34 | epoch = self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biEpoch 35 | 36 | step₀ = do 37 | lcheck (epoch == self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biEpoch) 38 | (here' ("Multi epoch in SyncInfo - HCC and HQC" ∷ [])) 39 | step₁ 40 | 41 | step₁ = do 42 | lcheck (maybeS (self ^∙ siHighestTimeoutCert) true (λ tc -> epoch == tc ^∙ tcEpoch)) 43 | (here' ("Multi epoch in SyncInfo - TC and HQC" ∷ [])) 44 | step₂ 45 | 46 | step₂ = do 47 | lcheck ( self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biRound 48 | ≥? self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biRound) 49 | (here' ("HQC has lower round than HCC" ∷ [])) 50 | step₃ 51 | 52 | step₃ = do 53 | lcheck (self ^∙ siHighestCommitCert ∙ qcCommitInfo /= BlockInfo.empty) 54 | (here' ("HCC has no committed block" ∷ [])) 55 | step₄ 56 | 57 | step₄ = do 58 | QuorumCert.verify (self ^∙ siHighestQuorumCert) validator 59 | step₅ 60 | 61 | step₅ = do 62 | -- Note: do not use (self ^∙ siHighestCommitCert) because it might be 63 | -- same as siHighestQuorumCert -- so no need to check again 64 | maybeS (self ^∙ sixxxHighestCommitCert) (pure unit) (` QuorumCert.verify ` validator) 65 | step₆ 66 | 67 | step₆ = do 68 | maybeS (self ^∙ siHighestTimeoutCert) (pure unit) (` TimeoutCertificate.verify ` validator) 69 | 70 | here' t = "SyncInfo" ∷ "verify" ∷ t 71 | 72 | verify = verify.step₀ 73 | 74 | hasNewerCertificates : SyncInfo → SyncInfo → Bool 75 | hasNewerCertificates self other 76 | = ⌊ self ^∙ siHighestCertifiedRound >? other ^∙ siHighestCertifiedRound ⌋ 77 | ∨ ⌊ self ^∙ siHighestTimeoutRound >? other ^∙ siHighestTimeoutRound ⌋ 78 | ∨ ⌊ self ^∙ siHighestCommitRound >? other ^∙ siHighestCommitRound ⌋ 79 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/TimeoutCertificate.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.OBM.Crypto hiding (verify) 8 | open import LibraBFT.Impl.OBM.Logging.Logging 9 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | open import Util.KVMap as Map 13 | open import Util.PKCS hiding (verify) 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Consensus.ConsensusTypes.TimeoutCertificate where 17 | 18 | verify : TimeoutCertificate → ValidatorVerifier → Either ErrLog Unit 19 | verify self validator = 20 | withErrCtx' ("TimeoutCertificate" ∷ "verify" ∷ "failed" ∷ []) 21 | (ValidatorVerifier.verifyAggregatedStructSignature 22 | validator (self ^∙ tcTimeout) (self ^∙ tcSignatures)) 23 | 24 | verify' : Maybe TimeoutCertificate → ValidatorVerifier → Either ErrLog Unit 25 | verify' mtc validator = maybeSMP (pure mtc) unit (` verify ` validator) 26 | 27 | -- HC-TODO : refactor this and LedgerInfoWithSignatures 28 | addSignature : Author → Signature → TimeoutCertificate → TimeoutCertificate 29 | addSignature a s tc = 30 | case Map.lookup a (tc ^∙ tcSignatures) of λ where 31 | (just _) → tc 32 | nothing → tc & tcSignatures ∙~ Map.kvm-insert-Haskell a s (tc ^∙ tcSignatures) 33 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/Vote.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | import LibraBFT.Impl.Consensus.ConsensusTypes.VoteData as VoteData 8 | open import LibraBFT.Impl.OBM.Crypto hiding (verify) 9 | open import LibraBFT.Impl.OBM.Logging.Logging 10 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import Optics.All 13 | open import Util.Hash 14 | open import Util.PKCS hiding (verify) 15 | open import Util.Prelude 16 | ------------------------------------------------------------------------------ 17 | open import Data.String using (String) 18 | 19 | module LibraBFT.Impl.Consensus.ConsensusTypes.Vote where 20 | 21 | ------------------------------------------------------------------------------ 22 | 23 | timeout : Vote → Timeout 24 | 25 | ------------------------------------------------------------------------------ 26 | 27 | newWithSignature : VoteData → Author → LedgerInfo → Signature → Vote 28 | newWithSignature voteData author ledgerInfo signature = 29 | Vote∙new voteData author ledgerInfo signature nothing 30 | 31 | verify : Vote → ValidatorVerifier → Either ErrLog Unit 32 | verify self validator = do 33 | lcheck (self ^∙ vLedgerInfo ∙ liConsensusDataHash == hashVD (self ^∙ vVoteData)) 34 | (here' ("Vote's hash mismatch with LedgerInfo" ∷ [])) 35 | withErrCtx' (here' ("vote" ∷ [])) 36 | (ValidatorVerifier.verify validator (self ^∙ vAuthor) (self ^∙ vLedgerInfo) (self ^∙ vSignature)) 37 | case self ^∙ vTimeoutSignature of λ where 38 | nothing → pure unit 39 | (just tos) → 40 | withErrCtx' (here' ("timeout" ∷ [])) 41 | (ValidatorVerifier.verify validator (self ^∙ vAuthor) (timeout self) tos) 42 | withErrCtx' (here' ("VoteData" ∷ [])) (VoteData.verify (self ^∙ vVoteData)) 43 | where 44 | here' : List String → List String 45 | here' t = "Vote" ∷ "verify" ∷ "failed" {-∷lsV self-} ∷ t 46 | 47 | addTimeoutSignature : Vote → Signature → Vote 48 | addTimeoutSignature self sig = 49 | if is-just (self ^∙ vTimeoutSignature) 50 | then self 51 | else self & vTimeoutSignature ?~ sig 52 | 53 | timeout v = 54 | Timeout∙new (v ^∙ vVoteData ∙ vdProposed ∙ biEpoch) (v ^∙ vVoteData ∙ vdProposed ∙ biRound) 55 | 56 | isTimeout : Vote → Bool 57 | isTimeout v = is-just (v ^∙ vTimeoutSignature) 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/ConsensusTypes/VoteData.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.ImplShared.Base.Types 9 | open import LibraBFT.ImplShared.Consensus.Types 10 | open import LibraBFT.Impl.OBM.Logging.Logging 11 | open import Optics.All 12 | open import Util.Prelude 13 | 14 | module LibraBFT.Impl.Consensus.ConsensusTypes.VoteData where 15 | 16 | verify : VoteData → Either ErrLog Unit 17 | verify self = do 18 | lcheck (self ^∙ vdParent ∙ biEpoch == self ^∙ vdProposed ∙ biEpoch) 19 | ("parent and proposed epochs do not match" ∷ []) 20 | lcheck (⌊ self ^∙ vdParent ∙ biRound (em ^∙ emEpochState) 56 | s : EpochManager → Either ErrLog Epoch → EpochManager 57 | s em _ = em 58 | 59 | -- getter only in Haskell 60 | emObmRoundManager : Lens EpochManager (Either ErrLog RoundManager) 61 | emObmRoundManager = mkLens' g s 62 | where 63 | g : EpochManager → Either ErrLog RoundManager 64 | g em = case em ^∙ emProcessor of λ where 65 | (just (RoundProcessorNormal rm)) → pure rm 66 | (just (RoundProcessorRecovery _)) → Left fakeErr 67 | nothing → Left fakeErr 68 | s : EpochManager → Either ErrLog RoundManager -> EpochManager 69 | s em _ = em 70 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/LedgerRecoveryData.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.Block as Block 9 | import LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert as QuorumCert 10 | open import LibraBFT.ImplShared.Base.Types 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import Optics.All 13 | open import Util.Hash 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Consensus.LedgerRecoveryData where 17 | 18 | postulate -- TODO-2: compareX, sortBy, findIndex, deleteAt, find 19 | compareX : (Epoch × Round) → (Epoch × Round) → Ordering 20 | sortBy : (Block → Block → Ordering) → List Block → List Block 21 | findIndex : (Block → Bool) → List Block → Maybe ℕ 22 | deleteAt : ℕ → List Block → List Block 23 | find : (QuorumCert → Bool) → List QuorumCert -> Maybe QuorumCert 24 | 25 | findRoot : List Block → List QuorumCert → LedgerRecoveryData 26 | → Either ErrLog (RootInfo × List Block × List QuorumCert) 27 | findRoot blocks0 quorumCerts0 (LedgerRecoveryData∙new storageLedger) = do 28 | (rootId , (blocks1 , quorumCerts)) ← 29 | if storageLedger ^∙ liEndsEpoch 30 | then (do 31 | genesis ← Block.makeGenesisBlockFromLedgerInfo storageLedger 32 | let genesisQC = QuorumCert.certificateForGenesisFromLedgerInfo storageLedger (genesis ^∙ bId) 33 | pure (genesis ^∙ bId , (genesis ∷ blocks0 , genesisQC ∷ quorumCerts0))) 34 | else 35 | pure (storageLedger ^∙ liConsensusBlockId , (blocks0 , quorumCerts0)) 36 | let sorter : Block → Block → Ordering 37 | sorter bl br = compareX (bl ^∙ bEpoch , bl ^∙ bRound) (br ^∙ bEpoch , br ^∙ bRound) 38 | sortedBlocks = sortBy sorter blocks1 39 | rootIdx ← maybeS 40 | (findIndex (λ x → x ^∙ bId == rootId) sortedBlocks) 41 | (Left fakeErr) -- ["unable to find root", show rootId] 42 | (pure ∘ id) 43 | rootBlock ← maybeS 44 | (sortedBlocks !? rootIdx) 45 | (Left fakeErr) -- ["sortedBlocks !? rootIdx"] 46 | (pure ∘ id) 47 | let blocks = deleteAt rootIdx sortedBlocks 48 | rootQuorumCert ← maybeS 49 | (find (λ x → x ^∙ qcCertifiedBlock ∙ biId == rootBlock ^∙ bId) quorumCerts) 50 | (Left fakeErr) -- ["No QC found for root", show rootId] 51 | (pure ∘ id) 52 | rootLedgerInfo ← maybeS 53 | (find (λ x → x ^∙ qcCommitInfo ∙ biId == rootBlock ^∙ bId) quorumCerts) 54 | (Left fakeErr) -- ["No LI found for root", show rootId] 55 | (pure ∘ id) 56 | pure (RootInfo∙new rootBlock rootQuorumCert rootLedgerInfo , blocks , quorumCerts) 57 | {- 58 | where 59 | here t = "LedgerRecoveryData":"findRoot":t 60 | deleteAt idx xs = lft ++ tail rgt where (lft, rgt) = splitAt idx xs 61 | tail = \case [] -> []; (_:xs) -> xs 62 | -} 63 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Liveness/ExponentialTimeInterval.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Impl.OBM.Rust.Duration as Duration 9 | open import LibraBFT.Impl.OBM.Rust.RustTypes 10 | open import LibraBFT.ImplShared.Base.Types 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import Optics.All 13 | open import Util.Prelude 14 | 15 | module LibraBFT.Impl.Consensus.Liveness.ExponentialTimeInterval where 16 | 17 | new : Duration → F64 → Usize → ExponentialTimeInterval 18 | new base exponentBase maxExponent = 19 | {- TODO-1 20 | if | maxExponent >= 32 21 | -> errorExit [ "ExponentialTimeInterval", "new" 22 | , "maxExponent for PacemakerTimeInterval should be < 32", show maxExponent ] 23 | | ceiling (exponentBase ** fromIntegral maxExponent) >= {-F64-} (maxBound::Int) 24 | -> errorExit [ "ExponentialTimeInterval", "new" 25 | , "maximum interval multiplier should be less then u32::Max"] 26 | | otherwise 27 | -> 28 | -} mkExponentialTimeInterval 29 | (Duration.asMillis base) 30 | exponentBase 31 | maxExponent 32 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Liveness/Properties/ProposerElection.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Impl.Consensus.Liveness.ProposerElection 9 | open import LibraBFT.ImplShared.Base.Types 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import LibraBFT.ImplShared.LBFT 12 | open import Optics.All 13 | open import Util.Lemmas 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Consensus.Liveness.Properties.ProposerElection where 17 | 18 | -- TUTORIAL 19 | module isValidProposalMSpec (b : Block) where 20 | 21 | pe = _^∙ lProposerElection 22 | mAuthor = b ^∙ bAuthor 23 | round = b ^∙ bRound 24 | 25 | contract 26 | : ∀ pre Post 27 | → (mAuthor ≡ nothing → Post (Left ProposalDoesNotHaveAnAuthor) pre []) 28 | → (Maybe-Any (getValidProposer (pe pre) round ≢_) mAuthor 29 | → Post (Left ProposerForBlockIsNotValidForThisRound) pre []) 30 | → (Maybe-Any (getValidProposer (pe pre) round ≡_) mAuthor 31 | → Post (Right unit) pre []) 32 | → LBFT-weakestPre (isValidProposalM b) Post pre 33 | -- 1. `isValidProposalM` begins with `RWS-maybe`, so we must provide two cases: 34 | -- one where `b ^∙ bAuthor` is `nothing` and one where it is `just` 35 | -- something 36 | -- 2. When it is nothing, we appeal to the assumed proof 37 | proj₁ (contract pre Post pfNone pf≢ pfOk) mAuthor≡nothing = pfNone mAuthor≡nothing 38 | -- 3. When it is something, we step into `isValidProposerM`. This means: 39 | -- - we use the proposer election of the round manager (`pe` and `pe≡`) 40 | -- - we apply `isValidProposer` to `pe` (`isvp-pe` and `isvp-pe≡`) 41 | -- - we push the pure value `a` into the LBFT monad and apply `isvp-pe` to 42 | -- it (`.a`, `isvp-pe-a`, and `isvp-pe-a≡`) 43 | -- - we push the pure value `b ^∙ bRound` (`r` and `r≡`) into the LBFT 44 | -- monad, and the returned value is the result of applying `isvp-pe-a` to 45 | -- this 46 | -- - now out of `isValidProposalM`, we are given an alias `r'` for `r` 47 | -- > proj₂ (contract Post pre pfNone pf≢ pfOk) a ma≡just-a isvp isvp≡ pe pe≡ isvp-pe isvp-pe≡ .a refl isvp-pe-a isvp-pe-a≡ r r≡ r' r'≡ = {!!} 48 | -- 4. Since the returned value we want to reason about is directly related to 49 | -- the behavior of these bound functions which are partial applications of 50 | -- `isValidProposer`, we perform case-analysis on each of the equality 51 | -- proofs (we can't pattern match on `ma≡just-a` directly) 52 | -- > proj₂ (contract pre Post pfNone pf≢ pfOk) a ma≡just-a ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl = {!!} 53 | -- 5. Now we encounter an `ifD`, which means we must provide two cases, one corresponding to each branch. 54 | proj₁ (proj₂ (contract pre Post pfNone pf≢ pfOk) a ma≡just-a ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl) vp≡true 55 | -- 6. The types of `pfOk` and `pf≢` are still "stuck" on the expression 56 | -- > b ^∙ bAuthor 57 | -- So, in both the `false` and `true` cases we rewrite by `ma≡just-a`, which 58 | -- tells us that the result is `just a` 59 | rewrite ma≡just-a = 60 | -- 7. To finish, we use `toWitnessF` to convert between the two forms of evidence. 61 | pfOk (just (toWitnessT vp≡true)) 62 | proj₂ (proj₂ (contract pre Post pfNone pf≢ pfOk) a ma≡just-a ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl) vp≡false 63 | rewrite ma≡just-a = 64 | pf≢ (just (toWitnessF vp≡false)) 65 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Liveness/ProposalGenerator.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.Block as Block 9 | import LibraBFT.Impl.Consensus.ConsensusTypes.BlockData as BlockData 10 | import LibraBFT.Impl.Types.BlockInfo as BlockInfo 11 | open import LibraBFT.ImplShared.Base.Types 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.Util.Dijkstra.All 14 | open import Optics.All 15 | open import Util.Encode as Encode 16 | open import Util.Prelude 17 | 18 | module LibraBFT.Impl.Consensus.Liveness.ProposalGenerator where 19 | 20 | ensureHighestQuorumCertM : Round → LBFT (Either ErrLog QuorumCert) 21 | 22 | generateNilBlockM : Round → LBFT (Either ErrLog Block) 23 | generateNilBlockM round = 24 | ensureHighestQuorumCertM round ∙?∙ (ok ∘ Block.newNil round) 25 | 26 | generateProposalM : Instant → Round → LBFT (Either ErrLog BlockData) 27 | generateProposalM _now round = do 28 | lrg ← use (lProposalGenerator ∙ pgLastRoundGenerated) 29 | ifD lrg do 33 | payload ← ifD BlockInfo.hasReconfiguration (hqc ^∙ qcCertifiedBlock) 34 | -- IMPL-DIFF : create a fake TX 35 | then pure (Encode.encode 0) -- (Payload []) 36 | else pure (Encode.encode 0) -- use pgTxnManager <*> use (rmEpochState ∙ esEpoch) <*> pure round 37 | use (lRoundManager ∙ pgAuthor) >>= λ where 38 | nothing → bail fakeErr -- ErrL (here ["lRoundManager.pgAuthor", "Nothing"]) 39 | (just author) → 40 | ok (BlockData.newProposal payload author round {-pure blockTimestamp <*>-} hqc)) 41 | else bail fakeErr 42 | -- where 43 | -- here t = "ProposalGenerator" ∷ "generateProposal" ∷ t 44 | 45 | ensureHighestQuorumCertM round = do 46 | hqc ← use (lBlockStore ∙ bsHighestQuorumCert) 47 | ifD‖ (hqc ^∙ qcCertifiedBlock ∙ biRound) ≥?ℕ round ≔ 48 | bail fakeErr {- ErrL (here [ "given round is lower than hqc round" 49 | , show (hqc^.qcCertifiedBlock.biRound) ]) -} 50 | ‖ hqc ^∙ qcEndsEpoch ≔ 51 | bail fakeErr {-ErrEpochEndedNoProposals (here ["further proposals not allowed"])-} 52 | ‖ otherwise≔ 53 | ok hqc 54 | -- where 55 | -- here t = "ProposalGenerator":"ensureHighestQuorumCertM":lsR round:t 56 | 57 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Liveness/ProposerElection.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.ImplShared.Base.Types 9 | open import LibraBFT.ImplShared.Consensus.Types 10 | open import LibraBFT.ImplShared.Util.Dijkstra.All 11 | open import Optics.All 12 | open import Util.Prelude 13 | 14 | module LibraBFT.Impl.Consensus.Liveness.ProposerElection where 15 | 16 | postulate -- TODO-1: Implement getValidProposer 17 | getValidProposer : ProposerElection → Round → Author 18 | 19 | isValidProposerM : Author → Round → LBFT Bool 20 | isValidProposer : ProposerElection → Author → Round → Bool 21 | 22 | isValidProposalM : Block → LBFT (Either ObmNotValidProposerReason Unit) 23 | isValidProposalM b = 24 | maybeSD (b ^∙ bAuthor) (bail ProposalDoesNotHaveAnAuthor) $ λ a → do 25 | -- IMPL-DIFF: `ifM` in Haskell means something else 26 | vp ← isValidProposerM a (b ^∙ bRound) 27 | ifD vp 28 | then ok unit 29 | else bail ProposerForBlockIsNotValidForThisRound 30 | 31 | isValidProposerM a r = isValidProposer <$> use lProposerElection <*> pure a <*> pure r 32 | 33 | isValidProposer pe a r = getValidProposer pe r == a 34 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/MetricsSafetyRules.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.SafetyRules.SafetyRules as SafetyRules 9 | import LibraBFT.Impl.Consensus.TestUtils.MockStorage as MockStorage 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import LibraBFT.ImplShared.Util.Dijkstra.All 12 | open import Optics.All 13 | open import Util.Prelude 14 | 15 | module LibraBFT.Impl.Consensus.MetricsSafetyRules where 16 | 17 | module performInitialize 18 | (self : SafetyRules) 19 | (obmPersistentLivenessStorage : PersistentLivenessStorage) 20 | where 21 | 22 | step₀ : EitherD ErrLog SafetyRules 23 | step₁ : EpochChangeProof → EitherD ErrLog SafetyRules 24 | 25 | step₀ = do 26 | let consensusState = SafetyRules.consensusState self 27 | srWaypoint = consensusState ^∙ csWaypoint 28 | proofs ← MockStorage.retrieveEpochChangeProofED 29 | (srWaypoint ^∙ wVersion) obmPersistentLivenessStorage 30 | step₁ proofs 31 | step₁ proofs = SafetyRules.initialize-ed-abs self proofs 32 | 33 | abstract 34 | performInitialize-ed-abs = performInitialize.step₀ 35 | performInitialize-abs : SafetyRules → PersistentLivenessStorage → Either ErrLog SafetyRules 36 | performInitialize-abs sr storage = toEither $ performInitialize-ed-abs sr storage 37 | performInitialize-abs-≡ : (sr : SafetyRules) (storage : PersistentLivenessStorage) 38 | → performInitialize-abs sr storage ≡ EitherD-run (performInitialize-ed-abs sr storage) 39 | performInitialize-abs-≡ sr storage = refl 40 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Network.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusTypes.ProposalMsg as ProposalMsg 9 | import LibraBFT.Impl.Consensus.ConsensusTypes.VoteMsg as VoteMsg 10 | open import LibraBFT.ImplShared.Base.Types 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import LibraBFT.ImplShared.NetworkMsg 13 | open import Optics.All 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Consensus.Network where 17 | 18 | processProposal : {- NodeId → -} ProposalMsg → Epoch → ValidatorVerifier → Either (Either ErrLog InfoLog) Unit 19 | processProposal {- peerId -} proposal myEpoch vv = 20 | case pProposal of λ where 21 | (Left e) → Left (Left e) 22 | (Right unit) → 23 | grd‖ proposal ^∙ pmProposal ∙ bEpoch == myEpoch ≔ 24 | pure unit 25 | -- TODO : push this onto a queue if epoch is in future (is this still relevant?) 26 | ‖ proposal ^∙ pmProposal ∙ bEpoch == myEpoch + 1 ≔ 27 | Left (Right fakeInfo) -- proposal in new epoch arrived before my epoch change 28 | ‖ otherwise≔ 29 | Left (Left fakeErr) -- proposal for wrong epoch 30 | where 31 | pProposal = do 32 | ProposalMsg.verify proposal vv 33 | -- Note that our model does not assume knowledge of who sends a message, and therefore we do not 34 | -- check that the proposal is *sent* by the given peer (of course it must be *signed* by the 35 | -- peer, which is verified elsewhere). Our proof should not require this. 36 | {- lcheck (proposal ^∙ pmProposal ∙ bAuthor == just peerId) -} 37 | 38 | processVote : {- NodeId → -} VoteMsg → Epoch → ValidatorVerifier → Either (Either ErrLog InfoLog) Unit 39 | processVote {- peerId -} voteMsg myEpoch vv = 40 | case pVote of λ where 41 | (Left e) → Left (Left e) 42 | (Right unit) → 43 | grd‖ voteMsg ^∙ vmEpoch == myEpoch ≔ 44 | pure unit 45 | -- IMPL-TODO : push this onto a queue if epoch is in future (is this still relevant?) 46 | -- NOTE : epoch might be mismatched because 47 | -- - vote for EpochChange proposal round + 2 arrives 48 | -- after leader already already formed a quorum 49 | -- - timeout votes for previous or subsequent epochs arrive after the epoch change 50 | ‖ voteMsg ^∙ vmVote ∙ vVoteData ∙ vdProposed ∙ biEpoch + 1 == myEpoch ≔ 51 | Left (Right (fakeInfo {- (here $ "vote for previous epoch arrived after my epoch change" ∷ lsE myEpoch ∷ []) -})) 52 | ‖ voteMsg ^∙ vmVote ∙ vVoteData ∙ vdProposed ∙ biEpoch == myEpoch + 1 ≔ 53 | Left (Right (fakeInfo {- (here $ "vote for previous epoch arrived before my epoch change" ∷ lsE myEpoch ∷ []) -})) 54 | ‖ otherwise≔ 55 | Left (Left (fakeErr {- (here $ "vote for wrong epoch" ∷ lsE myEpoch ∷ [])-})) 56 | where 57 | -- here t = "Network" ∷ "processVote" ∷ lsVM voteMsg ∷ t 58 | 59 | pVote : Either ErrLog Unit 60 | pVote = do 61 | -- See comment above about checking which peer *sent* the message. 62 | -- lcheck (voteMsg ^∙ vmVote ∙ vAuthor == peerId) 63 | -- (here $ "vote received must be from the sending peer" ∷ lsA peerId ∷ []) 64 | VoteMsg.verify voteMsg vv 65 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Network/Properties.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Concrete.Records 9 | open import LibraBFT.Impl.Consensus.Network 10 | open import LibraBFT.Impl.Properties.Util 11 | open import LibraBFT.ImplShared.Base.Types 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.NetworkMsg 14 | open import Optics.All 15 | open import Util.Prelude 16 | 17 | module LibraBFT.Impl.Consensus.Network.Properties where 18 | 19 | open Invariants 20 | 21 | module processProposalSpec (proposal : ProposalMsg) (myEpoch : Epoch) (vv : ValidatorVerifier) where 22 | postulate -- TODO-2: Refine contract 23 | -- We also need to know that the the proposal message was successfully 24 | -- checked by `ProposalMsg.verify` 25 | contract 26 | : case (processProposal proposal myEpoch vv) of λ where 27 | (Left _) → Unit 28 | (Right _) → proposal ^∙ pmProposal ∙ bEpoch ≡ myEpoch 29 | × BlockId-correct (proposal ^∙ pmProposal) 30 | 31 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/PendingVotes.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | Copyright (c) 2021, Oracle and/or its affiliates. 3 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 4 | -} 5 | 6 | import LibraBFT.Impl.Consensus.ConsensusTypes.Vote as Vote 7 | import LibraBFT.Impl.Consensus.ConsensusTypes.TimeoutCertificate as TimeoutCertificate 8 | open import LibraBFT.Impl.OBM.Rust.RustTypes 9 | import LibraBFT.Impl.Types.CryptoProxies as CryptoProxies 10 | import LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures 11 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.Util.Crypto 14 | open import LibraBFT.ImplShared.Util.Dijkstra.All 15 | open import Optics.All 16 | open import Util.Hash 17 | import Util.KVMap as Map 18 | open import Util.Prelude 19 | 20 | module LibraBFT.Impl.Consensus.PendingVotes where 21 | 22 | insertVoteM : Vote → ValidatorVerifier → LBFT VoteReceptionResult 23 | insertVoteM vote vv = do 24 | let liDigest = hashLI (vote ^∙ vLedgerInfo) 25 | atv ← use (lPendingVotes ∙ pvAuthorToVote) 26 | caseMD Map.lookup (vote ^∙ vAuthor) atv of λ where 27 | (just previouslySeenVote) → 28 | ifD liDigest ≟Hash (hashLI (previouslySeenVote ^∙ vLedgerInfo)) 29 | then (do 30 | let newTimeoutVote = Vote.isTimeout vote ∧ not (Vote.isTimeout previouslySeenVote) 31 | if not newTimeoutVote 32 | then pure DuplicateVote 33 | else continue1 liDigest) 34 | else 35 | pure EquivocateVote 36 | nothing → 37 | continue1 liDigest 38 | 39 | where 40 | 41 | continue2 : U64 → LBFT VoteReceptionResult 42 | 43 | continue1 : HashValue → LBFT VoteReceptionResult 44 | continue1 liDigest = do 45 | pv ← use lPendingVotes 46 | lPendingVotes ∙ pvAuthorToVote %= Map.kvm-insert-Haskell (vote ^∙ vAuthor) vote 47 | let liWithSig = CryptoProxies.addToLi (vote ^∙ vAuthor) (vote ^∙ vSignature) 48 | (fromMaybe (LedgerInfoWithSignatures∙new (vote ^∙ vLedgerInfo) Map.empty) 49 | (Map.lookup liDigest (pv ^∙ pvLiDigestToVotes))) 50 | lPendingVotes ∙ pvLiDigestToVotes %= Map.kvm-insert-Haskell liDigest liWithSig 51 | case⊎D ValidatorVerifier.checkVotingPower vv (Map.kvm-keys (liWithSig ^∙ liwsSignatures)) of λ where 52 | (Right unit) → 53 | pure (NewQuorumCertificate (QuorumCert∙new (vote ^∙ vVoteData) liWithSig)) 54 | (Left (ErrVerify (TooLittleVotingPower votingPower _))) → 55 | continue2 votingPower 56 | (Left _) → 57 | pure VRR_TODO 58 | 59 | continue2 qcVotingPower = 60 | caseMD vote ^∙ vTimeoutSignature of λ where 61 | (just timeoutSignature) → do 62 | pv ← use lPendingVotes 63 | let partialTc = TimeoutCertificate.addSignature (vote ^∙ vAuthor) timeoutSignature 64 | (fromMaybe (TimeoutCertificate∙new (Vote.timeout vote)) 65 | (pv ^∙ pvMaybePartialTC)) 66 | lPendingVotes ∙ pvMaybePartialTC %= const (just partialTc) 67 | case⊎D ValidatorVerifier.checkVotingPower vv (Map.kvm-keys (partialTc ^∙ tcSignatures)) of λ where 68 | (Right unit) → 69 | pure (NewTimeoutCertificate partialTc) 70 | (Left (ErrVerify (TooLittleVotingPower votingPower _))) → 71 | pure (TCVoteAdded votingPower) 72 | (Left _) → 73 | pure VRR_TODO 74 | nothing → 75 | pure (QCVoteAdded qcVotingPower) 76 | 77 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/PersistentLivenessStorage.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Haskell.Modules.RWS 8 | open import Haskell.Modules.RWS.Lens 9 | open import Haskell.Modules.RWS.RustAnyHow 10 | open import LibraBFT.Base.Types 11 | import LibraBFT.Impl.Consensus.TestUtils.MockStorage as MockStorage 12 | open import LibraBFT.Impl.OBM.Logging.Logging 13 | open import LibraBFT.ImplShared.Base.Types 14 | open import LibraBFT.ImplShared.Consensus.Types 15 | open import LibraBFT.ImplShared.LBFT 16 | open import Optics.All 17 | open import Util.Prelude 18 | ------------------------------------------------------------------------------ 19 | open import Data.String using (String) 20 | 21 | module LibraBFT.Impl.Consensus.PersistentLivenessStorage where 22 | 23 | ------------------------------------------------------------------------------ 24 | 25 | obmUpdateM 26 | : ( PersistentLivenessStorage → LBFT (Either ErrLog PersistentLivenessStorage) ) 27 | → LBFT (Either ErrLog Unit) 28 | 29 | obmUpdateE 30 | : BlockStore 31 | → ( PersistentLivenessStorage 32 | → Either ErrLog PersistentLivenessStorage ) 33 | -> Either ErrLog BlockStore 34 | 35 | ------------------------------------------------------------------------------ 36 | 37 | saveTreeM : List Block → List QuorumCert → LBFT (Either ErrLog Unit) 38 | saveTreeM blocks qcs = 39 | obmUpdateM (MockStorage.saveTreeM blocks qcs) 40 | 41 | saveTreeE : BlockStore → List Block → List QuorumCert → Either ErrLog BlockStore 42 | saveTreeE bs blocks qcs = 43 | obmUpdateE bs (MockStorage.saveTreeE blocks qcs) 44 | 45 | pruneTreeM : List HashValue → LBFT (Either ErrLog Unit) 46 | pruneTreeM = 47 | obmUpdateM ∘ MockStorage.pruneTreeM 48 | 49 | saveVoteM : Vote → LBFT (Either ErrLog Unit) 50 | saveVoteM = 51 | obmUpdateM ∘ MockStorage.saveStateM 52 | 53 | startM : LBFT (Either ErrLog RecoveryData) 54 | startM = 55 | use (lBlockStore ∙ bsStorage) >>= λ s → pure (MockStorage.start s) ∙^∙ withErrCtx (here' []) 56 | where 57 | here' : List String → List String 58 | here' t = "PersistentLivenessStorage" ∷ "startM" ∷ t 59 | 60 | saveHighestTimeoutCertM : TimeoutCertificate → LBFT (Either ErrLog Unit) 61 | saveHighestTimeoutCertM = 62 | obmUpdateM ∘ MockStorage.saveHighestTimeoutCertificateM 63 | 64 | ------------------------------------------------------------------------------ 65 | 66 | obmUpdateM f = do 67 | s <- use (lBlockStore ∙ bsStorage) 68 | f s ∙?∙ λ s' → do lBlockStore ∙ bsStorage ∙= s'; ok unit 69 | 70 | obmUpdateE bs f = do 71 | let s = bs ^∙ bsStorage 72 | s' ← f s 73 | pure (bs & bsStorage ∙~ s') 74 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/PersistentLivenessStorage/Properties.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Impl.Consensus.PersistentLivenessStorage 9 | open import LibraBFT.Impl.Properties.Util 10 | open import LibraBFT.ImplShared.Base.Types 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import LibraBFT.ImplShared.Util.Dijkstra.All 13 | open import Optics.All 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Consensus.PersistentLivenessStorage.Properties where 17 | 18 | module saveVoteMSpec (vote : Vote) where 19 | open OutputProps 20 | postulate -- TODO-2: refine and prove 21 | contract 22 | : ∀ P pre 23 | → (∀ outs → NoMsgs outs → NoErrors outs → P (inj₁ fakeErr) pre outs) 24 | → (∀ outs → NoMsgs outs → NoErrors outs 25 | → P (inj₂ unit) pre outs) 26 | → RWS-weakestPre (saveVoteM vote) P unit pre 27 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Properties/ConsensusProvider.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.ConsensusProvider as ConsensusProvider 9 | open import LibraBFT.Impl.Properties.Util 10 | import LibraBFT.Impl.IO.OBM.GenKeyFile as GenKeyFile 11 | open import LibraBFT.Impl.OBM.Logging.Logging 12 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 13 | open import LibraBFT.ImplShared.Consensus.Types 14 | open import LibraBFT.ImplShared.Consensus.Types.EpochDep 15 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 16 | open import LibraBFT.ImplShared.Util.Dijkstra.All 17 | open import Optics.All 18 | open import Util.PKCS 19 | open import Util.Prelude hiding (_++_) 20 | 21 | module LibraBFT.Impl.Consensus.Properties.ConsensusProvider where 22 | 23 | open InitProofDefs 24 | 25 | module startConsensusSpec 26 | (nodeConfig : NodeConfig) 27 | (now : Instant) 28 | (payload : OnChainConfigPayload) 29 | (liws : LedgerInfoWithSignatures) 30 | (sk : SK) 31 | (needFetch : ObmNeedFetch) 32 | (propGen : ProposalGenerator) 33 | (stateComp : StateComputer) 34 | where 35 | 36 | -- TODO-2: Requires refinement 37 | postulate 38 | contract' : EitherD-weakestPre (ConsensusProvider.startConsensus-ed-abs 39 | nodeConfig now payload liws sk needFetch propGen stateComp) 40 | (InitContract nothing) 41 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/Properties/MetricsSafetyRules.agda: -------------------------------------------------------------------------------- 1 | open import LibraBFT.Impl.Consensus.MetricsSafetyRules 2 | open import LibraBFT.Impl.OBM.Logging.Logging 3 | open import LibraBFT.Impl.Properties.Util 4 | open import LibraBFT.ImplShared.Consensus.Types 5 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 6 | open import LibraBFT.ImplShared.Util.Dijkstra.All 7 | open import Optics.All 8 | open import Util.Prelude hiding (_++_) 9 | 10 | module LibraBFT.Impl.Consensus.Properties.MetricsSafetyRules where 11 | 12 | open Invariants 13 | 14 | module performInitializeSpec 15 | (safetyRules : SafetyRules) 16 | (storage : PersistentLivenessStorage) 17 | where 18 | 19 | record ContractOk (sr : SafetyRules) : Set where 20 | constructor mkContractOk 21 | field 22 | srPres : Preserves SafetyRulesInv safetyRules sr 23 | lvNothing : sr ^∙ srPersistentStorage ∙ pssSafetyData ∙ sdLastVote ≡ nothing 24 | open ContractOk 25 | 26 | Contract : EitherD-Post ErrLog SafetyRules 27 | Contract (Left _) = ⊤ 28 | Contract (Right sr) = ContractOk sr 29 | 30 | module _ (sri : SafetyRulesInv safetyRules) 31 | (lvNothing : safetyRules ^∙ srPersistentStorage ∙ pssSafetyData ∙ sdLastVote ≡ nothing) 32 | where 33 | -- TODO-2: Requires refinement 34 | postulate 35 | contract' : EitherD-weakestPre (performInitialize-ed-abs safetyRules storage) Contract 36 | 37 | contract : Contract (performInitialize-abs safetyRules storage) 38 | contract rewrite performInitialize-abs-≡ safetyRules storage = 39 | EitherD-contract (performInitialize-ed-abs safetyRules storage) Contract contract' 40 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/RecoveryData.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | Copyright (c) 2021, Oracle and/or its affiliates. 3 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 4 | -} 5 | 6 | import LibraBFT.Impl.Consensus.LedgerRecoveryData as LedgerRecoveryData 7 | open import LibraBFT.Impl.OBM.Logging.Logging 8 | open import LibraBFT.ImplShared.Consensus.Types 9 | open import Optics.All 10 | open import Util.Prelude 11 | ------------------------------------------------------------------------------ 12 | open import Data.String using (String) 13 | 14 | module LibraBFT.Impl.Consensus.RecoveryData where 15 | 16 | findBlocksToPrune 17 | : HashValue → List Block → List QuorumCert 18 | → (List HashValue × List Block × List QuorumCert) 19 | 20 | new 21 | : Maybe Vote 22 | → LedgerRecoveryData 23 | → List Block 24 | → RootMetadata 25 | → List QuorumCert 26 | → Maybe TimeoutCertificate 27 | → Either ErrLog RecoveryData 28 | new lastVote storageLedger blocks0 rootMetadata quorumCerts0 highestTimeoutCertificate = do 29 | (root@(RootInfo∙new rb _ _) , blocks1 , quorumCerts1) 30 | ← withErrCtx' (here' []) (LedgerRecoveryData.findRoot blocks0 quorumCerts0 storageLedger) 31 | let (blocksToPrune , blocks , quorumCerts) 32 | = findBlocksToPrune (rb ^∙ bId) blocks1 quorumCerts1 33 | epoch = rb ^∙ bEpoch 34 | pure $ mkRecoveryData 35 | (case lastVote of λ where 36 | (just v) → if-dec v ^∙ vEpoch ≟ epoch then just v else nothing 37 | nothing → nothing) 38 | root 39 | rootMetadata 40 | blocks 41 | quorumCerts 42 | (just blocksToPrune) 43 | (case highestTimeoutCertificate of λ where 44 | (just tc) → if-dec tc ^∙ tcEpoch ≟ epoch then just tc else nothing 45 | nothing → nothing) 46 | where 47 | here' : List String → List String 48 | here' t = "RecoveryData" ∷ "new" ∷ t 49 | 50 | -- TODO (the "TODO" is in the Haskell code) 51 | findBlocksToPrune _rootId blocks quorumCerts = ([] , blocks , quorumCerts) 52 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/SafetyRules/PersistentSafetyStorage.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | ------------------------------------------------------------------------------ 8 | import LibraBFT.Impl.OBM.Crypto as TODO 9 | open import LibraBFT.Impl.OBM.Logging.Logging 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | open import Util.PKCS 13 | open import Util.Prelude 14 | ------------------------------------------------------------------------------ 15 | open import Data.String using (String) 16 | ------------------------------------------------------------------------------ 17 | 18 | module LibraBFT.Impl.Consensus.SafetyRules.PersistentSafetyStorage where 19 | 20 | new : Author → Waypoint → SK → PersistentSafetyStorage 21 | new author waypoint sk = mkPersistentSafetyStorage 22 | {- _pssSafetyData =-} (SafetyData∙new 23 | {- _sdEpoch = Epoch-} 1 24 | {-, _sdLastVotedRound = Round-} 0 25 | {-, _sdPreferredRound = Round-} 0 26 | {-, _sdLastVote =-} nothing) 27 | {-, _pssAuthor =-} author 28 | {-, _pssWaypoint =-} waypoint 29 | {-, _pssObmSK =-} (just sk) 30 | 31 | consensusKeyForVersion : PersistentSafetyStorage → PK → Either ErrLog SK 32 | consensusKeyForVersion self pk = 33 | -- LBFT-OBM-DIFF 34 | maybeS (self ^∙ pssObmSK) (Left fakeErr {-"pssObmSK Nothing"-}) $ λ sk → 35 | if TODO.makePK sk /= pk 36 | then Left fakeErr -- ["sk /= pk"] 37 | else pure sk 38 | where 39 | here' : List String → List String 40 | here' t = "PersistentSafetyStorage" ∷ "consensusKeyForVersion" ∷ t 41 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/SafetyRules/SafetyRulesManager.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | ------------------------------------------------------------------------------ 8 | import LibraBFT.Impl.Consensus.SafetyRules.PersistentSafetyStorage as PersistentSafetyStorage 9 | import LibraBFT.Impl.Consensus.SafetyRules.SafetyRules as SafetyRules 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | open import Util.PKCS 13 | open import Util.Prelude 14 | ------------------------------------------------------------------------------ 15 | 16 | module LibraBFT.Impl.Consensus.SafetyRules.SafetyRulesManager where 17 | 18 | storage 19 | : SafetyRulesConfig -> Author -> SK 20 | → Either ErrLog PersistentSafetyStorage 21 | storage config obmMe obmSK = do 22 | pure $ PersistentSafetyStorage.new -- internalStorage 23 | obmMe 24 | (config ^∙ srcObmGenesisWaypoint) 25 | obmSK 26 | 27 | newLocal : PersistentSafetyStorage → Bool → Either ErrLog SafetyRulesManager 28 | 29 | new 30 | : SafetyRulesConfig → Author → SK 31 | → Either ErrLog SafetyRulesManager 32 | new config obmMe obmSK = do 33 | storage0 ← storage config obmMe obmSK 34 | let exportConsensusKey = config ^∙ srcExportConsensusKey 35 | case config ^∙ srcService of λ where 36 | SRSLocal → newLocal storage0 exportConsensusKey 37 | 38 | newLocal storage0 exportConsensusKey = do 39 | safetyRules ← SafetyRules.new storage0 exportConsensusKey 40 | pure (mkSafetyRulesManager (SRWLocal safetyRules)) 41 | 42 | client : SafetyRulesManager → SafetyRules 43 | client self = case self ^∙ srmInternalSafetyRules of λ where 44 | (SRWLocal safetyRules) → safetyRules 45 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/StateComputerByteString.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.OBM.ConfigHardCoded as ConfigHardCoded 9 | open import LibraBFT.Impl.OBM.Logging.Logging 10 | import LibraBFT.Impl.Storage.DiemDB.DiemDB as DiemDB 11 | import LibraBFT.Impl.Types.OnChainConfig.ValidatorSet as ValidatorSet 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import Optics.All 14 | open import Util.ByteString as BS 15 | import Util.Encode as S 16 | open import Util.Hash 17 | open import Util.Prelude 18 | ------------------------------------------------------------------------------ 19 | open import Data.String using (String) 20 | 21 | module LibraBFT.Impl.Consensus.StateComputerByteString where 22 | 23 | -- LBFT-OBM-DIFF: In Rust, the following might throw BlockNotFound 24 | -- in execution_correctness_client.execute_block (not needed/implemented). 25 | -- In OBM we call this error ErrECCBlockNotFound so it is easy to see it is 26 | -- defined, caught, but never thrown. 27 | compute : StateComputerComputeType 28 | compute _self block _parentBlockId = 29 | StateComputeResult∙new 30 | (Version∙new (block ^∙ bEpoch {-∙ eEpoch-}) (block ^∙ bRound {-∙ rRound-})) 31 | <$> maybeEC 32 | where 33 | getES : ByteString → Either (List String) EpochState 34 | 35 | maybeEC : Either (List String) (Maybe EpochState) 36 | maybeEC = case block ^∙ bBlockData ∙ bdBlockType of λ where 37 | (Proposal {-Payload [-}a{-])-} _author) → 38 | if BS∙isPrefixOf ConfigHardCoded.ePOCHCHANGE a then just <$> getES a else pure nothing 39 | NilBlock → pure nothing 40 | Genesis → pure nothing 41 | 42 | getES bs = do 43 | let bs' = BS∙drop (BS∙length ConfigHardCoded.ePOCHCHANGE) bs 44 | case S.decode bs' of λ where 45 | (Left e) → Left ("StateComputerByteString" ∷ "compute" ∷ "decode" ∷ {-T.pack-} e ∷ []) 46 | (Right vv) → Right (EpochState∙new (block ^∙ bEpoch + 1) vv) 47 | 48 | -- LBFT-OBM-DIFF : gets block instead of vector of hashes 49 | -- TODO-2: consider converting to EitherD before proving anything about this 50 | commit : StateComputerCommitType 51 | commit self db (ExecutedBlock∙new _b (StateComputeResult∙new version _)) liws = 52 | case (DiemDB.saveTransactions.E db (just liws)) of λ where 53 | (Left e) → Left (errText e) 54 | (Right db') → pure 55 | ( (self & scObmVersion ∙~ version) 56 | , db' 57 | , (maybeS (liws ^∙ liwsLedgerInfo ∙ liNextEpochState) nothing $ λ (EpochState∙new e vv) → 58 | just (ReconfigEventEpochChange∙new 59 | (OnChainConfigPayload∙new e (ValidatorSet.obmFromVV vv)))) 60 | ) 61 | 62 | -- LBFT-OBM-DIFF : completely different 63 | syncTo : StateComputerSyncToType 64 | syncTo liws = 65 | maybeS (liws ^∙ liwsNextEpochState) (Left ("StateComputerByteString" ∷ "syncTo" ∷ "Nothing" ∷ [])) $ 66 | λ (EpochState∙new e vv) → 67 | Right (ReconfigEventEpochChange∙new 68 | (OnChainConfigPayload∙new e (ValidatorSet.obmFromVV vv))) 69 | 70 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Consensus/TestUtils/MockSharedStorage.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | open import Optics.All 9 | import Util.KVMap as Map 10 | open import Util.Prelude 11 | 12 | module LibraBFT.Impl.Consensus.TestUtils.MockSharedStorage where 13 | 14 | new : ValidatorSet → MockSharedStorage 15 | new = mkMockSharedStorage 16 | Map.empty 17 | Map.empty 18 | Map.empty 19 | nothing 20 | nothing 21 | 22 | newObmWithLIWS : ValidatorSet → LedgerInfoWithSignatures → MockSharedStorage 23 | newObmWithLIWS vs obmLIWS = 24 | new vs & mssLis ∙~ Map.singleton (obmLIWS ^∙ liwsVersion) obmLIWS 25 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Crypto/Crypto/Hash.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | 9 | module LibraBFT.Impl.Crypto.Crypto.Hash where 10 | 11 | postulate -- TODO-1: valueZero 12 | valueZero : HashValue 13 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Execution/ExecutorTypes/StateComputeResult.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | open import Optics.All 9 | 10 | module LibraBFT.Impl.Execution.ExecutorTypes.StateComputeResult where 11 | 12 | extensionProof : StateComputeResult → AccumulatorExtensionProof 13 | extensionProof self = AccumulatorExtensionProof∙new (self ^∙ scrObmNumLeaves) 14 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/GenKeyFile.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | import LibraBFT.Impl.OBM.Genesis as Genesis 8 | open import LibraBFT.Impl.OBM.Rust.RustTypes 9 | open import LibraBFT.Impl.OBM.Util 10 | import LibraBFT.Impl.Types.OnChainConfig.ValidatorSet as ValidatorSet 11 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 12 | open import LibraBFT.Impl.OBM.Rust.RustTypes 13 | open import LibraBFT.Impl.OBM.Util 14 | import LibraBFT.Impl.Types.OnChainConfig.ValidatorSet as ValidatorSet 15 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 16 | open import LibraBFT.ImplShared.Base.Types 17 | open import LibraBFT.ImplShared.Consensus.Types 18 | open import Util.PKCS 19 | open import Util.Prelude 20 | 21 | module LibraBFT.Impl.IO.OBM.GenKeyFile where 22 | 23 | ------------------------------------------------------------------------------ 24 | 25 | EndpointAddress = Author 26 | AddressToSkAndPkAssocList = List (EndpointAddress × (SK × PK)) 27 | 28 | ------------------------------------------------------------------------------ 29 | genKeys : {-Crypto.SystemDRG →-} ℕ → List (SK × PK) 30 | mkAuthors : {-Crypto.SystemDRG →-} U64 → List EndpointAddress 31 | → Either ErrLog AddressToSkAndPkAssocList 32 | mkValidatorSignersAndVerifierAndProposerElection 33 | : U64 → AddressToSkAndPkAssocList 34 | → Either ErrLog (List ValidatorSigner × ValidatorVerifier × ProposerElection) 35 | ------------------------------------------------------------------------------ 36 | 37 | NfLiwsVssVvPe = 38 | (U64 × LedgerInfoWithSignatures × List ValidatorSigner × ValidatorVerifier × ProposerElection) 39 | 40 | NfLiwsVsVvPe = 41 | (U64 × LedgerInfoWithSignatures × ValidatorSigner × ValidatorVerifier × ProposerElection) 42 | 43 | create' 44 | : U64 → List EndpointAddress {-→ SystemDRG-} 45 | → Either ErrLog 46 | ( U64 × AddressToSkAndPkAssocList 47 | × List ValidatorSigner × ValidatorVerifier × ProposerElection × LedgerInfoWithSignatures ) 48 | create' numFailures addresses {-drg-} = do 49 | authors ← mkAuthors {-drg-} numFailures addresses 50 | (s , vv , pe) ← mkValidatorSignersAndVerifierAndProposerElection numFailures authors 51 | case Genesis.obmMkGenesisLedgerInfoWithSignatures s (ValidatorSet.obmFromVV vv) of λ where 52 | (Left err) → Left err 53 | (Right liws) → pure (numFailures , authors , s , vv , pe , liws) 54 | 55 | abstract 56 | create = create' 57 | create≡ : create ≡ create' 58 | create≡ = refl 59 | 60 | mkAuthors {-drg-} numFailures0 addresses0 = do 61 | addrs <- checkAddresses 62 | checkBftAndRun numFailures0 addrs f 63 | where 64 | f : ℕ → List EndpointAddress → AddressToSkAndPkAssocList 65 | f _numFailures addresses = zip addresses (genKeys {-drg-} (length addresses)) 66 | checkAddresses : Either ErrLog (List EndpointAddress) 67 | checkAddresses = pure addresses0 68 | 69 | postulate -- Valid assumption: secret and public keys for each NodeId 70 | mkSK : NodeId → SK 71 | mkPK : NodeId → PK 72 | 73 | genKeys zero = [] 74 | genKeys x@(suc n) = (mkSK x , mkPK x) ∷ genKeys n 75 | 76 | mkValidatorSignersAndVerifierAndProposerElection numFaults ks = do 77 | -- IMPL-DIFF: Agda Author type does NOT contain a PK 78 | let allAuthors = fmap fst ks 79 | validatorVerifier ← ValidatorVerifier.initValidatorVerifier numFaults ks 80 | let authorKeyPairs = fmap (λ (a , (sk , _)) → (a , sk)) ks 81 | validatorSigners = foldl' go [] authorKeyPairs 82 | pure (validatorSigners , validatorVerifier , ProposerElection∙new allAuthors) 83 | where 84 | go : List ValidatorSigner → (Author × SK) → List ValidatorSigner 85 | go acc (author , sk) = ValidatorSigner∙new author sk ∷ acc 86 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/InputOutputHandlers.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Consensus.Network as Network 9 | import LibraBFT.Impl.Consensus.RoundManager as RoundManager 10 | open import LibraBFT.Impl.OBM.Logging.Logging 11 | open import LibraBFT.ImplShared.Consensus.Types 12 | open import LibraBFT.ImplShared.Util.Dijkstra.All 13 | open import Optics.All 14 | open import Util.Prelude 15 | 16 | -- This module defines the handler for our implementation. For most message types, it does some 17 | -- initial validation before passing the message on to the proper handlers. 18 | 19 | module LibraBFT.Impl.IO.OBM.InputOutputHandlers where 20 | 21 | epvv : LBFT (Epoch × ValidatorVerifier) 22 | epvv = _,_ <$> gets (_^∙ rmSafetyRules ∙ srPersistentStorage ∙ pssSafetyData ∙ sdEpoch) 23 | <*> gets (_^∙ rmEpochState ∙ esVerifier) 24 | 25 | module handleProposal (now : Instant) (pm : ProposalMsg) where 26 | step₀ : LBFT Unit 27 | step₁ : Epoch → ValidatorVerifier → LBFT Unit 28 | 29 | step₀ = do 30 | (myEpoch , vv) ← epvv 31 | step₁ myEpoch vv 32 | 33 | step₁ myEpoch vv = do 34 | case⊎D Network.processProposal {- {!!} -} pm myEpoch vv of λ where 35 | (Left (Left e)) → logErr e 36 | (Left (Right i)) → logInfo i 37 | (Right _) → RoundManager.processProposalMsgM now pm 38 | 39 | handleProposal : Instant → ProposalMsg → LBFT Unit 40 | handleProposal = handleProposal.step₀ 41 | 42 | module handleVote (now : Instant) (vm : VoteMsg) where 43 | step₀ : LBFT Unit 44 | step₁ : Epoch → ValidatorVerifier → LBFT Unit 45 | 46 | step₀ = do 47 | (myEpoch , vv) ← epvv 48 | step₁ myEpoch vv 49 | 50 | step₁ myEpoch vv = do 51 | case Network.processVote vm myEpoch vv of λ where 52 | (Left (Left e)) → logErr e 53 | (Left (Right i)) → logInfo i 54 | (Right _) → RoundManager.processVoteMsgM now vm 55 | 56 | abstract 57 | handleVote = handleVote.step₀ 58 | 59 | handleVote≡ : handleVote ≡ handleVote.step₀ 60 | handleVote≡ = refl 61 | 62 | handle : NodeId → NetworkMsg → Instant → LBFT Unit 63 | handle _self msg now = 64 | case msg of λ where 65 | (P pm) → handleProposal now pm 66 | (V vm) → handleVote now vm 67 | (C cm) → pure unit -- We don't do anything with commit messages, they are just for defining Correctness. 68 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/Messages.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.ImplShared.Consensus.Types 9 | ------------------------------------------------------------------------------ 10 | open import Data.String using (String) 11 | 12 | module LibraBFT.Impl.IO.OBM.Messages where 13 | 14 | record ECPWire : Set where 15 | constructor ECPWire∙new 16 | field 17 | --_ecpwWhy : Text -- for log visualization 18 | --_ecpwEpoch : Epoch -- for log visualization; epoch of sender 19 | --_ecpwRound : Round -- for log visualization; round of sender 20 | _ecpwECP : EpochChangeProof 21 | -- instance S.Serialize ECPWire 22 | 23 | record EpRRqWire : Set where 24 | constructor EpRRqWire∙new 25 | field 26 | --_eprrqwWhy : Text -- for log visualization 27 | --_eprrqEpoch : Epoch -- for log visualization; epoch of sender 28 | --_eprrqRound : Round -- for log visualization; round of sender 29 | _eprrqEpRRq : EpochRetrievalRequest 30 | -- instance S.Serialize EpRRqWire 31 | 32 | data Input : Set where 33 | IBlockRetrievalRequest : Instant → BlockRetrievalRequest → Input 34 | IBlockRetrievalResponse : Instant → BlockRetrievalResponse → Input 35 | IEpochChangeProof : AccountAddress → ECPWire → Input 36 | IEpochRetrievalRequest : AccountAddress → EpRRqWire → Input 37 | IInit : Instant → Input 38 | IProposal : Instant → AccountAddress → ProposalMsg → Input 39 | IReconfigLocalEpochChange : ReconfigEventEpochChange → Input 40 | ISyncInfo : Instant → AccountAddress → SyncInfo → Input 41 | ITimeout : Instant → String {-String is ThreadId-} → Epoch → Round → Input 42 | IVote : Instant → AccountAddress → VoteMsg → Input 43 | 44 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/ObmNeedFetch.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | 9 | module LibraBFT.Impl.IO.OBM.ObmNeedFetch where 10 | 11 | {- 12 | The functions in this module are used when a node needs to catchup. 13 | 14 | TODO-3: model catchup request/response in Agda. 15 | 16 | In haskell, for each message received from the network (including messages to self), 17 | each message is processed in a single thread that completes the processing 18 | before then processing a subsequent message. 19 | 20 | However, a node detects that it needs to catchup "in the middle" of that processing. 21 | In Haskell we use unsafePerformIO to send a network request to other nodes asking 22 | for "catchup" data. 23 | 24 | The responses are received by a different thread that then feeds them to the waiting thread, 25 | which then proceeds. 26 | -} 27 | 28 | postulate -- TODO-3: writeRequestReadResponseUNSAFE 29 | writeRequestReadResponseUNSAFE 30 | : ObmNeedFetch → Author → Author → BlockRetrievalRequest 31 | → BlockRetrievalResponse 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/Properties/Start.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Concrete.Records 9 | open import LibraBFT.Concrete.System 10 | open import LibraBFT.Concrete.System.Parameters 11 | open import LibraBFT.Impl.Consensus.ConsensusProvider as ConsensusProvider 12 | open import LibraBFT.Impl.Consensus.Properties.ConsensusProvider as ConsensusProviderProps 13 | import LibraBFT.Impl.IO.OBM.GenKeyFile as GenKeyFile 14 | open import LibraBFT.Impl.IO.OBM.InputOutputHandlers 15 | open import LibraBFT.Impl.IO.OBM.Start 16 | open import LibraBFT.Impl.OBM.Logging.Logging 17 | open import LibraBFT.Impl.Properties.Util 18 | open import LibraBFT.ImplShared.Base.Types 19 | open import LibraBFT.ImplShared.Consensus.Types 20 | open import LibraBFT.ImplShared.Interface.Output 21 | open import LibraBFT.ImplShared.NetworkMsg 22 | open import LibraBFT.ImplShared.Util.Dijkstra.All 23 | open import Optics.All 24 | open import Util.PKCS 25 | open import Util.Prelude 26 | open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms 27 | 28 | open Invariants 29 | open RoundManagerTransProps 30 | open InitProofDefs 31 | 32 | module LibraBFT.Impl.IO.OBM.Properties.Start where 33 | 34 | module startViaConsensusProviderSpec 35 | (now : Instant) 36 | (nfl : GenKeyFile.NfLiwsVsVvPe) 37 | (txTDS : TxTypeDependentStuffForNetwork) 38 | where 39 | -- It is somewhat of an overkill to write a separate contract for the last step, 40 | -- but keeping it explicit for pedagogical reasons 41 | contract-step₁ : ∀ (tup : (NodeConfig × OnChainConfigPayload × LedgerInfoWithSignatures × SK × ProposerElection)) 42 | → EitherD-weakestPre (startViaConsensusProvider-ed.step₁ now nfl txTDS tup) (InitContract nothing) 43 | contract-step₁ (nodeConfig , payload , liws , sk , pe) = 44 | startConsensusSpec.contract' nodeConfig now payload liws sk ObmNeedFetch∙new 45 | (txTDS ^∙ ttdsnProposalGenerator) (txTDS ^∙ ttdsnStateComputer) 46 | 47 | contract' : EitherD-weakestPre (startViaConsensusProvider-ed-abs now nfl txTDS) (InitContract nothing) 48 | contract' rewrite startViaConsensusProvider-ed-abs-≡ = 49 | -- TODO-2: this is silly; perhaps we should have an EitherD-⇒-bind-const or something for when 50 | -- we don't need to know anything about the values returned by part before the bind? 51 | EitherD-⇒-bind (ConsensusProvider.obmInitialData-ed-abs nfl) 52 | (EitherD-vacuous (ConsensusProvider.obmInitialData-ed-abs nfl)) 53 | P⇒Q 54 | where 55 | P⇒Q : EitherD-Post-⇒ (const Unit) (EitherD-weakestPre-bindPost _ (InitContract nothing)) 56 | P⇒Q (Left _) _ = tt 57 | P⇒Q (Right tup') _ c refl = contract-step₁ tup' 58 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/IO/OBM/Start.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.Consensus.EpochManagerTypes 8 | import LibraBFT.Impl.Consensus.ConsensusProvider as ConsensusProvider 9 | import LibraBFT.Impl.IO.OBM.GenKeyFile as GenKeyFile 10 | import LibraBFT.Impl.IO.OBM.ObmNeedFetch as ObmNeedFetch 11 | import LibraBFT.Impl.Types.ValidatorSigner as ValidatorSigner 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.Interface.Output 14 | open import LibraBFT.ImplShared.Util.Dijkstra.All 15 | open import Optics.All 16 | open import Util.PKCS 17 | open import Util.Prelude 18 | 19 | module LibraBFT.Impl.IO.OBM.Start where 20 | 21 | {- 22 | This only does the initialization steps from the Haskell version. 23 | If initialization succeeds, it returns 24 | - the EpochManager (for all epochs) 25 | - note: this contains the initialized RoundManager for the current epoch (i.e., Epoch 0) 26 | - any output from the RoundManager produced during initialization 27 | 28 | The only output is (with info logging removed): 29 | 30 | -- only the leader of round 1 will broadcast a proposal 31 | BroadcastProposal; [ ... peer addresses ... ]; 32 | (ProposalMsg 33 | (B 7194dca (BD 1 1 (Prop ("TX/1/1")) ...)) -- proposed block 34 | (SI (hqc c66a132) (hcc N) (htc (TC N)))) -- SyncInfo 35 | 36 | The Haskell code, after initialization, hooks up the communication channels and sockets 37 | and starts threads that handle them. One of the threads is given to 38 | EpochManager.obmStartLoop to get input and pass it through the EpochManager 39 | and then (usually) on to the RoundMnager. 40 | 41 | TODO-3: Replace 'Handle.initRM' with the initialized RoundManager obtained 42 | through the following 'startViaConsensusProvider'. 43 | TODO-3: Figure out how to handle the initial BroadcastProposal. 44 | -} 45 | module startViaConsensusProvider-ed 46 | (now : Instant) 47 | (nfl : GenKeyFile.NfLiwsVsVvPe) 48 | (txTDS : TxTypeDependentStuffForNetwork) 49 | where 50 | step₁ : (NodeConfig × OnChainConfigPayload × LedgerInfoWithSignatures × SK × ProposerElection) 51 | → EitherD ErrLog (EpochManager × List Output) 52 | 53 | step₀ : EitherD ErrLog (EpochManager × List Output) 54 | step₀ = do 55 | let (nf , liws , vs , vv , pe) = nfl 56 | (nc , occp , liws , sk , pe) ← ConsensusProvider.obmInitialData-ed-abs (nf , liws , vs , vv , pe) 57 | step₁ (nc , occp , liws , sk , pe) 58 | step₁ (nc , occp , liws' , sk , _) = 59 | ConsensusProvider.startConsensus-ed-abs 60 | nc now occp liws' sk 61 | (ObmNeedFetch∙new {- newNetwork -stps'-}) 62 | (txTDS ^∙ ttdsnProposalGenerator) (txTDS ^∙ ttdsnStateComputer) 63 | 64 | abstract 65 | startViaConsensusProvider-ed-abs = startViaConsensusProvider-ed.step₀ 66 | startViaConsensusProvider-ed-abs-≡ : startViaConsensusProvider-ed-abs ≡ startViaConsensusProvider-ed.step₀ 67 | startViaConsensusProvider-ed-abs-≡ = refl 68 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/ConfigHardCoded.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.OBM.Rust.RustTypes 8 | open import Util.ByteString 9 | 10 | module LibraBFT.Impl.OBM.ConfigHardCoded where 11 | 12 | ------------------------------------------------------------------------------ 13 | 14 | postulate -- TODO-1 ePOCHCHANGE 15 | ePOCHCHANGE : ByteString 16 | --ePOCHCHANGE = "EPOCHCHANGE" 17 | 18 | ------------------------------------------------------------------------------ 19 | 20 | maxPrunedBlocksInMem : Usize 21 | maxPrunedBlocksInMem = 10 22 | 23 | roundInitialTimeoutMS : U64 24 | roundInitialTimeoutMS = 3000 25 | 26 | ------------------------------------------------------------------------------ 27 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Crypto.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | open import Util.Encode 9 | open import Util.PKCS as PKCS hiding (sign; verify) 10 | open import Util.Prelude 11 | 12 | module LibraBFT.Impl.OBM.Crypto where 13 | 14 | ------------------------------------------------------------------------------ 15 | -- keys 16 | 17 | postulate -- TODO-1 : makePK 18 | makePK : SK → PK 19 | 20 | ------------------------------------------------------------------------------ 21 | 22 | postulate -- TODO-1: implement obmHashVersion 23 | obmHashVersion : Version → HashValue 24 | 25 | ------------------------------------------------------------------------------ 26 | -- sign and verify 27 | 28 | record CryptoHash (A : Set) : Set where 29 | field 30 | sign : SK → A → Signature 31 | verify : {-Text-} PK → Signature → A → Either ErrLog Unit 32 | ⦃ encodeA ⦄ : Encoder A 33 | 34 | open CryptoHash ⦃ ... ⦄ public 35 | 36 | instance 37 | CryptoHashBlockData : CryptoHash BlockData 38 | CryptoHashBlockData = record 39 | { sign = λ sk bd → PKCS.sign-raw (encode bd) sk 40 | ; verify = λ pk sig bd → if PKCS.verify (encode bd) sig pk 41 | then Right unit 42 | else Left fakeErr } 43 | 44 | instance 45 | CryptoHashLedgerInfo : CryptoHash LedgerInfo 46 | CryptoHashLedgerInfo = record 47 | { sign = λ sk li → PKCS.sign-raw (encode li) sk 48 | ; verify = λ pk sig li → if PKCS.verify (encode li) sig pk 49 | then Right unit 50 | else Left fakeErr } 51 | 52 | instance 53 | CryptoHashTimeout : CryptoHash Timeout 54 | CryptoHashTimeout = record 55 | { sign = λ sk to → PKCS.sign-raw (encode to) sk 56 | ; verify = λ pk sig to → if PKCS.verify (encode to) sig pk 57 | then Right unit 58 | else Left fakeErr } 59 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/ECP-LBFT-OBM-Diff/ECP-LBFT-OBM-Diff-0.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.Prelude 8 | 9 | module LibraBFT.Impl.OBM.ECP-LBFT-OBM-Diff.ECP-LBFT-OBM-Diff-0 where 10 | 11 | enabled : Bool 12 | enabled = true 13 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/ECP-LBFT-OBM-Diff/ECP-LBFT-OBM-Diff-2.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.OBM.ECP-LBFT-OBM-Diff.ECP-LBFT-OBM-Diff-0 as ECP-LBFT-OBM-Diff-0 9 | open import Util.Prelude 10 | 11 | module LibraBFT.Impl.OBM.ECP-LBFT-OBM-Diff.ECP-LBFT-OBM-Diff-2 where 12 | 13 | -- This is a separate file to avoid a cyclic dependency. 14 | 15 | ------------------------------------------------------------------------------ 16 | 17 | e_DiemDB_getEpochEndingLedgerInfosImpl_limit : Epoch → Epoch → Epoch → (Epoch × Bool) 18 | e_DiemDB_getEpochEndingLedgerInfosImpl_limit startEpoch endEpoch limit = 19 | if not ECP-LBFT-OBM-Diff-0.enabled 20 | then 21 | if-dec endEpoch >? startEpoch + limit 22 | then (startEpoch + limit , true) 23 | else (endEpoch , false) 24 | else (endEpoch , false) 25 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Genesis.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | import LibraBFT.Impl.Types.CryptoProxies as CryptoProxies 8 | import LibraBFT.Impl.Types.LedgerInfo as LedgerInfo 9 | import LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures 10 | import LibraBFT.Impl.Types.ValidatorSigner as ValidatorSigner 11 | import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 12 | open import LibraBFT.ImplShared.Consensus.Types 13 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 14 | open import Optics.All 15 | open import Util.Prelude 16 | 17 | module LibraBFT.Impl.OBM.Genesis where 18 | 19 | ------------------------------------------------------------------------------ 20 | 21 | obmMkLedgerInfoWithEpochState : ValidatorSet → Either ErrLog LedgerInfo 22 | 23 | ------------------------------------------------------------------------------ 24 | 25 | obmMkGenesisLedgerInfoWithSignatures 26 | : List ValidatorSigner → ValidatorSet → Either ErrLog LedgerInfoWithSignatures 27 | obmMkGenesisLedgerInfoWithSignatures vss0 vs0 = do 28 | liwes ← obmMkLedgerInfoWithEpochState vs0 29 | let sigs = fmap (λ vs → (vs ^∙ vsAuthor , ValidatorSigner.sign vs liwes)) vss0 30 | pure $ foldl' (λ acc (a , sig) → CryptoProxies.addToLi a sig acc) 31 | (LedgerInfoWithSignatures.obmNewNoSigs liwes) 32 | sigs 33 | 34 | obmMkLedgerInfoWithEpochState vs = do 35 | li ← LedgerInfo.mockGenesis (just vs) 36 | vv ← ValidatorVerifier.from-e-abs vs 37 | pure (li 38 | & liCommitInfo ∙ biNextEpochState 39 | ?~ EpochState∙new (li ^∙ liEpoch) vv) 40 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Logging/Logging.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Haskell.Modules.RWS 8 | open import LibraBFT.ImplShared.Consensus.Types 9 | open import LibraBFT.ImplShared.Interface.Output 10 | open import LibraBFT.ImplShared.Util.Dijkstra.All 11 | open import Util.Prelude 12 | ------------------------------------------------------------------------------ 13 | open import Data.String using (String) 14 | 15 | module LibraBFT.Impl.OBM.Logging.Logging where 16 | 17 | -- NOTE: Logging operations change the structure of the program, and proofs about peer 18 | -- operations are sensitive to this structure. Therefore, we add a "skeleton" of 19 | -- logging operations so that future refinements do not break existing proofs. 20 | -- In the future, we may wish to model and reason about errors and logging in more detail. 21 | 22 | postulate -- TODO-1 : errText : Note, the existing Agda ErrLog constructors do not contain text. 23 | errText : ErrLog → List String 24 | errText' : ErrLog → String 25 | 26 | logErr : ErrLog → LBFT Unit 27 | logErr x = tell (LogErr x ∷ []) 28 | 29 | logInfo : InfoLog → LBFT Unit 30 | logInfo x = tell (LogInfo x ∷ []) 31 | 32 | logEE : ∀ {A} → List String → LBFT A → LBFT A 33 | logEE _ f = logInfo fakeInfo >> f >>= λ r → logInfo fakeInfo >> pure r 34 | 35 | withErrCtx : List String → ErrLog → ErrLog 36 | withErrCtx _ = id 37 | 38 | withErrCtx' : ∀ {A} → List String → Either ErrLog A → Either ErrLog A 39 | withErrCtx' ctx = λ where 40 | (Left e) → Left (withErrCtx ctx e) 41 | (Right b) → pure b 42 | 43 | withErrCtxD' 44 | : ∀ {ℓ} {E : Set → Set → Set ℓ} ⦃ _ : EitherLike E ⦄ 45 | → ∀ {A : Set} → List String → E ErrLog A → EitherD ErrLog A 46 | withErrCtxD' ctx e = case toEither e of λ where 47 | (Left e) → fromEither $ Left (withErrCtx ctx e) 48 | (Right b) → fromEither $ Right b 49 | 50 | lcheck : ∀ {ℓ} {B : Set ℓ} ⦃ _ : ToBool B ⦄ → B → List String → Either ErrLog Unit 51 | lcheck b t = case check (toBool b) t of λ where 52 | (Left e) → Left fakeErr -- (ErrL [e]) 53 | (Right r) → Right r 54 | 55 | lcheckInfo : ∀ {ℓ} {B : Set ℓ} ⦃ _ : ToBool B ⦄ → B → List String → Either ErrLog Unit 56 | 57 | lcheckInfo b t = case check (toBool b) t of λ where 58 | (Left _) → Left (ErrInfo fakeInfo {-InfoL [e]-}) 59 | (Right r) → Right r 60 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Prelude.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.KVMap as Map 8 | open import Util.Prelude 9 | 10 | module LibraBFT.Impl.OBM.Prelude where 11 | 12 | lookupOrInsert : ∀ {K V : Set} → K → V → Map.KVMap K V → Map.KVMap K V 13 | lookupOrInsert k v m = 14 | if Map.kvm-member k m 15 | then m 16 | else Map.insert k v m 17 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Rust/Duration.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.OBM.Rust.RustTypes 8 | 9 | module LibraBFT.Impl.OBM.Rust.Duration where 10 | 11 | record Duration : Set where 12 | constructor Duration∙new 13 | 14 | postulate -- TODO-1 : fromMillis, asMillis 15 | fromMillis : U64 → Duration 16 | asMillis : Duration → U128 17 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Rust/RustTypes.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.Prelude 8 | ------------------------------------------------------------------------------ 9 | open import Agda.Builtin.Float 10 | 11 | module LibraBFT.Impl.OBM.Rust.RustTypes where 12 | 13 | -- TODO-2 : reasoning about integer overflow 14 | 15 | F64 : Set 16 | F64 = Float -- This is 'Double' in Haskell. In Agda, 'Float' is represented as a Haskell 'Double'. 17 | 18 | U64 : Set 19 | U64 = ℕ 20 | 21 | U128 : Set 22 | U128 = ℕ 23 | 24 | Usize : Set 25 | Usize = ℕ 26 | 27 | postulate -- TODO-1: VecDeque, vdNew 28 | VecDeque : Set 29 | vdNew : VecDeque 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Time.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.OBM.Rust.Duration as Duration 8 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 9 | open import Util.Prelude 10 | 11 | module LibraBFT.Impl.OBM.Time where 12 | 13 | postulate -- TODO-1 : iPlus, timeT 14 | iPlus : Instant → Duration → Instant 15 | timeT : Instant 16 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/OBM/Util.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Impl.OBM.Rust.RustTypes 8 | open import LibraBFT.ImplShared.Consensus.Types 9 | open import LibraBFT.ImplShared.Consensus.Types.EpochIndep 10 | open import Util.Prelude 11 | 12 | module LibraBFT.Impl.OBM.Util where 13 | 14 | -- To tolerate f failures, cluster must contain at least n ≥ 3f + 1 nodes, 15 | -- where n − f nodes form a quorum, assuming 1 vote per node. 16 | -- Note: our Haskell implementation and our model of it support non-uniform voting power, 17 | -- that is NOT reflected in these functions, but is reflected in functions in ValidatorVerifier. 18 | 19 | numNodesNeededForNFailures : U64 -> U64 20 | numNodesNeededForNFailures numFaultsAllowed = 3 * numFaultsAllowed + 1 21 | 22 | checkBftAndRun : ∀ {names : Set} {b : Set} 23 | → U64 → List names → (U64 → List names → b) 24 | → Either ErrLog b 25 | checkBftAndRun numFailures authors f = 26 | if-dec length authors Either ErrLog Epoch 28 | epoch self = maybeS (headMay (self ^∙ ecpLedgerInfoWithSigs)) 29 | (Left fakeErr {-["EpochChangeProof", "epoch", "empty"]-}) 30 | (pure ∘ (_^∙ liwsLedgerInfo ∙ liEpoch)) 31 | 32 | obmLastEpoch : EpochChangeProof → Epoch 33 | obmLastEpoch self = eitherS (obmLastLIWS self) (const ({-Epoch-} 0)) (_^∙ liwsLedgerInfo ∙ liEpoch) 34 | 35 | verify 36 | : {verifier : Set} ⦃ _ : Verifier.Verifier verifier ⦄ 37 | → EpochChangeProof → verifier 38 | → Either ErrLog LedgerInfoWithSignatures 39 | verify self verifier = do 40 | lcheck (not (null (self ^∙ ecpLedgerInfoWithSigs))) 41 | (here' ("empty" ∷ [])) 42 | lastLedgerInfoWithSigs ← last (self ^∙ ecpLedgerInfoWithSigs) 43 | lcheckInfo (not (Verifier.isLedgerInfoStale verifier (lastLedgerInfoWithSigs ^∙ liwsLedgerInfo))) 44 | (here' ("stale" ∷ [])) 45 | -- Skip stale ledger infos in the proof prefix. 46 | let ledgerInfosWithSigs = 47 | List.boolFilter 48 | (λ liws → not (Verifier.isLedgerInfoStale verifier (liws ^∙ liwsLedgerInfo))) 49 | (self ^∙ ecpLedgerInfoWithSigs) 50 | 51 | -- check the non-stale chain 52 | loop verifier ledgerInfosWithSigs 53 | 54 | pure lastLedgerInfoWithSigs 55 | where 56 | loop 57 | : {verifier : Set} ⦃ _ : Verifier.Verifier verifier ⦄ 58 | → verifier → List LedgerInfoWithSignatures 59 | → Either ErrLog Unit 60 | loop verifierRef = λ where 61 | [] → pure unit 62 | (liws ∷ liwss) → do 63 | Verifier.verify verifierRef liws 64 | verifierRef' ← case liws ^∙ liwsLedgerInfo ∙ liNextEpochState of λ where 65 | nothing → Left fakeErr -- ["empty ValidatorSet"] 66 | (just vs) → pure vs 67 | loop verifierRef' liwss 68 | 69 | here' : List String → List String 70 | here' t = "EpochChangeProof" ∷ "verify" ∷ t 71 | 72 | last : ∀ {A : Set} → List A → Either ErrLog A 73 | last [] = Left fakeErr 74 | last (x ∷ []) = Right x 75 | last (_ ∷ x ∷ xs) = last xs 76 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/EpochState.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Impl.OBM.Logging.Logging 9 | import LibraBFT.Impl.Types.LedgerInfoWithSignatures as LIWS 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | open import Util.Prelude 13 | 14 | module LibraBFT.Impl.Types.EpochState where 15 | 16 | verify : EpochState → LedgerInfoWithSignatures → Either ErrLog Unit 17 | verify self ledgerInfo = do 18 | lcheck (self ^∙ esEpoch == ledgerInfo ^∙ liwsLedgerInfo ∙ liEpoch) 19 | ( "EpochState" ∷ "LedgerInfo has unexpected epoch" ∷ []) 20 | --, show (self^.esEpoch), show (ledgerInfo^.liwsLedgerInfo.liEpoch) ] 21 | LIWS.verifySignatures ledgerInfo (self ^∙ esVerifier) 22 | 23 | epochChangeVerificationRequired : EpochState → Epoch → Bool 24 | epochChangeVerificationRequired self epoch = ⌊ self ^∙ esEpoch BlockInfo.mockGenesis mvs <*> pure Hash.valueZero 16 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/LedgerInfoWithSignatures.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | import LibraBFT.Impl.OBM.Crypto as Crypto 8 | open import LibraBFT.Impl.OBM.Logging.Logging 9 | open import LibraBFT.Impl.Types.ValidatorVerifier as ValidatorVerifier 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | import Util.KVMap as Map 13 | open import Util.PKCS 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Types.LedgerInfoWithSignatures where 17 | 18 | obmNewNoSigs : LedgerInfo → LedgerInfoWithSignatures 19 | obmNewNoSigs li = LedgerInfoWithSignatures∙new li Map.empty 20 | 21 | -- HC-TODO : refactor this and TimeoutCertificate 22 | addSignature : AccountAddress → Signature → LedgerInfoWithSignatures → LedgerInfoWithSignatures 23 | addSignature validator sig liws = 24 | case Map.lookup validator (liws ^∙ liwsSignatures) of λ where 25 | (just _) → liws 26 | nothing → 27 | liws & liwsSignatures ∙~ Map.kvm-insert-Haskell validator sig (liws ^∙ liwsSignatures) 28 | 29 | verifySignatures : LedgerInfoWithSignatures → ValidatorVerifier → Either ErrLog Unit 30 | verifySignatures self validator = withErrCtx' 31 | ("LedgerInfoWithSignatures" ∷ "verify" ∷ []) 32 | (ValidatorVerifier.batchVerifyAggregatedSignatures 33 | validator (self ^∙ liwsLedgerInfo) (self ^∙ liwsSignatures)) 34 | 35 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/OnChainConfig/ValidatorSet.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | open import Optics.All 9 | open import Util.KVMap as Map hiding (empty) 10 | open import Util.Prelude 11 | 12 | module LibraBFT.Impl.Types.OnChainConfig.ValidatorSet where 13 | 14 | new : List ValidatorInfo → ValidatorSet 15 | new = ValidatorSet∙new ConsensusScheme∙new 16 | 17 | empty : ValidatorSet 18 | empty = new [] 19 | 20 | obmFromVV : ValidatorVerifier → ValidatorSet 21 | obmFromVV vv0 = record -- ValidatorSet 22 | { _vsScheme = ConsensusScheme∙new -- TODO 23 | ; _vsPayload = fmap go (Map.toList (vv0 ^∙ vvAddressToValidatorInfo)) 24 | } 25 | where 26 | go : (Author × ValidatorConsensusInfo) → ValidatorInfo 27 | go (address , ValidatorConsensusInfo∙new pk vp) = 28 | record -- ValidatorInfo 29 | { _viAccountAddress = address 30 | ; _viConsensusVotingPower = vp 31 | ; _viConfig = record -- ValidatorConfig 32 | { _vcConsensusPublicKey = pk 33 | ; _vcValidatorNetworkAddress = address ^∙ aAuthorName } } 34 | 35 | obmGetValidatorInfo : AuthorName → ValidatorSet → Either ErrLog ValidatorInfo 36 | obmGetValidatorInfo name vs = 37 | case List-filter (λ vi → vi ^∙ viAccountAddress ∙ aAuthorName ≟ name) (vs ^∙ vsPayload) of λ where 38 | (vi ∷ []) → pure vi 39 | _ → Left fakeErr -- ["ValidatorSet", "obmGetValidatorInfo", "TODO better err msg"] 40 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/Properties/LedgerInfoWithSignatures.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures 9 | open import LibraBFT.ImplShared.Base.Types 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Optics.All 12 | open import Util.KVMap as Map 13 | open import Util.Hash 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Types.Properties.LedgerInfoWithSignatures (self : LedgerInfoWithSignatures) (vv : ValidatorVerifier) where 17 | 18 | -- See comments in LibraBFT.Impl.Consensus.ConsensusTypes.Properties.QuorumCert 19 | 20 | postulate -- TODO-2: define and prove 21 | 22 | Contract : Set 23 | 24 | contract : LedgerInfoWithSignatures.verifySignatures self vv ≡ Right unit → Contract 25 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/ValidatorSigner.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.ImplShared.Consensus.Types 8 | open import Optics.All 9 | open import Util.Encode 10 | open import Util.PKCS as PKCS hiding (sign) 11 | open import Util.Prelude 12 | 13 | module LibraBFT.Impl.Types.ValidatorSigner where 14 | 15 | sign : {C : Set} ⦃ enc : Encoder C ⦄ → ValidatorSigner → C → Signature 16 | sign (ValidatorSigner∙new _ sk) c = PKCS.sign-encodable c sk 17 | 18 | postulate -- TODO-1: publicKey_USE_ONLY_AT_INIT 19 | publicKey_USE_ONLY_AT_INIT : ValidatorSigner → PK 20 | 21 | obmGetValidatorSigner : AuthorName → List ValidatorSigner → Either ErrLog ValidatorSigner 22 | obmGetValidatorSigner name vss = 23 | case List-filter go vss of λ where 24 | (vs ∷ []) → pure vs 25 | _ → Left fakeErr -- [ "ValidatorSigner", "obmGetValidatorSigner" 26 | -- , name , "not found in" 27 | -- , show (fmap (^.vsAuthor.aAuthorName) vss) ] 28 | where 29 | go : (vs : ValidatorSigner) → Dec (vs ^∙ vsAuthor ≡ name) 30 | go (ValidatorSigner∙new _vsAuthor _) = _vsAuthor ≟ name 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/Verifier.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | import LibraBFT.Impl.Types.EpochState as EpochState 9 | import LibraBFT.Impl.Types.Waypoint as Waypoint 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | open import Util.Encode 12 | open import Util.PKCS hiding (verify) 13 | open import Util.Prelude 14 | 15 | module LibraBFT.Impl.Types.Verifier where 16 | 17 | record Verifier (A : Set) : Set where 18 | field 19 | verify : A → LedgerInfoWithSignatures → Either ErrLog Unit 20 | epochChangeVerificationRequired : A → Epoch → Bool 21 | isLedgerInfoStale : A → LedgerInfo → Bool 22 | ⦃ encodeA ⦄ : Encoder A 23 | 24 | open Verifier ⦃ ... ⦄ public 25 | 26 | instance 27 | VerifierEpochState : Verifier EpochState 28 | VerifierEpochState = record 29 | { verify = EpochState.verify 30 | ; epochChangeVerificationRequired = EpochState.epochChangeVerificationRequired 31 | ; isLedgerInfoStale = EpochState.isLedgerInfoStale 32 | } 33 | 34 | instance 35 | VerifierWaypoint : Verifier Waypoint 36 | VerifierWaypoint = record 37 | { verify = Waypoint.verifierVerify 38 | ; epochChangeVerificationRequired = Waypoint.epochChangeVerificationRequired 39 | ; isLedgerInfoStale = Waypoint.isLedgerInfoStale 40 | } 41 | 42 | -------------------------------------------------------------------------------- /src/LibraBFT/Impl/Types/Waypoint.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import LibraBFT.Base.Types 8 | open import LibraBFT.Impl.OBM.Logging.Logging 9 | import LibraBFT.Impl.Types.Ledger2WaypointConverter as Ledger2WaypointConverter 10 | open import LibraBFT.ImplShared.Consensus.Types 11 | import LibraBFT.ImplShared.Util.Crypto as Crypto 12 | open import Optics.All 13 | open import Util.Hash 14 | open import Util.Prelude 15 | 16 | module LibraBFT.Impl.Types.Waypoint where 17 | 18 | newAny : LedgerInfo → Waypoint 19 | newAny ledgerInfo = 20 | let converter = Ledger2WaypointConverter.new ledgerInfo 21 | in Waypoint∙new (ledgerInfo ^∙ liVersion) (Crypto.hashL2WC converter) 22 | 23 | newEpochBoundary : LedgerInfo → Either ErrLog Waypoint 24 | newEpochBoundary ledgerInfo = 25 | if ledgerInfo ^∙ liEndsEpoch 26 | then pure (newAny ledgerInfo) 27 | else Left fakeErr -- ["newEpochBoundary", "no validator set"] 28 | 29 | verify : Waypoint → LedgerInfo → Either ErrLog Unit 30 | verify self ledgerInfo = do 31 | lcheck (self ^∙ wVersion == ledgerInfo ^∙ liVersion) 32 | ("Waypoint" ∷ "version mismatch" ∷ []) --show (self^.wVersion), show (ledgerInfo^.liVersion)] 33 | let converter = Ledger2WaypointConverter.new ledgerInfo 34 | lcheck (self ^∙ wValue == Crypto.hashL2WC converter) 35 | ("Waypoint" ∷ "value mismatch" ∷ []) --show (self^.wValue), show (Crypto.hashL2WC converter)] 36 | pure unit 37 | 38 | epochChangeVerificationRequired : Waypoint → Epoch → Bool 39 | epochChangeVerificationRequired _self _epoch = true 40 | 41 | isLedgerInfoStale : Waypoint → LedgerInfo → Bool 42 | isLedgerInfoStale self ledgerInfo = ⌊ (ledgerInfo ^∙ liVersion) >= f) Q st 75 | LBFT-⇒-bind Post Q f pf m st con = RWS-⇒-bind {P = Post} {Q} {f} m unit st con pf 76 | 77 | LBFT-⇒-ebind 78 | : ∀ {A B C} {P : LBFT-Post (Either C A)} {Q : LBFT-Post (Either C B)} 79 | → {f : A → LBFT (Either C B)} 80 | → ∀ m st → LBFT-weakestPre m P st 81 | → RWS-Post-⇒ P (RWS-weakestPre-ebindPost unit f Q) 82 | → LBFT-weakestPre (m ∙?∙ f) Q st 83 | LBFT-⇒-ebind {P = Post} {Q} {f} m st con pf = 84 | RWS-⇒-ebind m unit st con pf 85 | -------------------------------------------------------------------------------- /src/LibraBFT/ImplShared/Util/Dijkstra/All.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | module LibraBFT.ImplShared.Util.Dijkstra.All where 8 | 9 | open import Dijkstra.All public 10 | open import LibraBFT.ImplShared.LBFT public 11 | -------------------------------------------------------------------------------- /src/Optics/All.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | module Optics.All where 7 | open import Optics.Functorial public 8 | open import Optics.Reflection public 9 | -------------------------------------------------------------------------------- /src/Optics/Example.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | open import Data.Nat 7 | open import Data.Maybe 8 | open import Data.Char 9 | open import Data.String 10 | open import Data.List hiding (product) 11 | open import Relation.Binary.PropositionalEquality 12 | import Relation.Binary.PropositionalEquality as PE 13 | using (_≡_; refl) 14 | import Relation.Binary.Definitions as BD 15 | import Relation.Binary as RB 16 | 17 | ------------------------------------------------------------------------------ 18 | 19 | open import Function 20 | 21 | open import Optics.All 22 | 23 | module Optics.Example where 24 | 25 | infixl 1 _&_ 26 | _&_ = Function._|>_ 27 | 28 | 29 | -- First we declare a record; which must be EXACTLY 30 | -- like the record 'Person' below. 31 | -- that is; must contain a constructor and 32 | -- a number of /simple/ fields (of type Set; no proofs please!) 33 | record Person : Set where 34 | constructor person 35 | field 36 | pName : String 37 | pAge : ℕ 38 | 39 | -- Then, we do some template agda: 40 | -- Yes,I know it looks weird; but it says: 41 | -- Put 'pName' and 'pAge' into scope as 42 | -- new identifiers; and run the metacomputation mkLens 43 | -- passing this newly created identifiers; the mkLens 44 | -- will then bind these identifiers to their respective 45 | -- generated lenses for the record Person 46 | -- 47 | -- IMPORTANT: Note how I did NOT /open Person/; otherwise, we'd 48 | -- have to give different names to the lenses. 49 | -- 50 | -- IMPORTANT: the list of names passed to unquoteDecl must come 51 | -- in the same order as the fields of Person. 52 | unquoteDecl pName pAge = mkLens (quote Person) (pName ∷ pAge ∷ []) 53 | 54 | -- Ok; lets do more recors for fun 55 | record Store : Set where 56 | constructor store 57 | field 58 | sId : ℕ 59 | sManager : Person 60 | unquoteDecl sId sManager = mkLens (quote Store) (sId ∷ sManager ∷ []) 61 | 62 | record Product : Set where 63 | constructor product 64 | field 65 | pId : ℕ 66 | pTag : String 67 | pStore : Store 68 | 69 | unquoteDecl pId pTag pStore = mkLens (quote Product) 70 | (pId ∷ pTag ∷ pStore ∷ []) 71 | 72 | -- Let's now do a simple example: 73 | 74 | mary : Person 75 | mary = person "Mary" 41 76 | 77 | compilers-from-mary : Store 78 | compilers-from-mary = store 0 mary 79 | 80 | ghc : Product 81 | ghc = product 13 "v8.0.0" compilers-from-mary 82 | 83 | -- Now say mary turns 42 years old; 84 | 85 | ghc-from-older-mary : Product 86 | ghc-from-older-mary = ghc & pStore ∙ sManager ∙ pAge ∙~ 42 87 | 88 | same-ghc-from-mary : Product 89 | same-ghc-from-mary = ghc & pStore ∙ sManager ∙ pAge %~ suc 90 | 91 | all-is-fine : ghc-from-older-mary ≡ same-ghc-from-mary 92 | all-is-fine = refl 93 | 94 | mary's-age-was-updated : ghc-from-older-mary ^∙ pStore ∙ sManager ∙ pAge ≡ 42 95 | mary's-age-was-updated = refl 96 | -------------------------------------------------------------------------------- /src/Optics/Functorial.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | open import Category.Functor 7 | open import Data.Maybe 8 | open import Function 9 | open import Level 10 | open import Relation.Binary.PropositionalEquality 11 | 12 | module Optics.Functorial where 13 | 14 | Lens' : (F : Set → Set) → RawFunctor F → Set → Set → Set 15 | Lens' F _ S A = (A → F A) → S → F S 16 | 17 | data Lens (S A : Set) : Set₁ where 18 | lens : ((F : Set → Set)(rf : RawFunctor F) → Lens' F rf S A) 19 | → Lens S A 20 | 21 | private 22 | cf : {A : Set} → RawFunctor {Level.zero} (const A) 23 | cf = record { _<$>_ = λ x x₁ → x₁ } 24 | 25 | if : RawFunctor {Level.zero} id 26 | if = record { _<$>_ = λ x x₁ → x x₁ } 27 | 28 | -- We can make lenses relatively painlessly without requiring reflection 29 | -- by providing getter and setter functions 30 | mkLens' : ∀ {A B : Set} 31 | → (B → A) 32 | → (B → A → B) 33 | → Lens B A 34 | mkLens' {A} {B} get set = 35 | lens (λ F rf f b → Category.Functor.RawFunctor._<$>_ 36 | {F = F} rf 37 | {A = A} 38 | {B = B} 39 | (set b) 40 | (f (get b))) 41 | 42 | -- Getter: 43 | 44 | -- this is typed as ^\. 45 | _^∙_ : ∀{S A} → S → Lens S A → A 46 | _^∙_ {_} {A} s (lens p) = p (const A) cf id s 47 | 48 | -- Setter: 49 | 50 | set : ∀{S A} → Lens S A → A → S → S 51 | set (lens p) a s = p id if (const a) s 52 | 53 | infixr 4 _∙~_ 54 | _∙~_ = set 55 | 56 | -- _|>_ is renamed to _&_ by Util.Prelude 57 | set? : ∀{S A} → Lens S (Maybe A) → A → S → S 58 | set? l a s = s |> l ∙~ just a 59 | 60 | infixr 4 _?~_ 61 | _?~_ = set? 62 | 63 | -- Modifier: 64 | over : ∀{S A} → Lens S A → (A → A) → S → S 65 | over (lens p) f s = p id if f s 66 | 67 | infixr 4 _%~_ 68 | _%~_ = over 69 | 70 | -- Composition 71 | infixr 30 _∙_ 72 | _∙_ : ∀{S A B} → Lens S A → Lens A B → Lens S B 73 | (lens p) ∙ (lens q) = lens (λ F rf x x₁ → p F rf (q F rf x) x₁) 74 | 75 | -- Relation between the same field of two states This most general form allows us to specify a 76 | -- Lens S A, a function A → B, and a relation between two B's, and holds iff the relation holds 77 | -- between the values yielded by applying the Lens to two S's and then applying the function to 78 | -- the results; more specific variants are provided below 79 | _[_]L_f=_at_ : ∀ {ℓ} {S A B : Set} → S → (B → B → Set ℓ) → S → (A → B) → Lens S A → Set ℓ 80 | s₁ [ _~_ ]L s₂ f= f at l = f (s₁ ^∙ l) ~ f (s₂ ^∙ l) 81 | 82 | _[_]L_at_ : ∀ {ℓ} {S A} → S → (A → A → Set ℓ) → S → Lens S A → Set ℓ 83 | s₁ [ _~_ ]L s₂ at l = _[_]L_f=_at_ s₁ _~_ s₂ id l 84 | 85 | infix 4 _≡L_f=_at_ 86 | _≡L_f=_at_ : ∀ {S A B : Set} → (s₁ s₂ : S) → (A → B) → Lens S A → Set 87 | s₁ ≡L s₂ f= f at l = _[_]L_f=_at_ s₁ _≡_ s₂ f l 88 | 89 | infix 4 _≡L_at_ 90 | _≡L_at_ : ∀ {S A} → (s₁ s₂ : S) → Lens S A → Set 91 | s₁ ≡L s₂ at l = _[_]L_f=_at_ s₁ _≡_ s₂ id l 92 | 93 | -------------------------------------------------------------------------------- /src/Util/Encode.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.ByteString 8 | open import Util.Prelude 9 | ------------------------------------------------------------------------------ 10 | open import Data.String using (String) 11 | 12 | module Util.Encode where 13 | 14 | -- An encoder for values of type A is 15 | -- an injective mapping of 'A's into 'ByteString's 16 | record Encoder {a}(A : Set a) : Set a where 17 | constructor mkEncoder 18 | field 19 | encode : A → ByteString 20 | encode-inj : ∀{a₁ a₂} → encode a₁ ≡ encode a₂ → a₁ ≡ a₂ 21 | open Encoder {{...}} public 22 | 23 | ≡-Encoder : ∀ {a} {A : Set a} → Encoder A → DecidableEquality A 24 | ≡-Encoder (mkEncoder enc enc-inj) x y 25 | with enc x ≟ByteString enc y 26 | ...| yes enc≡ = yes (enc-inj enc≡) 27 | ...| no neq = no (⊥-elim ∘ neq ∘ cong enc) 28 | 29 | postulate -- valid assumption 30 | instance 31 | encℕ : Encoder ℕ 32 | encBS : Encoder ByteString 33 | 34 | instance 35 | encFin : {n : ℕ} → Encoder (Fin n) 36 | encFin {n} = record { encode = encode ⦃ encℕ ⦄ ∘ toℕ ; 37 | encode-inj = toℕ-injective ∘ encode-inj ⦃ encℕ ⦄ } 38 | 39 | postulate -- TODO-2 decoder 40 | decode : ∀ {A : Set} → ByteString → Either String A 41 | -------------------------------------------------------------------------------- /src/Util/FunctionOverride.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | open import Axiom.Extensionality.Propositional 7 | open import Data.Empty 8 | open import Level 9 | open import Relation.Nullary 10 | open import Relation.Binary.PropositionalEquality hiding (Extensionality) 11 | 12 | module Util.FunctionOverride 13 | {ℓ₁ : Level} 14 | (A : Set ℓ₁) 15 | (_≟A_ : (a₁ a₂ : A) → Dec (a₁ ≡ a₂)) 16 | {ℓ₂ : Level}{B : Set ℓ₂} 17 | where 18 | 19 | override : (A → B) → A → B → (A → B) 20 | override f p v x 21 | with p ≟A x 22 | ...| yes refl = v 23 | ...| no neq = f x 24 | 25 | syntax override m p v = ⟦ m , p ← v ⟧ 26 | 27 | postulate -- valid assumption 28 | -- TODO-2: Eliminate postulate using https://github.com/agda/cubical 29 | funext : Extensionality ℓ₁ ℓ₂ 30 | 31 | override-target-≡ : ∀ {a : A}{b : B}{f} 32 | → override f a b a ≡ b 33 | override-target-≡ {a} 34 | with a ≟A a 35 | ...| yes refl = refl 36 | ...| no neq = ⊥-elim (neq refl) 37 | 38 | override-target-≢ : ∀ {a a' : A}{b : B}{f} 39 | → a' ≢ a 40 | → f a' ≡ (override f a b) a' 41 | override-target-≢ {a} {a'} neq 42 | with a ≟A a' 43 | ...| yes refl = ⊥-elim (neq refl) 44 | ...| no _ = refl 45 | 46 | overrideSameVal-correct : ∀ {f : A → B} 47 | → (p a : A) 48 | → override f p (f p) a ≡ f a 49 | overrideSameVal-correct p a 50 | with p ≟A a 51 | ...| no neq = refl 52 | ...| yes refl = refl 53 | 54 | overrideSameVal-correct-ext : ∀ {f : A → B}{p : A} → override f p (f p) ≡ f 55 | overrideSameVal-correct-ext {p = p} = funext (overrideSameVal-correct p) 56 | -------------------------------------------------------------------------------- /src/Util/Hash.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.ByteString 8 | open import Util.Encode 9 | open import Util.Prelude 10 | open import Util.Lemmas 11 | 12 | -- This module defines Hash functions, and related properties 13 | 14 | module Util.Hash where 15 | 16 | ------------------------------------------------- 17 | -- Hash function postulates 18 | -- 19 | postulate -- valid assumption: hashes are some (unspecified) number of bytes 20 | hashNumBytes : ℕ 21 | 22 | Hash : Set 23 | Hash = Σ ByteString (λ bs → length bs ≡ hashNumBytes) 24 | 25 | hashLen-pi : ∀ {bs : ByteString} {n : ℕ } → (p1 p2 : length bs ≡ n) → p1 ≡ p2 26 | hashLen-pi {[]} {.0} refl refl = refl 27 | hashLen-pi {h ∷ t} {.(suc (length t))} refl refl = refl 28 | 29 | sameBS⇒sameHash : ∀ {h1 h2 : Hash} 30 | → proj₁ h1 ≡ proj₁ h2 31 | → h1 ≡ h2 32 | sameBS⇒sameHash { h1a , h1b } { h2a , h2b } refl rewrite hashLen-pi {h2a} h1b h2b = refl 33 | 34 | _≟Hash_ : (h₁ h₂ : Hash) → Dec (h₁ ≡ h₂) 35 | (l , pl) ≟Hash (m , pm) with List-≡-dec (Vec-≡-dec _≟Bool_) l m 36 | ...| yes refl = yes (cong (_,_ l) (≡-pi pl pm)) 37 | ...| no abs = no (abs ∘ ,-injectiveˡ) 38 | 39 | instance 40 | Eq-Hash : Eq Hash 41 | Eq._≟_ Eq-Hash = _≟Hash_ 42 | 43 | encodeH : Hash → ByteString 44 | encodeH (bs , _) = bs 45 | 46 | encodeH-inj : ∀ i j → encodeH i ≡ encodeH j → i ≡ j 47 | encodeH-inj (i , pi) (j , pj) refl = cong (_,_ i) (≡-pi pi pj) 48 | 49 | encodeH-len : ∀{h} → length (encodeH h) ≡ hashNumBytes 50 | encodeH-len { bs , p } = p 51 | 52 | encodeH-len-lemma : ∀ i j → length (encodeH i) ≡ length (encodeH j) 53 | encodeH-len-lemma i j = trans (encodeH-len {i}) (sym (encodeH-len {j})) 54 | 55 | -- Which means that we can make a helper function that combines 56 | -- the necessary injections into one big injection 57 | ++b-2-inj : (h₁ h₂ : Hash){l₁ l₂ : Hash} 58 | → encodeH h₁ ++ encodeH l₁ ≡ encodeH h₂ ++ encodeH l₂ 59 | → h₁ ≡ h₂ × l₁ ≡ l₂ 60 | ++b-2-inj h₁ h₂ {l₁} {l₂} hip 61 | with ++-inj {m = encodeH h₁} {n = encodeH h₂} (encodeH-len-lemma h₁ h₂) hip 62 | ...| hh , ll = encodeH-inj h₁ h₂ hh , encodeH-inj l₁ l₂ ll 63 | 64 | Collision : {A B : Set}(f : A → B)(a₁ a₂ : A) → Set 65 | Collision f a₁ a₂ = a₁ ≢ a₂ × f a₁ ≡ f a₂ 66 | 67 | instance 68 | enc-Hash : Encoder Hash 69 | enc-Hash = record 70 | { encode = encodeH 71 | ; encode-inj = encodeH-inj _ _ 72 | } 73 | 74 | module WithCryptoHash 75 | -- A Hash function maps a bytestring into a hash. 76 | (hash : BitString → Hash) 77 | (hash-cr : ∀{x y} → hash x ≡ hash y → Collision hash x y ⊎ x ≡ y) where 78 | 79 | -- We define the concatenation of hashes like one would expect 80 | hash-concat : List Hash → Hash 81 | hash-concat l = hash (bs-concat (List-map encodeH l)) 82 | 83 | -- And voila, it is either injective ot we broke the hash function! 84 | hash-concat-inj : ∀{l₁ l₂} → hash-concat l₁ ≡ hash-concat l₂ → NonInjective-≡ hash ⊎ l₁ ≡ l₂ 85 | hash-concat-inj {l₁} {l₂} hyp with hash-cr hyp 86 | ...| inj₁ col = inj₁ ((_ , _) , col) 87 | ...| inj₂ same with bs-concat-inj (List-map encodeH l₁) (List-map encodeH l₂) same 88 | ...| res = inj₂ (map-inj encodeH (encodeH-inj _ _) res) 89 | where 90 | map-inj : ∀{a b}{A : Set a}{B : Set b}(f : A → B) 91 | → (f-injective : ∀{a₁ a₂} → f a₁ ≡ f a₂ → a₁ ≡ a₂) 92 | → ∀{xs ys} → List-map f xs ≡ List-map f ys → xs ≡ ys 93 | map-inj f finj {[]} {[]} hyp = refl 94 | map-inj f finj {x ∷ xs} {y ∷ ys} hyp 95 | = cong₂ _∷_ (finj (proj₁ (∷-injective hyp))) 96 | (map-inj f finj (proj₂ (∷-injective hyp))) 97 | -------------------------------------------------------------------------------- /src/Yasm/Base.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2020, 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.PKCS 8 | open import Util.Prelude 9 | open import Yasm.Types 10 | 11 | -- This module defines the types used to define a SystemModel. 12 | module Yasm.Base (ℓ-PeerState : Level) where 13 | -- Our system is configured through a value of type 14 | -- SystemParameters where we specify: 15 | record SystemTypeParameters : Set (ℓ+1 ℓ-PeerState) where 16 | constructor mkSysTypeParms 17 | field 18 | PeerId : Set 19 | _≟PeerId_ : ∀ (p₁ p₂ : PeerId) → Dec (p₁ ≡ p₂) 20 | Bootstrap : Set 21 | -- A relation specifying what Signatures are included in bootstrapInfo 22 | ∈BootstrapInfo : Bootstrap → Signature → Set 23 | PeerState : Set ℓ-PeerState 24 | Msg : Set 25 | Part : Set -- Types of interest that can be represented in Msgs 26 | 27 | -- The messages must be able to carry signatures 28 | instance Part-sig : WithSig Part 29 | 30 | -- A relation specifying what Parts are included in a Msg. 31 | 32 | -- TODO-2: I changed the name of this to append the G because of the pain disambiguating it from 33 | -- NetworkMsg.⊂Msg. This issue https://github.com/agda/agda/issues/2175 suggests I should have 34 | -- been able to get this right without renaming, but... I'd like to underastand how to do this 35 | -- right, but for expedience, not now. 36 | _⊂MsgG_ : Part → Msg → Set 37 | 38 | module _ (systypes : SystemTypeParameters) where 39 | open SystemTypeParameters systypes 40 | 41 | record SystemInitAndHandlers : Set (ℓ+1 ℓ-PeerState) where 42 | constructor mkSysInitAndHandlers 43 | field 44 | -- The same bootstrap information is given to any uninitialised peer before 45 | -- it can handle any messages. 46 | bootstrapInfo : Bootstrap 47 | 48 | -- Represents an uninitialised PeerState, about which we know nothing whatsoever 49 | initPS : PeerState 50 | 51 | -- Bootstraps a peer. Our current system model is simplistic in that unsuccessful 52 | -- initialisation of a peer has no side effects. In future, we could change the return type 53 | -- of bootstrap to Maybe PeerState × List (Action Msg), allowing for it to return nothing, but 54 | -- to include actions such as sending messages, logging, etc. We are not doing so now as it 55 | -- is disruptive to existing proofs and modeling and verifying properties about unsuccessful 56 | -- initialisation is not a priority. 57 | bootstrap : PeerId → Bootstrap → Maybe (PeerState × List (Action Msg)) 58 | 59 | -- Handles a message on a previously initialized peer. 60 | handle : PeerId → Msg → PeerState → PeerState × List (Action Msg) 61 | 62 | -------------------------------------------------------------------------------- /src/Yasm/Types.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021, Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.Prelude 8 | 9 | -- This module defines types used in the specification of a SystemModel. 10 | module Yasm.Types where 11 | 12 | -- Actions that can be performed by peers. 13 | -- 14 | -- For now, the SystemModel supports only one kind of action: to send a 15 | -- message. Later it might include things like logging, crashes, assertion 16 | -- failures, etc. For example, if an assertion fires, this 17 | -- could "kill the process" and make it not send any messages in the future. 18 | -- We could also then prove that the handlers do not crash, certain 19 | -- messages are logged under certain circumstances, etc. 20 | -- 21 | -- Alternatively, certain actions can be kept outside the system model by 22 | -- defining an application-specific PeerState type (see `Yasm.Base`). 23 | -- For example: 24 | -- 25 | -- > libraHandle : Msg → Status × Log × LState → Status × LState × List Action 26 | -- > libraHandle _ (Crashed , l , s) = Crashed , s , [] -- i.e., crashed peers never send messages 27 | -- > 28 | -- > handle = filter isSend ∘ libraHandle 29 | data Action (Msg : Set) : Set where 30 | send : (m : Msg) → Action Msg 31 | 32 | -- Injectivity of `send`. 33 | action-send-injective : ∀ {Msg}{m m' : Msg} → send m ≡ send m' → m ≡ m' 34 | action-send-injective refl = refl 35 | -------------------------------------------------------------------------------- /src/Yasm/Yasm.agda: -------------------------------------------------------------------------------- 1 | {- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9. 2 | 3 | Copyright (c) 2021 Oracle and/or its affiliates. 4 | Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl 5 | -} 6 | 7 | open import Util.PKCS 8 | open import Util.Prelude 9 | import Yasm.Base as YB 10 | import Yasm.System as YS 11 | 12 | -- This module provides a single import for all Yasm modules 13 | 14 | module Yasm.Yasm 15 | (ℓ-PeerState : Level) 16 | (ℓ-VSFP : Level) 17 | (parms : YB.SystemTypeParameters ℓ-PeerState) 18 | (iiah : YB.SystemInitAndHandlers ℓ-PeerState parms) 19 | (ValidSenderForPK : YS.WithInitAndHandlers.ValidSenderForPK-type ℓ-PeerState ℓ-VSFP parms iiah) 20 | (ValidSenderForPK-stable : YS.WithInitAndHandlers.ValidSenderForPK-stable-type ℓ-PeerState ℓ-VSFP parms iiah ValidSenderForPK) 21 | where 22 | open YB.SystemTypeParameters parms 23 | open YB.SystemInitAndHandlers iiah 24 | open import Yasm.Base public 25 | open import Yasm.Types public 26 | open import Yasm.System ℓ-PeerState ℓ-VSFP parms public 27 | open import Yasm.Properties ℓ-PeerState ℓ-VSFP parms iiah ValidSenderForPK ValidSenderForPK-stable public 28 | open WithInitAndHandlers iiah public 29 | open import Util.FunctionOverride PeerId _≟PeerId_ public 30 | --------------------------------------------------------------------------------