commit f42e9d12ac75d2876a4cf600d44976b7090d4533 Author: Tezos Date: Thu Sep 8 19:13:10 2016 +0200 First public release diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..58133b97b --- /dev/null +++ b/.gitignore @@ -0,0 +1,45 @@ + +/tezos-node +/tezos-protocol-compiler +/tezos-client + +/src/.depend + +/src/node/updater/environment_gen +/src/node/updater/proto_environment.mli +/src/compiler/embedded_cmis.ml + +/src/proto/**/_tzbuild +/src/proto/register_client_*.ml +/src/client/embedded/**/_tzbuild + +/src/client/embedded/demo/.depend + +/src/client/embedded/bootstrap/.depend +/src/client/embedded/bootstrap/concrete_lexer.ml +/src/client/embedded/bootstrap/concrete_parser.ml +/src/client/embedded/bootstrap/concrete_parser.mli + +/test/.depend + +/test/test-store +/test/test-state +/test/test-context +/test/test-basic +/test/LOG + +*~ +\#*\# + +*.[oa] +*.so +*~ +*.cm[iaoxt] +*.cmti +*.cmxa +*.cmxs +*.mli.deps +*.ml.deps + +*.rej +*.orig \ No newline at end of file diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml new file mode 100644 index 000000000..ad4678726 --- /dev/null +++ b/.gitlab-ci.yml @@ -0,0 +1,147 @@ +variables: + ocaml_image: alpine_ocaml-4.03.0 + build_image_name: ocp_tezos_build + build_image_id: ${CI_BUILD_REF} + build_image: ${build_image_name}:${ocaml_image} + +image: ${build_image}_${build_image_id} + +stages: + - build_deps + - build + - build_test + - test + - publish + - cleanup + +build_deps: + stage: build_deps + image: ocp:docker + tags: + - docker_builder + script: + - ./scripts/create_docker_builder.sh + ${build_image_name} ${ocaml_image} "_${build_image_id}" + +build: + stage: build + tags: + - tezos_builder + script: + - make -j4 + artifacts: + expire_in: 1 week + untracked: true + +build:test: + stage: build_test + tags: + - tezos_builder + script: + - make -C test build-test -j4 + dependencies: + - build + artifacts: + expire_in: 1 week + untracked: true + +test:store: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-store + dependencies: + - build + - build:test + +test:context: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-context + dependencies: + - build + - build:test + +test:state: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-state + dependencies: + - build + - build:test + +test:basic: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-basic + dependencies: + - build + - build:test + +test:basic.sh: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-basic.sh + dependencies: + - build + - build:test + +publish:expurge: + stage: publish + tags: + - tezos_builder + only: + - master@tezos/tezos + script: + - echo "${CI_KH}" > ~/.ssh/known_hosts + - echo "${CI_PK}" > ~/.ssh/id_rsa + - chmod 400 ~/.ssh/id_rsa + - rm -fr .git/refs/original + - git filter-branch --prune-empty --index-filter + 'git rm -r --cached --ignore-unmatch + .gitlab-ci.yml + "docs/proof of stake.md" + src/client/embedded/bootstrap/mining/' + --env-filter + 'export GIT_AUTHOR_NAME="Dynamic Ledger Solutions, Inc." ; + export GIT_AUTHOR_EMAIL="contact@tezos.com"' + HEAD + - git tag ${CI_BUILD_REF}_expurged + - git push git@gitlab.ocamlpro.com:${CI_PROJECT_PATH}.git + -f --tags HEAD:master-expurged + +publish:github: + image: ocaml/opam:${ocaml_image} + stage: publish + tags: + - tezos_builder + only: + - master@tezos/tezos + when: manual + script: + - echo "${CI_KH}" > ~/.ssh/known_hosts + - echo "${CI_PK}" > ~/.ssh/id_rsa + - chmod 400 ~/.ssh/id_rsa + - git reset ${CI_BUILD_REF}_expurged + - git push git@github.com:OCamlPro/tezos.git + -f HEAD:master + +cleanup: + stage: cleanup + image: ocp:docker + tags: + - docker_builder + script: + - docker tag ${build_image}_${build_image_id} + ${build_image}_${CI_PROJECT_NAMESPACE}_${CI_BUILD_REF_NAME} + - docker rmi ${build_image}_${build_image_id} + when: always diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 000000000..ef83851c8 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1 @@ +match_clause = 4 diff --git a/Makefile b/Makefile new file mode 100644 index 000000000..3f4dc5fa1 --- /dev/null +++ b/Makefile @@ -0,0 +1,13 @@ + +all: + ${MAKE} -C src all + +clean: + ${MAKE} -C src clean + +.PHONY:test +test: + ${MAKE} -C test + +build_deps: + @./scripts/install_build_deps.sh all diff --git a/README.md b/README.md new file mode 100644 index 000000000..cd987e62f --- /dev/null +++ b/README.md @@ -0,0 +1,66 @@ + +TEZOS +===== + +To compile: + +``` +make build-deps +make +``` + +========= + +To run a single instance : + +``` +./tezos-node +``` + +All useful data are stored in `${HOME}/.tezos-node`. + +To run a test instance, without connecting to the gossup network : + +``` +./tezos-node -sandbox /path/to/a/custom/data/dir +``` + +Useful data will be stored in the directory `/path/to/a/custom/data/dir` +instead of `${HOME}/.tezos-node`. + +========= + +To create other instances on the same machine, it is possible to +duplicate and edit `${HOME}/.tezos/config` while taking care not to +share paths for accessing the database or any other data file +(cf. options `db.store` ; `db.context` ; `net.peers` and `protocol.dir`). + +Another possibility is to let Tezos generate a config file by specifying +options on the command line. For instance, if `${DIR}/config` does not +exist, the following command will generate it and replace the default values +with the values from the command line arguments: + +``` +./tezos-node -base-dir ${DIR} -net-port 2023 -net-addr 127.0.0.1 +``` + +The Tezos server has a built-in mechanism to discover peers on the local net +(using UDP packets broadcasted on port 7732) + +If this mechanism isn't sufficient, one can provide Tezos with a list of +initial peers, either by editing the option `net.bootstrap.peers` in the +`config` file, or by specifying a command line parameter: + +``` +./tezos-node -base-dir ${DIR} -net-port 2023 -net-addr 127.0.0.1 \ + -net-bootstrap-peers '[("127.0.0.1", 2021);("127.0.0.1", 2022)]' +``` + +If `${DIR}/config` exists, the command line options override those read +in the config file. Tezos never modifies the content of an existing +`${DIR}/config` file. + +``` +./tezos-node -config-file ${DIR}/config +``` + diff --git a/docs/TUTORIAL.md b/docs/TUTORIAL.md new file mode 100644 index 000000000..aecac1651 --- /dev/null +++ b/docs/TUTORIAL.md @@ -0,0 +1,65 @@ +# Tezos Code Tutorial + +## Introduction + +The purpose of this document is to help contributors get started with the Tezos +codebase. The code is organized in several layers in a way which largely reflects the philosophy of the project. It creates a very strict separation between the "node", which implements the network protocol described in the white paper and between the protocols themselves. Of course the seed protocol itself is a very important part of the Tezos project and it follows a similar organization. The economic protocol sits on top of a few layers of abstractions dealing primarily with storing and retrieving data from the current context. + +## Overview of the source + +This section presents a brief overview of the layout of the source files and their significance. + +### node +The network shell +#### node/db +Persistent data structures used by the shell to store its state. +#### note/net +Connectivity for the gossip network and primitives to create RPC services +#### node/shell +The shell itself +#### node/updater +Manage on-the-fly updates to the protocol + +### proto +This is where the protocols live +#### proto/environment + +#### proto/current + +### utils + +### compiler + +### client +### client/embedded + +### Node, the network shell + +### Storing the context + +## Irmin + +Tezos needs to store potentially different version of its context, corresponding to potentially different branches of the blockchain. This also implies the ability to roll back the changes made by any single block, and to make atomic changes to the structure on disk for eac block to avoid corruption. + +To that extent, Tezos borrows from the MirageOS project a module called [Irmin](https://github.com/mirage/irmin "Irmin") + +> Irmin is a library to persist and synchronize distributed data structures both on-disk and in-memory. It enables a style of programming very similar to the Git workflow, where distributed nodes fork, fetch, merge and push data between each other. The general idea is that you want every active node to get a local (partial) copy of a global database and always be very explicit about how and when data is shared and migrated. + +Caveat: although Tezos **is** a distributed ledger, it does **not** rely on Irmin's distributed store capabilities. For our purposes we only use Irmin as a local storage. The git structure is particularly well suited to represent the versionning implicit in the state of a blockchain based ledger. In fact, the context of Tezos can be observed by running "git checkout" in the data directory. + +## Netbits and Jsont + +Netbits and Jsont are modules which allow for the typesafe serialization of OCaml objects in a binary format and in Json (respectively). Importantly, it does not make of the potentially brittle representation created by the compiler and access through the Obj.magic function. Serializers are created using a set of type constructors defined in a GADT. + + +## (MISC STUFF TO BE ORGANIZED IN THE DOCUMENT) + +The "Main" module represents the fixed interface between the economic protocol and the shell. + +A protocol consists of several .ml and .mli files and a file name TEZOS_PROTOCOL which lists the modules in order of inclusion for the compilation. Lower level modules sit below high level modules. + + +What are \\_repr modules? + +These modules handle the low level representation of a type, in particular its serialization in Json and in binary format. A module based on this type will often exist on top of it and provide functionality around that type. This provides finely grained layers of encapsulation to mininize the visible interfaces. + diff --git a/docs/proof of stake.md b/docs/proof of stake.md new file mode 100644 index 000000000..ccf46d3c8 --- /dev/null +++ b/docs/proof of stake.md @@ -0,0 +1,136 @@ +# Proof-of-stake in Tezos: Michelson + +## Introduction + +This write-up intends to provide a more detailed description of the proof-of-stake mechanism in Michelson (Tezos' seed protocol) than is available in the white paper. It explains the rationale between the design decisions, highlights some tradeoffs and calls attention to potential weaknesses and concerns. + +## Outline + +Our proof-of-stake mechanism is based on a blockchain. We attempt to replicate Bitcoin's consensus properties without relying on proof-of-work. Instead of being discovered by miners through brute force search, the blocks are *forged* and *signed* by the participants in the network. We attempt to assign the right to sign the blocks randomly in proportion to the amount of tokens held. This isn’t necessarily because the party receiving the signing right has “something at stake” but rather because it acts as a reasonable Sybil prevention mechanism. This approach presents a few challenges: + +1. What source of randomness can we use to assign signing rights? +2. What happens if the responsible party doesn’t sign a block ? +3. The old quip goes: “Time is nature's way to keep everything from happening all at once”. How do we go about that? +4. Since signatures are costless, how do we incentivize against forks that reorganize the blockchain? +5. Since blocks are cheap to create (it is the goal), how do we prevent DOS attacks that force nodes to waste time evaluating spurious forks? + +If we can reasonably patch all of these issues, we may have a workable proof-of-stake scheme. It may not strictly dominate proof-of-work in all aspects, but it will better for some threat models and worse for others. Whether or not it is overall "better" or "worse" is ultimately an empirical question. + +## A warning about complexity + +Before we get started, I should disclose that the complexity of our approach gives me pause. Proof-of-work looks dead simple and yet has proven out to be a trove of gotchas (such as selfish-mining). With a complex system like the one I am about to describe, it is much more harduous to foresee all the potential problems and attacks. With hindsight, I realize I would be more comfortable with a mechanism offering a more patent security model. A verifiable reduction to PBFT would be ideal. Tendermint claims to do this, but I haven’t evaluated it and they have systematically failed to demonstrate reliable consensus in demonstrations. This may be an implementation issue or an issue with their design at large. + +Fortunately, Tezos can upgrade its consensus mechanism, so all that is needed is for the current consensus mechanism to be sufficiently robust to cope long enough for a cleaner mechanism to replace it. A successful launch will give us ample funding to develop such a solution. + +## Overview of our approach + +There is some circular dependencies in the various parts which make up Michelson's proof-of-stake mechanism. For instance, the procedure by which we derive a random seed for assigning forging rights depends on the system's ability to resist censorship, but the latter cannot exist without random seeds. As a result, the reader may want to jump between the different sections or two read in two passes so as to resolve the dependencies. + +### Cycle + +Briefly speaking, the algorithm proceeds according to a cycle composed of a set number of blocks. The length of a cycle, in blocks, is a tunable parameter which we have yet to decide upon. We intend for a cycle to last between a few days and a few months. Shorter cycles offer better protection against censorship, while longer cycles provide a stronger consensus. + +### Forging + +At the beginning of a cycle, a random seed is derived from information revealed in the penultimate cycle. For each block in the cycle, we randomly assign "forging" rights priorities to stakeholders. For instance, for the 5th block in the cycle, the protocol may randomly pick stakeholder A and gives them the top priority for forging that block, then randomly pick stakeholder B and give them the second highest priority, and so on and so forth. Thus, each block in the cycle is associated with a list of stakeholders ordered by priority. This priority is reflected in the form of timing rules. The stakeholder with the top forging priority may create the block one minute after the previous block. If he doesn't do so, the stakeholder with the second highest forging priority may create the block two minutes after the previous block, etc. + +### Endorsements + +In addition to forging rights, the protocol randomly assigns endorsement rights. For each block, 16 endorsement rights are randomly assigned to stakeholders. An endorsement means that a select stakeholder signs a particular block. Those endorsements are then included in the block's children. The total number of signature in a chain is the criterion for selecting the longest chain. + +Here's a quick explanation why signatures are needed. Suppose the next block is to be forged in priority by stakeholder A, followed by stakeholder B, while the block after that gives the first priority to B and the second to A. B could be tempted to create both blocks, linking them to each other in a form of "selfish forging". Signatures mitigate this greatly because endorsements for the first block would refer to the block mined by A, and B needs to include as many of these endorsements as possible for its block to hold weight. + +Stakeholders are incentivized to collaborate to sign the same block in two ways. If a signer signs a block which doesn't end up being part of the blockchain, then they will miss out on receiving a reward, and the more signers agree on which block to sign, the higher the reward. They also receive a higher reward for higher priority blocks, to nudge them away from trying to hold out. + +### Bonds and rewards + +In proof-of-work, at a given time, a mining rig can only be used to mine children of a specific block. This financially incentivizes miners to commit to one particular branch. Cryptographic signatures on the other hand are very cheap, and thus a stakehoklder forging a block or signing an endorsment on our network could theoretically participate in two different branches. However, this can be detected by networks participants since in both cases the public key is the same. + +Stakeholders maintain a pool of tokens which is used as collateral. Whenever a stakeholder forges a block or sign an endorsment, a portion of this pool is frozen for a period of time (we are targetting one year but may have a shorter cycle initially). The period of time is adjusted so that reimbursements fall on a predictable schedule in order to compress the size of the state needed. Reimbursements are made to the pool of tokens from which collateral is drawn. If a double signature is detected for the same block, but in a different branch, or the same endorsement, but for a different block, a miner can include a denunication in their block, which contains a proof of malfeasance. The bond is forfeited, and the miner receives a reward (of lower xvalue to the bond). + +This effectively protects only against double signatures when the branches fork within the same cycle. If a fork happened ahead of the current cycle, "blocks" and "endorsements" are not meaningfully the same, and a stakeholder may get away with a double signature. However, large stakeholders who take part in the consensus algorithm will typically have a large amount of bonds "at stake" in the chain, making it unwise for them to cause trouble in the consensus. + +### Randomness & rolls + +In order to "randomly" determine how to assign mining a signing rights at the beginning of a cycle, we use a cryptographically secure PRNG seeded with a value computed at the end of the penultimate cycle. The seed is computed as follow. During a first cycle, block forgers commit to a secret random number by including its hash in their blocks. During the following cycle, they reveal their commitment under penalty of forfeiting the bond deposited for the block. All the revelead commitments are hashed together and a seed is derived by solving a related discrete logarithm problem. + +To select a random stakeholder, we use a "follow-the-coin" strategy. This ensures that a malicious participant creating a fork by themselves cannot assign themselves signing and forging rights by shuffling around coins. Tracking every single coin would be inefficient. Instead, we track "rolls" of coin. A roll of coin represent a set of several coins bundled together. Sometimes transactions may break rolls, in which case the roll id goes into a LIFO queue and is reused as soon as enough loose coins are joined in a contract to form a roll. This means that a stake will alway be rounded down to the nearest number of rolls it represents. + +### DDOS protection + +Bitcoin's least appreciated strength is its resistance to DDOS attacks. When a peer advertises a better chain to a node, before beginning to even download the blocks, the amount of work can be assessed extremely quickly by looking at the block hashes. This doesn't mean further validation isn't warranted, the blocks may be invalid, but if they are, this is an extremely expensive attack to throw. + +In contrast, in proof-of-stake, blocks are cheap to create and can take longer to validate. How do we prevent a scenario where peers flood us with invalid blocks advertising them as higher priority than the real chain. We take a variety of approaches. + +First, we analyze blocks defensively, trying to reject invalid blocks as early as possible. This may not be as cheap as counting the number of 0s in a hash, andit may require downloading more data, but in the end, both are constant time operations. + +Moreover, a valid, low priority, fork will have long time intervals between blocks. The network shell will simply refuse to validate blocks dated in the future. This prevents an adversary from forcing the evaluation of a trillion bock long forks for instance. + +Furthermore, the network shell may blacklist IPs that relay invalid blocks. This is not ideal as it may lead to the blacklisting of TOR exit nodes and may not work well with IPv6. In the future, we could consider having peers purchase keys on the blockchain and require such keys to participate in the gossip network. This would make blacklisting / whitelisting work much better. + +Last, but not least, we require the hash of each block to solve a small proof-of-work problem. It is calibrated so that creating a block should be roughly 1,000 times more expensive than validating it. The deadweight loss of this mild proof-of-work stamp is many order of magnitudes smaller than that of a regular proof-of-work consensus. It is not subject to a red queen effect: as hardware becomes better, it becomes cheaper to both generate and validate blocks.x + +## Seed derivation + +We can harden the seed derivation by making it computationally expensive to compute the seed. A simple approach would be to use many rounds of hashing, but this has the downside of requiring every party validating the ledger to perform the same computation. The solution to a preimage problem as in Bitcoin's proof-of-work is computationally hard but can be checked very cheaply. Unfortunately, those solutions aren't unique. + +Instead we use a computationally hard problem where there exists a unique solution which can be checked inexpensively. + +We first derive a 64 bit hash, x, out of the nonces revealed by the forgers. We then increment x until we find p, the smallest prime number greater or equal to x. The seed we seek is the discrete log of h(x) modulo p in base 2. This takes 32 bits of effort and about 1Gb of mmeory. A parameter which may be updated in further protocol changes. + +The last block of a cycle must contain the solution to the problem. + +### Informal checkpointing + +Requiring regular, centralized checkpoints would defeat the purpose of a decentralized ledger. However, occasional checkpoints do have their use. After several months, the hash of a particular block in the blockchain should be considered largely a settled matter and may be discovered through social consensus. Certain attacks against proof-of-stake involve purchasing old wallet keys from former stakeholders. Such an attack, by its nature would be largely visible. If such a threat did arise, given the exceptional circumstances, the network participants can simply decide to protect themselves by picking a checkpoint. It's ad hoc, it's inelegant, but it works and it should be enough to thwart such an attack and even discourage it in the first place. + +### Delegation + +Each contract has two keys. A "manager" key for spending the funds, and a "delegate" key for all operations related to participations in the proof-of-stake protocol or the governance process. This has several advantages. + +First, it permits specialization. Not every party holding a contract on the network is interested in participating directly in the proof-of-stake protocol or in network governance. + +Second, it permits to keep private spending keys offline. + +Third, delegate keys will be sticky to some extent. This prevents parties from changing their keys willy nilly which would weaken the ability to detect double signatures. + + + + +* The hash of the block +* An Ed25519 signature of the block +* A shell header +* A protocol header + +The shell header is common to all protocol versions and can be understood by the network shell: + +* A timestamp +* The hash of the preceding block +* The fitness score of the current chain +* A merkle tree of operation hashes, the semantics of which are opaque to the network shellx + +The protocol header (specific to Michelson) + +* A nonce used for a minimal proof-of-work stamp for DDOS purposes +* The current block height +* A list of denounciations + +"Operations" act on the ledger to change its state. They are typically transactions, or new contract originations, but certain operations play a specific role in the proof-of-stake mechanism. They are + + * Delegations + * Bond payments + * Endorsements + * Divulgments + +## Cycles + +The proof-of-stake algorithm works according to a set cycle. The lenght of the cycle (in block) is a tunable parameter, typically we intend to set it between a few days and a few months. + + + + + + + + + diff --git a/scripts/create_docker_builder.sh b/scripts/create_docker_builder.sh new file mode 100755 index 000000000..1a5592443 --- /dev/null +++ b/scripts/create_docker_builder.sh @@ -0,0 +1,30 @@ +#! /bin/sh + +set -x + +dir=$(mktemp -d) +cur_dir="$(dirname "$(readlink -f "$0")")" + +image_name=${1:=tezos_build} +ocaml_version=${2:=alpine_ocaml-4.03.0} +image_version=$3 + +cp ${cur_dir}/install_build_deps.sh ${dir} +cp ${cur_dir}/../src/tezos-deps.opam ${dir} +cat > ${dir}/Dockerfile < .depend +%.ml.deps: %.ml | predepend + @echo OCAMLDEP ${TARGET} $(notdir $^) + @$(OCAMLDEP) -native $(INCLUDES) $^ > $@ +%.mli.deps: %.mli | predepend + @echo OCAMLDEP ${TARGET} $(notdir $^) + @$(OCAMLDEP) -native $(INCLUDES) $^ > $@ + +clean:: + -rm -f .depend + -find \( -name \*.mli.deps -or -name \*.ml.deps \) -delete diff --git a/src/Makefile.config b/src/Makefile.config new file mode 100644 index 000000000..f9f74976e --- /dev/null +++ b/src/Makefile.config @@ -0,0 +1,18 @@ + +INCLUDES = \ + $(patsubst %, -I %, $(SOURCE_DIRECTORIES)) \ + $(patsubst %, -package %, $(PACKAGES)) \ + $(patsubst %, -open %, $(OPENED_MODULES)) + +OCAMLFLAGS = \ + -g -safe-string -bin-annot -w +27-30-40 -short-paths \ + ${INCLUDES} \ + ${EXTRA_OCAMLFLAGS} + +OCAMLC = ocamlfind ocamlc +OCAMLOPT = ocamlfind ocamlopt +OCAMLMKTOP = ocamlfind ocamlmktop +OCAMLDEP = ocamlfind ocamldep +OCAMLRES = ocp-ocamlres +OCAMLLEX = ocamllex +MENHIR = menhir diff --git a/src/client/.merlin b/src/client/.merlin new file mode 100644 index 000000000..910303f1c --- /dev/null +++ b/src/client/.merlin @@ -0,0 +1,4 @@ +REC +FLG -open Error_monad -open Hash -open Utils +S embedded +B embedded diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml new file mode 100644 index 000000000..cb5464cb6 --- /dev/null +++ b/src/client/client_aliases.ml @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Local Storage for Configuration *) + +open Lwt +open Cli_entries + +module type Entity = sig + type t + val encoding : t Data_encoding.t + val of_source : string -> t Lwt.t + val to_source : t -> string Lwt.t + val name : string +end + +module type Alias = sig + type t + val load : unit -> (Lwt_io.file_name * t) list Lwt.t + val find : Lwt_io.file_name -> t Lwt.t + val find_opt : Lwt_io.file_name -> t option Lwt.t + val rev_find : t -> Lwt_io.file_name option Lwt.t + val name : t -> string Lwt.t + val mem : Lwt_io.file_name -> bool Lwt.t + val add : Lwt_io.file_name -> t -> unit Lwt.t + val del : Lwt_io.file_name -> unit Lwt.t + val save : (Lwt_io.file_name * t) list -> unit Lwt.t + val to_source : t -> string Lwt.t + val alias_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> + (Lwt_io.file_name * t -> 'a) Cli_entries.params + val fresh_alias_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> (string -> 'a) Cli_entries.params + val source_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> (t -> 'a) Cli_entries.params +end + +module Alias = functor (Entity : Entity) -> struct + + let encoding = + let open Data_encoding in + list (obj2 + (req "name" string) + (req "value" Entity.encoding)) + + let filename () = + Client_config.(base_dir#get // Entity.name ^ "s") + + let load () = + let filename = filename () in + if not (Sys.file_exists filename) then return [] else + Data_encoding.Json.read_file filename >>= function + | None -> + error "couldn't to read the %s alias file" Entity.name + | Some json -> + match Data_encoding.Json.destruct encoding json with + | exception _ -> (* TODO print_error *) + error "didn't understand the %s alias file" Entity.name + | list -> + return list + + let find_opt name = + load () >>= fun list -> + try return (Some (List.assoc name list)) + with Not_found -> return None + + let find name = + load () >>= fun list -> + try return (List.assoc name list) + with Not_found -> error "no %s alias named %s" Entity.name name + + let rev_find v = + load () >>= fun list -> + try return (Some (List.find (fun (_, v') -> v = v') list |> fst)) + with Not_found -> return None + + let mem name = + load () >>= fun list -> + try + ignore (List.assoc name list) ; + Lwt.return true + with + | Not_found -> Lwt.return false + + let save list = + catch + (fun () -> + let dirname = Client_config.base_dir#get in + (if not (Sys.file_exists dirname) then Utils.create_dir dirname + else return ()) >>= fun () -> + let filename = filename () in + let json = Data_encoding.Json.construct encoding list in + Data_encoding.Json.write_file filename json >>= function + | false -> fail (Failure "Json.write_file") + | true -> return ()) + (fun exn -> + error "could not write the %s alias file: %s." + Entity.name (Printexc.to_string exn)) + + let add name value = + let keep = ref false in + load () >>= fun list -> + (if not Client_config.force#get then + Lwt_list.iter_s (fun (n, v) -> + if n = name && v = value then + (message "The %s alias %s already exists with the same value." Entity.name n ; + keep := true ; + return ()) + else if n = name && v <> value then + error "another %s is already aliased as %s, use -force true to update" Entity.name n + else if n <> name && v = value then + error "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n + else return ()) + list else return ()) >>= fun () -> + let list = List.filter (fun (n, _) -> n <> name) list in + let list = (name, value) :: list in + if !keep then + return () + else + save list >>= fun () -> + message "New %s alias '%s' saved." Entity.name name ; + return () + + let del name = + load () >>= fun list -> + let list = List.filter (fun (n, _) -> n <> name) list in + save list + + let save list = + save list >>= fun () -> + message "Successful update of the %s alias file." Entity.name ; + return () + + include Entity + + let alias_param ?(n = "name") ?(desc = "existing " ^ name ^ " alias") next = + Param (n, desc, (fun s -> find s >>= fun v -> return (s, v)), next) + + let fresh_alias_param ?(n = "new") ?(desc = "new " ^ name ^ " alias") next = + Param (n, + desc, + (fun s -> + load () >>= fun list -> + if not Client_config.force#get then + Lwt_list.iter_s (fun (n, _v) -> + if n = name then + error "the %s alias %s already exists, use -force true to update" Entity.name n + else return ()) + list >>= fun () -> + return s + else return s), + next) + + let source_param ?(n = "src") ?(desc = "source " ^ name) next = + Param (n, + desc ^ "\n" + ^ "can be an alias, file or litteral (autodetected in this order)\n\ + use 'file:path', 'text:litteral' or 'alias:name' to force", + (fun s -> + let read path = + catch + (fun () -> Lwt_io.(with_file ~mode:Input path read)) + (fun exn -> param_error "cannot read file (%s)" (Printexc.to_string exn)) + >>= of_source in + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "text" ; text ] -> + of_source text + | [ "file" ; path ] -> + read path + | _ -> + catch + (fun () -> find s) + (fun _ -> + catch + (fun () -> read s) + (fun _ -> of_source s))), + next) + + let name d = + rev_find d >>= function + | None -> Entity.to_source d + | Some name -> Lwt.return name + +end diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli new file mode 100644 index 000000000..70296652c --- /dev/null +++ b/src/client/client_aliases.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +module type Entity = sig + type t + val encoding : t Data_encoding.t + val of_source : string -> t Lwt.t + val to_source : t -> string Lwt.t + val name : string +end + +module type Alias = sig + type t + val load : unit -> (Lwt_io.file_name * t) list Lwt.t + val find : Lwt_io.file_name -> t Lwt.t + val find_opt : Lwt_io.file_name -> t option Lwt.t + val rev_find : t -> Lwt_io.file_name option Lwt.t + val name : t -> string Lwt.t + val mem : Lwt_io.file_name -> bool Lwt.t + val add : Lwt_io.file_name -> t -> unit Lwt.t + val del : Lwt_io.file_name -> unit Lwt.t + val save : (Lwt_io.file_name * t) list -> unit Lwt.t + val to_source : t -> string Lwt.t + val alias_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> + (Lwt_io.file_name * t -> 'a) Cli_entries.params + val fresh_alias_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> (string -> 'a) Cli_entries.params + val source_param : + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> (t -> 'a) Cli_entries.params +end +module Alias (Entity : Entity) : Alias with type t = Entity.t diff --git a/src/client/client_config.ml b/src/client/client_config.ml new file mode 100644 index 000000000..62af71802 --- /dev/null +++ b/src/client/client_config.ml @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Configuration and Arguments Parsing *) + +open Config_file + +let (//) = Filename.concat + +let home = + try Sys.getenv "HOME" + with Not_found -> "/root" + +class string_option_cp ?group name ?short_name default help = + object (self) + inherit [string] option_cp + string_wrappers ?group name ?short_name default help + method get_spec = + let set = function + | "" + | "none" -> self#set None | s -> self#set (Some s) in + Arg.String set + end + +let file_group = new group + +(* Command line options *) + +let cli_group = new group + +let base_dir = + new filename_cp ~group:cli_group ["base-dir"] (home // ".tezos-client") + "The directory where the Tezos client will store all its data." + +let config_file = + new filename_cp ~group:cli_group ["config-file"] (base_dir#get // "config") + "The main configuration file." + +let print_timings = + new bool_cp ~group:cli_group ["timings"] false + "Show RPC request times." + +let force = + new bool_cp ~group:cli_group ["force"] false + "Show less courtesy than the average user." + +let block = + new string_cp ~group:cli_group ["block"] "prevalidation" + "The block on which to apply contextual commands." + +let block () = + match Node_rpc_services.Blocks.parse_block block#get with + | Ok s -> s + | Error _ -> raise (Arg.Bad "Can't parse -block") + +let () = + let config_file_forced = ref false in + let update_config _old_file _new_file = config_file_forced := true in + let update_base_dir old_dir new_dir = + if new_dir <> old_dir then + if not !config_file_forced then begin + config_file#set (new_dir // "config"); + config_file_forced := false + end + in + config_file#add_hook update_config; + base_dir#add_hook update_base_dir + +(** Network options *) + +let in_both_groups cp = + file_group # add cp ; cli_group # add cp ; cp + +let incoming_addr = in_both_groups @@ + new string_cp [ "addr" ] ~short_name:"A" "127.0.0.1" + "The IP address at which the node's RPC server can be reached." + +let incoming_port = in_both_groups @@ + new int_cp [ "port" ] ~short_name:"P" 8732 + "The TCP port at which the node's RPC server can be reached." + +(* Version specific options *) + +let contextual_options : (unit -> unit) ref Protocol_hash_table.t = + Protocol_hash_table.create 7 + +let register_config_option version option = + let callback () = + file_group # add option ; + cli_group # add option in + try + let cont = Protocol_hash_table.find contextual_options version in + cont := fun () -> callback () ; !cont () + with Not_found -> + Protocol_hash_table.add contextual_options version (ref callback) + +(* Entry point *) + +let parse_args ?version usage dispatcher = + let open Lwt in + try begin match version with + | None -> () + | Some version -> + try + !(Protocol_hash_table.find contextual_options version) () + with Not_found -> () end ; + let base_args = cli_group#command_line_args "-" in + let args = ref base_args in + let anon dispatch n = match dispatch (`Arg n) with + | `Nop -> () + | `Args nargs -> args := nargs @ !args + | `Fail exn -> raise exn + | `Res _ -> assert false in + Arg.parse_argv_dynamic + ~current:(ref 0) Sys.argv args (anon (dispatcher ())) (usage base_args) ; + let dispatch = dispatcher () in + (if Sys.file_exists config_file#get then begin + try + file_group#read config_file#get ; + (* parse once again to overwrite file options by cli ones *) + Arg.parse_argv_dynamic + ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; + Lwt.return () + with Sys_error msg -> + Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg; + exit 1 + end else begin + try + (* parse once again with contextual options *) + Arg.parse_argv_dynamic + ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; + Utils.create_dir (Filename.dirname config_file#get) >>= fun () -> + file_group#write config_file#get ; + Lwt.return () + with Sys_error msg -> + Printf.eprintf + "Warning: can't create the default configuration file: %s\n%!" msg ; + Lwt.return () + end) >>= fun () -> + begin match dispatch `End with + | `Res res -> + res + | `Fail exn -> fail exn + | `Nop | `Args _ -> assert false + end + with exn -> Lwt.fail exn + +exception Found of string +let preparse name argv = + try + for i = 0 to Array.length argv - 1 do + if argv.(i) = name && i <> Array.length argv - 1 then + raise (Found argv.(i+1)) + done ; + None + with Found s -> Some s + +let preparse_args () : Node_rpc_services.Blocks.block = + begin + match preparse "-base-dir" Sys.argv with + | None -> () + | Some dir -> base_dir#set dir + end ; + begin + match preparse "-config-file" Sys.argv with + | None -> config_file#set @@ base_dir#get // "config" + | Some file -> config_file#set file + end ; + begin + if Sys.file_exists config_file#get then try + file_group#read config_file#get ; + with Sys_error msg -> + Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg; + exit 1 + end ; + begin + match preparse "-addr" Sys.argv with + | None -> () + | Some addr -> incoming_addr#set addr + end ; + begin + match preparse "-port" Sys.argv with + | None -> () + | Some port -> + try incoming_port#set (int_of_string port) + with _ -> + Printf.eprintf "Error: can't parse the -port option: %S.\n%!" port ; + exit 1 end ; + match preparse "-block" Sys.argv with + | None -> `Prevalidation + | Some x -> + match Node_rpc_services.Blocks.parse_block x with + | Error _ -> + Printf.eprintf "Error: can't parse the -block option: %S.\n%!" x ; + exit 1 + | Ok b -> b diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml new file mode 100644 index 000000000..0abbb17e9 --- /dev/null +++ b/src/client/client_generic_rpcs.ml @@ -0,0 +1,347 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Generic JSON RPC interface *) + +open Lwt +open Cli_entries +open Json_schema + +(*-- Assisted, schema directed input fill in --------------------------------*) + +exception Erroneous_construct +exception Unsupported_construct + +type input = { + int : int -> int -> string option -> string list -> int Lwt.t ; + float : string option -> string list -> float Lwt.t ; + string : string option -> string list -> string Lwt.t ; + bool : string option -> string list -> bool Lwt.t ; + continue : string option -> string list -> bool Lwt.t ; + display : string -> unit Lwt.t ; +} + +(* generic JSON generation from a schema with callback for random or + interactive filling *) +let fill_in input schema = + let rec element path { title ; kind }= + match kind with + | Integer -> + input.int 0 (1 lsl 30 - 1) title path >>= fun i -> + return (`Float (float i)) + | Number -> + input.float title path >>= fun f -> + return (`Float f) + | Boolean -> + input.bool title path >>= fun f -> + return (`Bool f) + | String _ -> + input.string title path >>= fun f -> + return (`String f) + | Combine ((One_of | Any_of), elts) -> + let nb = List.length elts in + input.int 0 (nb - 1) (Some "Select the schema to follow") path >>= fun n -> + element path (List.nth elts n) + | Combine ((All_of | Not), _) -> fail Unsupported_construct + | Def_ref name -> + return (`String (Json_query.json_pointer_of_path name)) +(* (try element path (find_definition name schema) + with Not_found -> fail Erroneous_construct) *) + | Id_ref _ | Ext_ref _ -> + fail Unsupported_construct + | Array (elts, _) -> + let rec fill_loop acc n ls = + match ls with + | [] -> return acc + | elt :: elts -> + element (string_of_int n :: path) elt >>= fun json -> + fill_loop (json :: acc) (succ n) elts + in + fill_loop [] 0 elts >>= fun acc -> + return (`A (List.rev acc)) + | Object { properties } -> + let rec fill_loop acc ls = + match ls with + | [] -> return acc + | (n, elt, _, _) :: elts -> + element (n :: path) elt >>= fun json -> + fill_loop ((n, json) :: acc) elts + in + fill_loop [] properties >>= fun acc -> + return (`O (List.rev acc)) + | Monomorphic_array (elt, specs) -> + let rec fill_loop acc min n max = + if n > max then + return acc + else + element (string_of_int n :: path) elt >>= fun json -> + (if n < min then return true else input.continue title path) >>= function + | true -> fill_loop (json :: acc) min (succ n) max + | false -> return (json :: acc) + in + let max = match specs.max_items with None -> max_int | Some m -> m in + fill_loop [] specs.min_items 0 max >>= fun acc -> + return (`A (List.rev acc)) + | Any -> fail Unsupported_construct + | Dummy -> fail Unsupported_construct + | Null -> return `Null + in + element [] (Json_schema.root schema) + +let random_fill_in schema = + let display _ = return () in + let int min max _ _ = return (Random.int (max - min) + min) in + let string _title _ = return "" in + let float _ _ = return (Random.float infinity) in + let bool _ _ = return (Random.int 2 = 0) in + let continue _ _ = return (Random.int 4 = 0) in + catch + (fun () -> + fill_in + { int ; float ; string ; bool ; display ; continue } + schema >>= fun json -> + return (Ok json)) + (fun e -> + let msg = Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e) in + return (Error msg)) + +let editor_fill_in schema = + let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in + let rec init () = + (* write a temp file with instructions *) + random_fill_in schema >>= function + | Error msg -> return (Error msg) + | Ok json -> + Lwt_io.(with_file Output tmp (fun fp -> + write_line fp (Data_encoding.Json.to_string json))) >>= fun () -> + edit () + and edit () = + (* launch the user's editor on it *) + let editor_cmd = + try let ed = Sys.getenv "EDITOR" in Lwt_process.shell (ed ^ " " ^ tmp) + with Not_found -> + try let ed = Sys.getenv "VISUAL" in Lwt_process.shell (ed ^ " " ^ tmp) + with Not_found -> + if Sys.win32 then + (* TODO: I have no idea what I'm doing here *) + ("", [| "notepad.exe" ; tmp |]) + else + (* TODO: vi on MacOSX ? *) + ("", [| "nano" ; tmp |]) + in + (Lwt_process.open_process_none editor_cmd) # status >>= function + | Unix.WEXITED 0 -> + reread () >>= fun json -> + delete () >>= fun () -> + return json + | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x -> + let msg = Printf.sprintf "FAILED %d \n%!" x in + delete () >>= fun () -> + return (Error msg) + and reread () = + (* finally reread the file *) + Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text -> + return (Data_encoding.Json.from_string text) + and delete () = + (* and delete the temp file *) + Lwt_unix.unlink tmp + in + init () + +(*-- Nice list display ------------------------------------------------------*) + +module StringMap = Map.Make(String) + +let rec count = + let open RPC.Description in + function + | Dynamic _ -> 1 + | Static { service ; subdirs } -> + let service = + match service with + | None -> 0 + | Some _ -> 1 in + let subdirs = + match subdirs with + | None -> 0 + | Some (Suffixes subdirs) -> + StringMap.fold (fun _ t r -> r + count t) subdirs 0 + | Some (Arg (_, subdir)) -> count subdir in + service + subdirs + +(*-- Commands ---------------------------------------------------------------*) + +let list url () = + let args = Utils.split '/' url in + Client_node_rpcs.describe ~recurse:true args >>= fun tree -> + let open RPC.Description in + let collected_args = ref [] in + let collect arg = + if not (arg.RPC.Arg.descr <> None && List.mem arg !collected_args) then + collected_args := arg :: !collected_args in + let display_paragraph ppf description = + Format.fprintf ppf "@, @[%a@]" + (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words) + (Utils.split ' ' description) + in + let display_arg ppf arg = + match arg.RPC.Arg.descr with + | None -> Format.fprintf ppf "%s" arg.RPC.Arg.name + | Some descr -> + Format.fprintf ppf "<%s>%a" arg.RPC.Arg.name display_paragraph descr + in + let display_service ppf (_path, tpath, service) = + Format.fprintf ppf "- /%s" (String.concat "/" tpath) ; + match service.description with + | None | Some "" -> () + | Some description -> display_paragraph ppf description + in + let rec display ppf (path, tpath, tree) = + match tree with + | Dynamic description -> begin + Format.fprintf ppf "- /%s " (String.concat "/" tpath) ; + match description with + | None | Some "" -> () + | Some description -> display_paragraph ppf description + end + | Static { service = None ; subdirs = None } -> () + | Static { service = Some service ; subdirs = None } -> + display_service ppf (path, tpath, service) + | Static { service ; subdirs = Some (Suffixes subdirs) } -> begin + match service, StringMap.bindings subdirs with + | None, [] -> () + | None, [ n, solo ] -> + display ppf (path @ [ n ], tpath @ [ n ], solo) + | None, items when count tree >= 3 && path <> [] -> + Format.fprintf ppf "@[+ %s/@,%a@]" + (String.concat "/" path) (display_list tpath) items + | Some service, items when count tree >= 3 && path <> [] -> + Format.fprintf ppf "@[+ %s@,%a@,%a@]" + (String.concat "/" path) + display_service (path, tpath, service) + (display_list tpath) items + | None, (n, t) :: items -> + Format.fprintf ppf "%a" + display (path @ [ n ], tpath @ [ n ], t) ; + List.iter + (fun (n, t) -> + Format.fprintf ppf "@,%a" + display (path @ [ n ], tpath @ [ n ], t)) + items + | Some service, items -> + display_service ppf (path, tpath, service) ; + List.iter + (fun (n, t) -> + Format.fprintf ppf "@,%a" + display (path @ [ n ], tpath @ [ n ], t)) + items + end + | Static { service = None ; subdirs = Some (Arg (arg, solo)) } -> + collect arg ; + let name = Printf.sprintf "<%s>" arg.RPC.Arg.name in + display ppf (path @ [ name ], tpath @ [ name ], solo) + | Static { service = Some service ; + subdirs = Some (Arg (arg, solo)) } -> + collect arg ; + display_service ppf (path, tpath, service) ; + Format.fprintf ppf "@," ; + let name = Printf.sprintf "<%s>" arg.RPC.Arg.name in + display ppf (path @ [ name ], tpath @ [ name ], solo) + and display_list tpath = + Format.pp_print_list + (fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t)) + in + Format.printf "@ @[Available services:@ @ %a@]@." + display (args, args, tree) ; + if !collected_args <> [] then + Format.printf "@,@[Dynamic parameter description:@ @ %a@]@." + (Format.pp_print_list display_arg) !collected_args ; + return () + + +let schema url () = + let args = Utils.split '/' url in + let open RPC.Description in + Client_node_rpcs.describe ~recurse:false args >>= function + | Static { service = Some { input ; output } } -> + Printf.printf "Input schema:\n%s\nOutput schema:\n%s\n%!" + (Data_encoding.Json.to_string (Json_schema.to_json input)) + (Data_encoding.Json.to_string (Json_schema.to_json output)); + return () + | _ -> + Printf.printf + "No service found at this URL (but this is a valid prefix)\n%!" ; + return () + +let fill_in schema = + let open Json_schema in + match (root schema).kind with + | Null -> Lwt.return (Ok `Null) + | Any | Object { properties = [] } -> Lwt.return (Ok (`O [])) + | _ -> editor_fill_in schema + +let call url () = + let args = Utils.split '/' url in + let open RPC.Description in + Client_node_rpcs.describe ~recurse:false args >>= function + | Static { service = Some { input } } -> begin + fill_in input >>= function + | Error _ -> + error "bad input" + | Ok json -> + Client_node_rpcs.get_json args json >>= fun json -> + Printf.printf "Output:\n%s\n%!" (Data_encoding.Json.to_string json) ; + return () + end + | _ -> + Printf.printf + "No service found at this URL (but this is a valid prefix)\n%!" ; + return () + +let () = + let open Cli_entries in + register_tag "low-level" "low level commands for advanced users" ; + register_tag "local" "commands that do not require a running node" ; + register_tag "debug" "commands mostly useful for debugging" ; + register_group "rpc" "Commands for the low level RPC layer" + +let commands = Cli_entries.([ + command + ~tags: [ "local" ] + ~desc: "list all understood protocol versions" + (fixed [ "list" ; "versions" ]) + (fun () -> + List.iter + (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver) + (Client_version.get_versions ()) ; return ()) ; + command + ~tags: [ "low-level" ; "local" ] + ~group: "rpc" + ~desc: "list available RPCs (low level command for advanced users)" + (prefixes [ "rpc" ; "list" ] @@ stop) + (list "/"); + command + ~tags: [ "low-level" ; "local" ] + ~group: "rpc" + ~desc: "list available RPCs (low level command for advanced users)" + (prefixes [ "rpc" ; "list" ] @@ string "url" "the RPC's prefix to be described" @@ stop) + list ; + command + ~tags: [ "low-level" ; "local" ] + ~group: "rpc" + ~desc: "get the schemas of an RPC" + (prefixes [ "rpc" ; "schema" ] @@ string "url" "the RPC's URL" @@ stop) + schema ; + command + ~tags: [ "low-level" ; "local" ] + ~group: "rpc" + ~desc: "call an RPC (low level command for advanced users)" + (prefixes [ "rpc" ; "call" ] @@ string "url" "the RPC's URL" @@ stop) + call + ]) diff --git a/src/client/client_generic_rpcs.mli b/src/client/client_generic_rpcs.mli new file mode 100644 index 000000000..7c819c892 --- /dev/null +++ b/src/client/client_generic_rpcs.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val commands: Cli_entries.command list diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml new file mode 100644 index 000000000..535f50b89 --- /dev/null +++ b/src/client/client_keys.ml @@ -0,0 +1,137 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Public_key_hash = Client_aliases.Alias (struct + type t = Ed25519.Public_key_hash.t + let encoding = Ed25519.Public_key_hash.encoding + let of_source s = Lwt.return (Ed25519.Public_key_hash.of_b48check s) + let to_source p = Lwt.return (Ed25519.Public_key_hash.to_b48check p) + let name = "public key hash" + end) + +module Public_key = Client_aliases.Alias (struct + type t = Ed25519.public_key + let encoding = Ed25519.public_key_encoding + let of_source s = + Lwt.return (Sodium.Sign.Bytes.to_public_key + (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s))) + let to_source p = + Lwt.return B64.(encode ~alphabet:uri_safe_alphabet + (Bytes.to_string (Sodium.Sign.Bytes.of_public_key p))) + let name = "public key" + end) + +module Secret_key = Client_aliases.Alias (struct + type t = Ed25519.secret_key + let encoding = Ed25519.secret_key_encoding + let of_source s = + Lwt.return (Sodium.Sign.Bytes.to_secret_key + (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s))) + let to_source p = + Lwt.return B64.(encode ~alphabet:uri_safe_alphabet + (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key p))) + let name = "secret key" + end) + +let gen_keys name = + let secret_key, public_key = Sodium.Sign.random_keypair () in + Secret_key.add name secret_key >>= fun () -> + Public_key.add name public_key >>= fun () -> + Public_key_hash.add name (Ed25519.hash public_key) >>= fun () -> + Cli_entries.message "I generated a brand new pair of keys under the name '%s'." name ; + Lwt.return () + +let check_keys_consistency pk sk = + let message = MBytes.of_string "Voulez-vous coucher avec moi, ce soir ?" in + let signature = Ed25519.sign sk message in + Ed25519.check_signature pk signature message + +let get_key pkh = + Public_key_hash.rev_find pkh >>= function + | None -> Cli_entries.error "no keys for the source contract manager" + | Some n -> + Public_key.find n >>= fun pk -> + Secret_key.find n >>= fun sk -> + return (n, pk, sk) + +let commands () = + let open Cli_entries in + register_group "keys" "Commands for managing cryptographic keys" ; + [ command + ~group: "keys" + ~desc: "generate a pair of keys" + (prefixes [ "gen" ; "keys" ] + @@ Secret_key.fresh_alias_param + @@ stop) + (fun name () -> gen_keys name) ; + command + ~group: "keys" + ~desc: "add a secret key to the wallet" + (prefixes [ "add" ; "secret" ; "key" ] + @@ Secret_key.fresh_alias_param + @@ Secret_key.source_param + @@ stop) + (fun name sk () -> + Lwt.catch (fun () -> + Public_key.find name >>= fun pk -> + if check_keys_consistency pk sk || Client_config.force#get then + Secret_key.add name sk + else + error "public and secret keys '%s' don't correspond, \ + please don't use -force true" name) + (function + | Not_found -> + error "no public key named '%s', add it before adding the secret key" name + | exn -> Lwt.fail exn)) ; + command + ~group: "keys" + ~desc: "add a public key to the wallet" + (prefixes [ "add" ; "public" ; "key" ] + @@ Public_key.fresh_alias_param + @@ Public_key.source_param + @@ stop) + (fun name key () -> + Public_key_hash.add name (Ed25519.hash key) >>= fun () -> + Public_key.add name key) ; + command + ~group: "keys" + ~desc: "add an ID a public key hash to the wallet" + (prefixes [ "add" ; "identity" ] + @@ Public_key_hash.fresh_alias_param + @@ Public_key_hash.source_param + @@ stop) + (fun name hash () -> + Public_key_hash.add name hash) ; + command + ~group: "keys" + ~desc: "list all public key hashes and associated keys" + (fixed [ "list" ; "known" ; "identities" ]) + (fun () -> + Public_key_hash.load () >>= fun l -> + Lwt_list.iter_s (fun (name, pkh) -> + Public_key.mem name >>= fun pkm -> + Secret_key.mem name >>= fun pks -> + Public_key_hash.to_source pkh >>= fun v -> + message "%s: %s%s%s" name v + (if pkm then " (public key known)" else "") + (if pks then " (secret key known)" else "") ; + Lwt.return ()) + l) ; + command + ~group: "keys" + ~desc: "forget all keys" + (fixed [ "forget" ; "all" ; "keys" ]) + (fun () -> + if not Client_config.force#get then + error "this can only used with option -force true" + else + Public_key.save [] >>= fun () -> + Secret_key.save [] >>= fun () -> + Public_key_hash.save []) ; + ] diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli new file mode 100644 index 000000000..e88391533 --- /dev/null +++ b/src/client/client_keys.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +module Public_key_hash : Client_aliases.Alias with type t = Ed25519.public_key_hash +module Public_key : Client_aliases.Alias with type t = Ed25519.public_key +module Secret_key : Client_aliases.Alias with type t = Ed25519.secret_key + +val get_key: + Public_key_hash.t -> + ( string * Public_key.t * Secret_key.t ) tzresult Lwt.t + + +val commands: unit -> Cli_entries.command list diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml new file mode 100644 index 000000000..bab832207 --- /dev/null +++ b/src/client/client_node_rpcs.ml @@ -0,0 +1,209 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - RPC Calls *) + +open Lwt +open Cli_entries +open Logging.RPC + +let log_file = + let open CalendarLib in + Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ.log" + (Calendar.Precise.now ()) + +let with_log_file f = + Utils.create_dir Client_config.(base_dir#get // "logs") >>= fun () -> + Lwt_io.with_file + ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] + ~mode: Lwt_io.Output + Client_config.(base_dir#get // "logs" // log_file) + f + +let log_request cpt url req = + with_log_file + (fun fp -> + Lwt_io.fprintf fp">>>>%d: %s\n%s\n" cpt url req >>= fun () -> + Lwt_io.flush fp) + +let log_response cpt code ans = + with_log_file + (fun fp -> + Lwt_io.fprintf fp"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans >>= fun () -> + Lwt_io.flush fp) + +let cpt = ref 0 +let make_request service json = + incr cpt ; + let cpt = !cpt in + let serv = "http://" ^ Client_config.incoming_addr#get + ^ ":" ^ string_of_int Client_config.incoming_port#get in + let string_uri = String.concat "/" (serv :: service) in + let uri = Uri.of_string string_uri in + let reqbody = Data_encoding.Json.to_string json in + let tzero = Unix.gettimeofday () in + catch + (fun () -> + let body = Cohttp_lwt_body.of_string reqbody in + Cohttp_lwt_unix.Client.post ~body uri >>= fun (code, ansbody) -> + log_request cpt string_uri reqbody >>= fun () -> + return (cpt, Unix.gettimeofday () -. tzero, + code.Cohttp.Response.status, ansbody)) + (fun e -> + let msg = match e with + | Unix.Unix_error (e, _, _) -> Unix.error_message e + | e -> Printexc.to_string e in + error "cannot connect to the RPC server (%s)" msg) + +let get_streamed_json service json = + make_request service json >>= fun (_cpt, time, code, ansbody) -> + let ansbody = Cohttp_lwt_body.to_stream ansbody in + match code, ansbody with + | #Cohttp.Code.success_status, ansbody -> + if Client_config.print_timings#get then + message "Request to /%s succeeded in %gs" + (String.concat "/" service) time ; + Lwt.return ( + Lwt_stream.filter_map_s + (function + | Ok v -> Lwt.return (Some v) + | Error msg -> + lwt_log_error + "Failed to parse json: %s" msg >>= fun () -> + Lwt.return None) + (Data_encoding.Json.from_stream ansbody)) + | err, _ansbody -> + if Client_config.print_timings#get then + message "Request to /%s failed in %gs" + (String.concat "/" service) time ; + message "Request to /%s failed, server returned %s" + (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + error "the RPC server returned a non-success status (%s)" + (Cohttp.Code.string_of_status err) + +let get_json service json = + make_request service json >>= fun (cpt, time, code, ansbody) -> + Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> + match code, ansbody with + | #Cohttp.Code.success_status, ansbody -> begin + if Client_config.print_timings#get then + message "Request to /%s succeeded in %gs" + (String.concat "/" service) time ; + log_response cpt code ansbody >>= fun () -> + if ansbody = "" then Lwt.return `Null + else match Data_encoding.Json.from_string ansbody with + | Error _ -> error "the RPC server returned malformed JSON" + | Ok res -> Lwt.return res + end + | err, _ansbody -> + if Client_config.print_timings#get then + message "Request to /%s failed in %gs" + (String.concat "/" service) time ; + message "Request to /%s failed, server returned %s" + (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + error "the RPC server returned a non-success status (%s)" + (Cohttp.Code.string_of_status err) + +exception Unknown_error of Data_encoding.json + +let parse_answer service path json = + match RPC.read_answer service json with + | Error msg -> (* TODO print_error *) + error "request to /%s returned wrong JSON (%s)\n%s" + (String.concat "/" path) msg (Data_encoding.Json.to_string json) + | Ok v -> return v + +let call_service0 service arg = + let path, arg = RPC.forge_request service () arg in + get_json path arg >>= parse_answer service path + +let call_service1 service a1 arg = + let path, arg = RPC.forge_request service ((), a1) arg in + get_json path arg >>= parse_answer service path + +let call_service2 service a1 a2 arg = + let path, arg = RPC.forge_request service (((), a1), a2) arg in + get_json path arg >>= parse_answer service path + +let call_streamed_service0 service arg = + let path, arg = RPC.forge_request service () arg in + get_streamed_json path arg >|= fun st -> + Lwt_stream.map_s (parse_answer service path) st + +module Services = Node_rpc_services +let errors = call_service0 RPC.Error.service +let forge_block ?net ?predecessor ?timestamp fitness ops header = + call_service0 Services.forge_block + (net, predecessor, timestamp, fitness, ops, header) +let validate_block net block = + call_service0 Services.validate_block (net, block) +let inject_block ?(wait = true) ?force block = + call_service0 Services.inject_block (block, wait, force) +let inject_operation ?(wait = true) ?force operation = + call_service0 Services.inject_operation (operation, wait, force) +let describe ?recurse path = + let prefix, arg = RPC.forge_request Services.describe () recurse in + get_json (prefix @ path) arg >>= + parse_answer Services.describe prefix + +type net = Services.Blocks.net = Net of Block_hash.t + +module Blocks = struct + type block = Services.Blocks.block + + type block_info = Services.Blocks.block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + operations: Operation_hash.t list option ; + net: net ; + test_protocol: Protocol_hash.t option ; + test_network: (net * Time.t) option ; + } + type preapply_param = Services.Blocks.preapply_param = { + operations: Operation_hash.t list ; + sort: bool ; + timestamp: Time.t option ; + } + type preapply_result = Services.Blocks.preapply_result = { + operations: error Updater.preapply_result ; + fitness: MBytes.t list ; + timestamp: Time.t ; + } + let net h = call_service1 Services.Blocks.net h () + let predecessor h = call_service1 Services.Blocks.predecessor h () + let hash h = call_service1 Services.Blocks.hash h () + let timestamp h = call_service1 Services.Blocks.timestamp h () + let fitness h = call_service1 Services.Blocks.fitness h () + let operations h = call_service1 Services.Blocks.operations h () + let protocol h = call_service1 Services.Blocks.protocol h () + let test_protocol h = call_service1 Services.Blocks.test_protocol h () + let test_network h = call_service1 Services.Blocks.test_network h () + let preapply h ?timestamp ?(sort = false) operations = + call_service1 Services.Blocks.preapply h { operations ; sort ; timestamp } + let pending_operations block = + call_service1 Services.Blocks.pending_operations block () + let info ?(operations = false) h = + call_service1 Services.Blocks.info h operations + let list ?operations ?length ?heads ?delay () = + call_service0 Services.Blocks.list + { operations; length ; heads ; monitor = Some false ; delay } + let monitor ?operations ?length ?heads ?delay () = + call_streamed_service0 Services.Blocks.list + { operations; length ; heads ; monitor = Some true ; delay } +end + +module Operations = struct + let monitor ?contents () = + call_streamed_service0 Services.Operations.list + { monitor = Some true ; contents } +end diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli new file mode 100644 index 000000000..d1c238ee0 --- /dev/null +++ b/src/client/client_node_rpcs.mli @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type net = State.net_id = Net of Block_hash.t + +val errors: unit -> Json_schema.schema Lwt.t +val forge_block: + ?net:Updater.net_id -> + ?predecessor:Block_hash.t -> + ?timestamp:Time.t -> + Fitness.fitness -> + Operation_hash.t list -> + MBytes.t -> + MBytes.t Lwt.t + +val validate_block: net -> Block_hash.t -> unit tzresult Lwt.t +val inject_block: + ?wait:bool -> ?force:bool -> MBytes.t -> + Block_hash.t tzresult Lwt.t +val inject_operation: + ?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t + +module Blocks : sig + + type block = [ + | `Genesis + | `Head of int | `Prevalidation + | `Test_head of int | `Test_prevalidation + | `Hash of Block_hash.t + ] + + val net: block -> net Lwt.t + val predecessor: block -> Block_hash.t Lwt.t + val hash: block -> Block_hash.t Lwt.t + val timestamp: block -> Time.t Lwt.t + val fitness: block -> MBytes.t list Lwt.t + val operations: block -> Operation_hash.t list Lwt.t + val protocol: block -> Protocol_hash.t Lwt.t + val test_protocol: block -> Protocol_hash.t option Lwt.t + val test_network: block -> (net * Time.t) option Lwt.t + + val pending_operations: + block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t + + type block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + operations: Operation_hash.t list option ; + net: net ; + test_protocol: Protocol_hash.t option ; + test_network: (net * Time.t) option ; + } + + val info: + ?operations:bool -> block -> block_info Lwt.t + + val list: + ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> + unit -> block_info list list Lwt.t + + val monitor: + ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> + unit -> block_info list list Lwt_stream.t Lwt.t + + type preapply_result = { + operations: error Updater.preapply_result ; + fitness: MBytes.t list ; + timestamp: Time.t ; + } + + val preapply: + block -> + ?timestamp:Time.t -> + ?sort:bool -> + Hash.Operation_hash.t list -> preapply_result tzresult Lwt.t + +end + +module Operations : sig + val monitor: + ?contents:bool -> unit -> + (Operation_hash.t * Store.operation option) list Lwt_stream.t Lwt.t +end + +val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t + +(** Low-level *) + +val get_json: string list -> Data_encoding.json -> Data_encoding.json Lwt.t + +val call_service0: + (unit, unit, 'i, 'o) RPC.service -> 'i -> 'o Lwt.t +val call_service1: + (unit, unit * 'a, 'i, 'o) RPC.service -> 'a -> 'i -> 'o Lwt.t +val call_service2: + (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> 'a -> 'b -> 'i -> 'o Lwt.t diff --git a/src/client/client_version.ml b/src/client/client_version.ml new file mode 100644 index 000000000..bbc4fdfa5 --- /dev/null +++ b/src/client/client_version.ml @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +(* A global store for version indexed commands. *) + +exception Version_not_found + +let versions = Protocol_hash_table.create 7 + +let get_versions () = + Protocol_hash_table.fold + (fun k c acc -> (k, c) :: acc) + versions + [] + +let register name commands = + let previous = + try Protocol_hash_table.find versions name + with Not_found -> [] in + Protocol_hash_table.add versions name (commands @ previous) + +let commands_for_version version = + try Protocol_hash_table.find versions version + with Not_found -> raise Version_not_found diff --git a/src/client/client_version.mli b/src/client/client_version.mli new file mode 100644 index 000000000..eefd4cbdf --- /dev/null +++ b/src/client/client_version.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Cli_entries + +exception Version_not_found + +val register: Protocol_hash.t -> command list -> unit +val commands_for_version: Protocol_hash.t -> command list +val get_versions: unit -> (Protocol_hash.t * (command list)) list diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared new file mode 100644 index 000000000..e2aa12c45 --- /dev/null +++ b/src/client/embedded/Makefile.shared @@ -0,0 +1,78 @@ + +all: ../client_$(PROTO_VERSION).cmx + +include ../../../Makefile.config + +NODE_DIRECTORIES = \ + $(addprefix ../../../, \ + utils \ + node/updater \ + node/db \ + node/net \ + node/shell \ + client \ +) + +SOURCE_DIRECTORIES += \ + ${NODE_DIRECTORIES} \ + ../../../proto + +OPENED_MODULES := \ + Client_embedded_proto_${PROTO_VERSION} \ + Register_client_embedded_proto_${PROTO_VERSION} \ + Error_monad \ + Hash \ + ${OPENED_MODULES} + +OBJS := \ + ${IMPLS:.ml=.cmx} ${IMPLS:.ml=.ml.deps} \ + ${INTFS:.mli=.cmi} ${INTFS:.mli=.mli.deps} \ + ../client_$(PROTO_VERSION).cmx +${OBJS}: TARGET="(client_$(PROTO_VERSION).cmx)" +${OBJS}: PACKAGES=lwt ocplib-json-typed config-file sodium +${OBJS}: ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa + +../client_$(PROTO_VERSION).cmx: $(patsubst %.ml, %.cmx, ${IMPLS}) + @echo LINK $(notdir $@) + @$(OCAMLOPT) -linkall ${OCAMLFLAGS} -pack -o $@ \ + $(patsubst %.ml, %.cmx, ${IMPLS}) + +%.cmx: %.ml + @echo OCAMLOPT ${TARGET} $(notdir $@) + @$(OCAMLOPT) ${OCAMLFLAGS} -for-pack Client_$(PROTO_VERSION) -c $< + +%.cmi: %.mli + @echo OCAMLOPT ${TARGET} $(notdir $@) + @$(OCAMLOPT) ${OCAMLFLAGS} -for-pack Client_$(PROTO_VERSION) -c $< + +%.ml: %.mll + @echo OCAMLLEX ${TARGET} $(notdir $@) + @$(OCAMLLEX) $< + +%.ml %.mli: %.mly + @echo MENHIR ${TARGET} $(notdir $@) + @$(MENHIR) --explain $< + +.PHONY: clean +clean:: + -rm -f ../client_$(PROTO_VERSION).cm* ../client_$(PROTO_VERSION).o + -rm -f *.cm* *~ *.o *.a *.deps + -rm -rf _tzbuild + -rm -f .depend + +ifneq ($(MAKECMDGOALS),clean) +-include .depend +endif + +predepend: + +DEPENDS := ${INTFS} ${IMPLS} +.SECONDARY: $(patsubst %,%.deps,${DEPENDS}) +.depend: $(patsubst %,%.deps,${DEPENDS}) + @cat $^ > .depend +%.ml.deps: %.ml | predepend + @echo OCAMLDEP ${TARGET} $(notdir $<) + @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $^ > $@ +%.mli.deps: %.mli | predepend + @echo OCAMLDEP ${TARGET} $(notdir $<) + @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $^ > $@ diff --git a/src/client/embedded/bootstrap/.merlin b/src/client/embedded/bootstrap/.merlin new file mode 100644 index 000000000..a8b40a7ca --- /dev/null +++ b/src/client/embedded/bootstrap/.merlin @@ -0,0 +1,12 @@ +REC +S . +B . +S mining +B mining +S ../../../proto +B ../../../proto +S ../../../proto/bootstrap +B _tzbuild +FLG -open Client_embedded_proto_bootstrap +FLG -open Register_client_embedded_proto_bootstrap +FLG -open Tezos_context \ No newline at end of file diff --git a/src/client/embedded/bootstrap/Makefile b/src/client/embedded/bootstrap/Makefile new file mode 100644 index 000000000..3da331ee6 --- /dev/null +++ b/src/client/embedded/bootstrap/Makefile @@ -0,0 +1,31 @@ + +PROTO_VERSION := bootstrap + +INTFS := \ + concrete_parser.mli \ + client_proto_rpcs.mli \ + client_proto_args.mli \ + client_proto_contracts.mli \ + client_proto_programs.mli \ + client_proto_context.mli \ + client_proto_nonces.mli \ + client_proto_main.mli + +IMPLS := \ + script_located_ir.ml \ + concrete_parser.ml concrete_lexer.ml \ + client_proto_rpcs.ml \ + client_proto_args.ml \ + client_proto_contracts.ml \ + client_proto_programs.ml \ + client_proto_context.ml \ + client_proto_nonces.ml \ + client_proto_main.ml + +OPENED_MODULES := Tezos_context + +predepend: concrete_parser.ml concrete_lexer.ml + +-include mining/Makefile + +include ../Makefile.shared diff --git a/src/client/embedded/bootstrap/client_proto_aliases.ml b/src/client/embedded/bootstrap/client_proto_aliases.ml new file mode 100644 index 000000000..141468d60 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_aliases.ml @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + + +(* -- aliases ----------------------------------------------------------------- *) + + +(* -- parsing ----------------------------------------------------------------- *) + diff --git a/src/client/embedded/bootstrap/client_proto_aliases.mli b/src/client/embedded/bootstrap/client_proto_aliases.mli new file mode 100644 index 000000000..447918baa --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_aliases.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Contract : Client_aliases.Alias with type t = Contract_repr.contract diff --git a/src/client/embedded/bootstrap/client_proto_args.ml b/src/client/embedded/bootstrap/client_proto_args.ml new file mode 100644 index 000000000..2e3b66991 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_args.ml @@ -0,0 +1,122 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let tez_sym = + "\xEA\x9C\xA9" + +let block () = Client_config.block () + +let tez_of_string s = + match Tez.of_string s with + | None -> invalid_arg "tez_of_string" + | Some t -> t + +let fee = ref (tez_of_string "0.05") +let fee_arg = + "-fee", + Arg.String (fun s -> + try fee := tez_of_string s + with _ -> raise (Arg.Bad "invalid \xEA\x9C\xA9 notation in parameter -fee")), + "The fee in \xEA\x9C\xA9 to pay to the miner.\n\ + default: \'0.05\"\n\ + text format: D,DDD,DDD.DD (centiles are optional, comas are optional)" + +let init = ref "void" +let init_arg = + "-init", + Arg.Set_string init, + "The initial value of the contract's storage.\n\ + default: void" + +let arg = ref None +let arg_arg = + "-arg", + Arg.String (fun a -> arg := Some a), + "The argument passed to the contract's script, if needed.\n\ + default: no argument" + +let delegate = ref None +let delegate_arg = + "-delegate", + Arg.String (fun s -> delegate := Some s), + "Set the delegate of the contract.\n\ + Must be a known identity." + +let source = ref None +let source_arg = + "-source", + Arg.String (fun s -> source := Some s), + "Set the source of the bonds to be paid.\n\ + Must be a known identity." + +let spendable = ref true +let spendable_args = + [ "-spendable", + Arg.Set spendable, + "Set the created contract to be spendable (default)" ; + "-non-spendable", + Arg.Clear spendable, + "Set the created contract to be non spendable" ] + +let force = ref false +let force_arg = + "-force", + Arg.Set force, + "Force the injection of branch-invalid operation or force \ + \ the injection of bleck without a fitness greater than the \ + \ current head." + +let delegatable = ref false +let delegatable_args = + [ "-delegatable", + Arg.Set delegatable, + "Set the created contract to be delegatable" ; + "-non-delegatable", + Arg.Clear delegatable, + "Set the created contract to be non delegatable (default)" ] + +let tez_param ~n ~desc next = + Cli_entries.param + n + (desc ^ " in \xEA\x9C\xA9\n\ + text format: D,DDD,DDD.DD (centiles and comas are optional)") + (fun s -> + try Lwt.return (tez_of_string s) + with _ -> Cli_entries.param_error "invalid \xEA\x9C\xA9 notation") + next + +let max_priority = ref None +let max_priority_arg = + "-max-priority", + Arg.String (fun s -> + try max_priority := Some (int_of_string s) + with _ -> raise (Arg.Bad "invalid priority in -max-priority")), + "Set the max_priority used when looking for mining slot." + +let endorsement_delay = ref 15 +let endorsement_delay_arg = + "-endorsement-delay", + Arg.String (fun s -> + try endorsement_delay := int_of_string s + with _ -> raise (Arg.Bad "invalid priority in -endorsement-delay")), + "Set the delay used before to endorse the current block." + +module Daemon = struct + let all = ref true + let arg r = Arg.Unit (fun () -> all := false; r := true) + let mining = ref false + let mining_arg = + "-mining", arg mining, "Run the mining daemon" + let endorsement = ref false + let endorsement_arg = + "-endorsement", arg endorsement, "Run the endorsement daemon" + let denunciation = ref false + let denunciation_arg = + "-denunciation", arg denunciation, "Run the denunciation daemon" +end diff --git a/src/client/embedded/bootstrap/client_proto_args.mli b/src/client/embedded/bootstrap/client_proto_args.mli new file mode 100644 index 000000000..fbe0ec496 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_args.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val block: unit -> Client_node_rpcs.Blocks.block + +val tez_sym: string + +val init_arg: string * Arg.spec * string +val fee_arg: string * Arg.spec * string +val arg_arg: string * Arg.spec * string +val source_arg: string * Arg.spec * string +val delegate_arg: string * Arg.spec * string +val delegatable_args: (string * Arg.spec * string) list +val spendable_args: (string * Arg.spec * string) list +val max_priority_arg: string * Arg.spec * string +val force_arg: string * Arg.spec * string +val endorsement_delay_arg: string * Arg.spec * string + +val tez_param : + n:string -> + desc:string -> + 'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params + +val delegate: string option ref +val source: string option ref +val delegatable: bool ref +val spendable: bool ref +val force: bool ref +val fee: Tez.t ref +val init: string ref +val arg: string option ref +val max_priority: int option ref +val endorsement_delay: int ref + +module Daemon : sig + val mining_arg: string * Arg.spec * string + val endorsement_arg: string * Arg.spec * string + val denunciation_arg: string * Arg.spec * string + val all: bool ref + val mining: bool ref + val endorsement: bool ref + val denunciation: bool ref +end diff --git a/src/client/embedded/bootstrap/client_proto_context.ml b/src/client/embedded/bootstrap/client_proto_context.ml new file mode 100644 index 000000000..92ed97fda --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_context.ml @@ -0,0 +1,275 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Client_proto_args +open Client_proto_contracts +open Client_proto_programs +open Client_keys + +let handle_error f () = + f () >>= Client_proto_rpcs.handle_error + +let check_contract neu = + RawContractAlias.mem neu >>= function + | true -> + Cli_entries.error "contract '%s' already exists" neu + | false -> + Lwt.return () + +let get_delegate_pkh = function + | None -> Lwt.return None + | Some delegate -> + Lwt.catch + (fun () -> + Public_key_hash.find delegate >>= fun r -> + Lwt.return (Some r)) + (fun _ -> Lwt.return None) + +let get_timestamp block () = + Client_node_rpcs.Blocks.timestamp block >>= fun v -> + Cli_entries.message "%s" (Time.to_notation v) ; + Lwt.return () + +let list_contracts block () = + Client_proto_rpcs.Context.Contract.list block >>=? fun contracts -> + iter_s (fun h -> + begin match Contract.is_default h with + | Some m -> begin + Public_key_hash.rev_find m >>= function + | None -> Lwt.return "" + | Some nm -> + RawContractAlias.find_opt nm >|= function + | None -> " (known as " ^ nm ^ ")" + | Some _ -> " (known as key:" ^ nm ^ ")" + end + | None -> begin + RawContractAlias.rev_find h >|= function + | None -> "" + | Some nm -> " (known as " ^ nm ^ ")" + end + end >>= fun nm -> + let kind = match Contract.is_default h with + | Some _ -> " (default)" + | None -> "" in + Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm; + return ()) + contracts + +let transfer block ?force + ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () = + let open Cli_entries in + Client_node_rpcs.Blocks.net block >>= fun net -> + begin match arg with + | Some arg -> + Client_proto_programs.parse_data arg >>= fun arg -> + Lwt.return (Some arg) + | None -> Lwt.return None + end >>= fun parameters -> + Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + let counter = Int32.succ pcounter in + message "Acquired the source's sequence counter (%ld -> %ld)." + pcounter counter ; + Client_proto_rpcs.Helpers.Forge.Manager.transaction block + ~net ~source ~sourcePubKey:src_pk ~counter ~amount + ~destination ?parameters ~fee () >>=? fun bytes -> + message "Forged the raw transaction frame." ; + let signed_bytes = Ed25519.append_signature src_sk bytes in + Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> + answer "Operation successfully injected in the node." ; + answer "Operation hash is '%a'." Operation_hash.pp oph ; + return () + +let originate_account block ?force + ~source ~src_pk ~src_sk ~manager_pkh ?delegatable ?spendable ?delegate ~balance ~fee () = + let open Cli_entries in + Client_node_rpcs.Blocks.net block >>= fun net -> + Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + let counter = Int32.succ pcounter in + message "Acquired the source's sequence counter (%ld -> %ld)." + pcounter counter ; + Client_proto_rpcs.Helpers.Forge.Manager.origination block + ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh + ~counter ~balance ?spendable + ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) -> + message "Forged the raw origination frame." ; + let signed_bytes = Ed25519.append_signature src_sk bytes in + Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> + message "Operation successfully injected in the node." ; + message "Operation hash is '%a'." Operation_hash.pp oph ; + return contract + +let originate_contract + block ?force + ~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey + ~(code:Script.code) ~init ~fee () = + let open Cli_entries in + Client_proto_programs.parse_data init >>= fun storage -> + let init = Script.{ storage ; storage_type = code.storage_type } in + Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + let counter = Int32.succ pcounter in + message "Acquired the source's sequence counter (%ld -> %ld)." + pcounter counter ; + Client_node_rpcs.Blocks.net block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Manager.origination block + ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh + ~counter ~balance ~spendable:!spendable + ?delegatable ?delegatePubKey + ~script:(code, init) ~fee () >>=? fun (contract, bytes) -> + message "Forged the raw origination frame." ; + let signed_bytes = Ed25519.append_signature src_sk bytes in + Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> + message "Operation successfully injected in the node." ; + message "Operation hash is '%a'." Operation_hash.pp oph ; + return contract + +let commands () = + let open Cli_entries in + register_group "context" "Block contextual commands (see option -block)" ; + [ command + ~group: "context" + ~desc: "access the timestamp of the block" + (fixed [ "get" ; "timestamp" ]) + (get_timestamp (block ())) ; + command + ~group: "context" + ~desc: "lists all non empty contracts of the block" + (fixed [ "list" ; "contracts" ]) + (handle_error (list_contracts (block ()))) ; + command + ~group: "context" + ~desc: "get the bootstrap keys and bootstrap contract handle" + (fixed [ "bootstrap" ]) + (fun () -> + Client_proto_rpcs.Constants.bootstrap `Genesis >>= fun accounts -> + let cpt = ref 0 in + Lwt_list.iter_s + (fun { Bootstrap.public_key_hash = pkh ; + public_key = pk ; secret_key = sk } -> + incr cpt ; + let name = Printf.sprintf "bootstrap%d" !cpt in + Public_key_hash.add name pkh >>= fun () -> + Public_key.add name pk >>= fun () -> + Secret_key.add name sk >>= fun () -> + message "Bootstrap keys added under the name '%s'." name; + Lwt.return_unit) + accounts >>= fun () -> + Lwt.return_unit) ; + command + ~group: "context" + ~desc: "get the balance of a contract" + (prefixes [ "get" ; "balance" ] + @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ stop) + (fun (_, contract) () -> + Client_proto_rpcs.Context.Contract.balance (block ()) contract + >>= Client_proto_rpcs.handle_error >>= fun amount -> + answer "%a %s" Tez.pp amount tez_sym; + Lwt.return ()); + command + ~group: "context" + ~desc: "get the manager of a block" + (prefixes [ "get" ; "manager" ] + @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ stop) + (fun (_, contract) () -> + Client_proto_rpcs.Context.Contract.manager (block ()) contract + >>= Client_proto_rpcs.handle_error >>= fun manager -> + Public_key_hash.rev_find manager >>= fun mn -> + Public_key_hash.to_source manager >>= fun m -> + message "%s (%s)" m + (match mn with None -> "unknown" | Some n -> "known as " ^ n) ; + Lwt.return ()); + command + ~group: "context" + ~desc: "open a new account" + ~args: ([ fee_arg ; delegate_arg ; force_arg ] + @ delegatable_args @ spendable_args) + (prefixes [ "originate" ; "account" ] + @@ RawContractAlias.fresh_alias_param + ~n: "new" ~desc: "name of the new contract" + @@ prefix "for" + @@ Public_key_hash.alias_param + ~n: "mgr" ~desc: "manager of the new contract" + @@ prefix "transfering" + @@ tez_param + ~n: "qty" ~desc: "amount taken from source" + @@ prefix "from" + @@ ContractAlias.alias_param + ~n:"src" ~desc: "name of the source contract" + @@ stop) + (fun neu (_, manager) balance (_, source) -> + handle_error @@ fun () -> + check_contract neu >>= fun () -> + get_delegate_pkh !delegate >>= fun delegate -> + Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> + Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> + message "Got the source's manager keys (%s)." src_name ; + originate_account (block ()) ~force:!force + ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee + ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate + () >>=? fun contract -> + RawContractAlias.add neu contract >>= fun () -> + return ()) ; + command + ~group: "context" + ~desc: "open a new scripted account" + ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ + delegatable_args @ spendable_args @ [ init_arg ]) + (prefixes [ "originate" ; "contract" ] + @@ RawContractAlias.fresh_alias_param + ~n: "new" ~desc: "name of the new contract" + @@ prefix "for" + @@ Public_key_hash.alias_param + ~n: "mgr" ~desc: "manager of the new contract" + @@ prefix "transfering" + @@ tez_param + ~n: "qty" ~desc: "amount taken from source" + @@ prefix "from" + @@ ContractAlias.alias_param + ~n:"src" ~desc: "name of the source contract" + @@ prefix "running" + @@ Program.source_param + ~n:"prg" ~desc: "script of the account\n\ + combine with -init if the storage type is non void" + @@ stop) + (fun neu (_, manager) balance (_, source) code -> + handle_error @@ fun () -> + check_contract neu >>= fun () -> + get_delegate_pkh !delegate >>= fun delegate -> + Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> + Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> + message "Got the source's manager keys (%s)." src_name ; + originate_contract (block ()) ~force:!force + ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee + ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init () + >>=? fun contract -> + RawContractAlias.add neu contract >>= fun () -> + return ()) ; + command + ~group: "context" + ~desc: "transfer funds" + ~args: [ fee_arg ; arg_arg ; force_arg ] + (prefixes [ "transfer" ] + @@ tez_param + ~n: "qty" ~desc: "amount taken from source" + @@ prefix "from" + @@ ContractAlias.alias_param + ~n: "src" ~desc: "name of the source contract" + @@ prefix "to" + @@ ContractAlias.destination_param + ~n: "dst" ~desc: "name/literal of the destination contract" + @@ stop) + (fun amount (_, source) (_, destination) -> + handle_error @@ fun () -> + Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> + Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> + message "Got the source's manager keys (%s)." src_name ; + transfer (block ()) ~force:!force + ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) + ] diff --git a/src/client/embedded/bootstrap/client_proto_context.mli b/src/client/embedded/bootstrap/client_proto_context.mli new file mode 100644 index 000000000..e000c2d7f --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_context.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val transfer: + Client_proto_rpcs.block -> + ?force:bool -> + source:Contract.t -> + src_pk:public_key -> + src_sk:secret_key -> + destination:Contract.t -> + ?arg:string -> + amount:Tez.t -> + fee:Tez.t -> + unit -> unit tzresult Lwt.t + +val originate_account: + Client_proto_rpcs.block -> + ?force:bool -> + source:Contract.t -> + src_pk:public_key -> + src_sk:secret_key -> + manager_pkh:public_key_hash -> + ?delegatable:bool -> + ?spendable:bool -> + ?delegate:public_key_hash -> + balance:Tez.t -> + fee:Tez.t -> + unit -> Contract.t tzresult Lwt.t + +val originate_contract: + Client_proto_rpcs.block -> + ?force:bool -> + source:Contract.t -> + src_pk:public_key -> + src_sk:secret_key -> + manager_pkh:public_key_hash -> + balance:Tez.t -> + ?delegatable:bool -> + ?delegatePubKey:public_key_hash -> + code:Script.code -> + init:string -> + fee:Tez.t -> + unit -> Contract.t tzresult Lwt.t + +val commands: unit -> Cli_entries.command list diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml new file mode 100644 index 000000000..05aa8b817 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -0,0 +1,182 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module RawContractAlias = Client_aliases.Alias (struct + type t = Contract.t + let encoding = Contract.encoding + let of_source s = + match Contract.of_b48check s with + | Error _ -> Lwt.fail (Failure "bad contract notation") + | Ok s -> Lwt.return s + let to_source s = + Lwt.return (Contract.to_b48check s) + let name = "contract" + end) + +module ContractAlias = struct + let find s = + RawContractAlias.find_opt s >>= function + | Some v -> Lwt.return (s, v) + | None -> + Client_keys.Public_key_hash.find_opt s >>= function + | Some v -> + Lwt.return (s, Contract.default_contract v) + | None -> + Cli_entries.error + "no contract alias nor key alias names %s" s + let find_key name = + Client_keys.Public_key_hash.find name >>= fun v -> + Lwt.return (name, Contract.default_contract v) + + let rev_find c = + match Contract.is_default c with + | Some hash -> begin + Client_keys.Public_key_hash.rev_find hash >>= function + | Some name -> Lwt.return (Some ("key:" ^ name)) + | None -> Lwt.return_none + end + | None -> RawContractAlias.rev_find c + + let get_contract s = + match Utils.split ~limit:1 ':' s with + | [ "key" ; key ]-> + find_key key + | _ -> find s + + let alias_param ?(n = "name") ?(desc = "existing contract alias") next = + Cli_entries.Param + (n, desc ^ "\n" + ^ "can be an contract alias or a key alias (autodetected in this order)\n\ + use 'key:name' to force the later", get_contract, next) + + let destination_param ?(n = "dst") ?(desc = "destination contract") next = + Cli_entries.Param + (n, + desc ^ "\n" + ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ + use 'text:litteral', 'alias:name', 'key:name' to force", + (fun s -> + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "key" ; text ] -> + Client_keys.Public_key_hash.find text >>= fun v -> + Lwt.return (s, Contract.default_contract v) + | _ -> + Lwt.catch + (fun () -> find s) + (fun _ -> + match Contract.of_b48check s with + | Error _ -> Lwt.fail (Failure "bad contract notation") + | Ok v -> Lwt.return (s, v))), + next) + + let name contract = + rev_find contract >|= function + | None -> Contract.to_b48check contract + | Some name -> name + +end + +let get_manager block source = + match Contract.is_default source with + | Some hash -> return hash + | None -> Client_proto_rpcs.Context.Contract.manager block source + +let get_delegate block source = + let open Client_keys in + match Contract.is_default source with + | Some hash -> return hash + | None -> + Client_proto_rpcs.Context.Contract.delegate block source >>=? function + | Some delegate -> return delegate + | None -> Client_proto_rpcs.Context.Contract.manager block source + +let may_check_key sourcePubKey sourcePubKeyHash = + match sourcePubKey with + | Some sourcePubKey -> + if not (Ed25519.equal_hash (Ed25519.hash sourcePubKey) sourcePubKeyHash) + then + failwith "Invalid public key in `client_proto_endorsement`" + else + return () + | None -> return () + +let check_public_key block ?src_pk src_pk_hash = + Client_proto_rpcs.Context.Key.get block src_pk_hash >>= function + | Error errors -> + begin + match src_pk with + | None -> + let exn = Client_proto_rpcs.string_of_errors errors in + failwith "Unknown public key\n%s" exn + | Some key -> + may_check_key src_pk src_pk_hash >>=? fun () -> + return (Some key) + end + | Ok _ -> return None + +let commands () = + let open Cli_entries in + register_group "contracts" + "Commands for managing the record of known contracts" ; + [ + command + ~group: "contracts" + ~desc: "add a contract to the wallet" + (prefixes [ "remember" ; "contract" ] + @@ RawContractAlias.fresh_alias_param + @@ RawContractAlias.source_param + @@ stop) + (fun name hash () -> RawContractAlias.add name hash) ; + command + ~group: "contracts" + ~desc: "remove a contract from the wallet" + (prefixes [ "forget" ; "contract" ] + @@ RawContractAlias.alias_param + @@ stop) + (fun (name, _) () -> RawContractAlias.del name) ; + command + ~group: "contracts" + ~desc: "lists all known contracts" + (fixed [ "list" ; "known" ; "contracts" ]) + (fun () -> + RawContractAlias.load () >>= fun list -> + List.iter (fun (n, v) -> + let v = Contract.to_b48check v in + message "%s: %s" n v) + list ; + Client_keys.Public_key_hash.load () >>= fun list -> + Lwt_list.iter_s (fun (n, v) -> + RawContractAlias.mem n >>= fun mem -> + let p = if mem then "key:" else "" in + let v = Contract.to_b48check (Contract.default_contract v) in + message "%s%s: %s" p n v ; + Lwt.return_unit) + list >>= fun () -> + Lwt.return ()) ; + command + ~group: "contracts" + ~desc: "forget all known contracts" + (fixed [ "forget" ; "all" ; "contracts" ]) + (fun () -> + if not Client_config.force#get then + error "this can only used with option -force true" + else + RawContractAlias.save []) ; + command + ~group: "contracts" + ~desc: "display a contract from the wallet" + (prefixes [ "show" ; "known" ; "contract" ] + @@ RawContractAlias.alias_param + @@ stop) + (fun (_, contract) () -> + Format.printf "%a\n%!" Contract.pp contract ; + Lwt.return ()) ; + ] diff --git a/src/client/embedded/bootstrap/client_proto_contracts.mli b/src/client/embedded/bootstrap/client_proto_contracts.mli new file mode 100644 index 000000000..87e40ba04 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_contracts.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module RawContractAlias : + Client_aliases.Alias with type t = Contract.t + +module ContractAlias : sig + val get_contract: string -> (string * Contract.t) Lwt.t + val alias_param: + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params + val destination_param: + ?n:string -> + ?desc:string -> + 'a Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params + val rev_find: Contract.t -> string option Lwt.t + val name: Contract.t -> string Lwt.t +end + +val get_manager: + Client_proto_rpcs.block -> + Contract.t -> + public_key_hash tzresult Lwt.t + +val get_delegate: + Client_proto_rpcs.block -> + Contract.t -> + public_key_hash tzresult Lwt.t + +val check_public_key : + Client_proto_rpcs.block -> + ?src_pk:public_key -> + public_key_hash -> + public_key option tzresult Lwt.t + +val commands: unit -> Cli_entries.command list diff --git a/src/client/embedded/bootstrap/client_proto_main.ml b/src/client/embedded/bootstrap/client_proto_main.ml new file mode 100644 index 000000000..bc4d0155e --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_main.ml @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let protocol = + Protocol_hash.of_b48check + "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" + +let () = + Client_version.register protocol @@ + Client_proto_programs.commands () @ + Client_proto_contracts.commands () @ + Client_proto_context.commands () diff --git a/src/client/embedded/bootstrap/client_proto_main.mli b/src/client/embedded/bootstrap/client_proto_main.mli new file mode 100644 index 000000000..bf9be960c --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_main.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val protocol: Protocol_hash.t diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml new file mode 100644 index 000000000..5e2f3dcf7 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_nonces.ml @@ -0,0 +1,82 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Cli_entries + +(* TODO locking... *) + +type t = (Block_hash.t * Nonce.t) list + +let encoding : t Data_encoding.t = + let open Data_encoding in + list + (obj2 + (req "block" Block_hash.encoding) + (req "nonce" Nonce.encoding)) + +let filename () = + Client_config.(base_dir#get // "nonces") + +let load () = + let filename = filename () in + if not (Sys.file_exists filename) then + Lwt.return [] + else + Data_encoding.Json.read_file filename >>= function + | None -> error "couldn't to read the nonces file" + | Some json -> + match Data_encoding.Json.destruct encoding json with + | exception _ -> (* TODO print_error *) + error "didn't understand the nonces file" + | list -> + Lwt.return list + +let check_dir dirname = + if not (Sys.file_exists dirname) then + Utils.create_dir dirname + else + Lwt.return () + +let save list = + Lwt.catch + (fun () -> + let dirname = Client_config.base_dir#get in + check_dir dirname >>= fun () -> + let filename = filename () in + let json = Data_encoding.Json.construct encoding list in + Data_encoding.Json.write_file filename json >>= function + | false -> failwith "Json.write_file" + | true -> return ()) + (fun exn -> + error "could not write the nonces file: %s." (Printexc.to_string exn)) + +let mem block_hash = + load () >|= fun data -> + List.mem_assoc block_hash data + +let find block_hash = + load () >|= fun data -> + try Some (List.assoc block_hash data) + with Not_found -> None + +let add block_hash nonce = + load () >>= fun data -> + save ((block_hash, nonce) :: + List.remove_assoc block_hash data) + +let del block_hash = + load () >>= fun data -> + save (List.remove_assoc block_hash data) + +let dels hashes = + load () >>= fun data -> + save @@ + List.fold_left + (fun data hash -> List.remove_assoc hash data) + data hashes diff --git a/src/client/embedded/bootstrap/client_proto_nonces.mli b/src/client/embedded/bootstrap/client_proto_nonces.mli new file mode 100644 index 000000000..d99f7caed --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_nonces.mli @@ -0,0 +1,14 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val mem: Block_hash.t -> bool Lwt.t +val find: Block_hash.t -> Nonce.t option Lwt.t +val add: Block_hash.t -> Nonce.t -> unit tzresult Lwt.t +val del: Block_hash.t -> unit tzresult Lwt.t +val dels: Block_hash.t list -> unit tzresult Lwt.t diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml new file mode 100644 index 000000000..8ac8763bb --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -0,0 +1,179 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Client_proto_args + +let report_parse_error _prefix exn _lexbuf = + let open Lexing in + let open Script_located_ir in + let print_loc ppf ((sl, sc), (el, ec)) = + if sl = el then + if sc = ec then + Format.fprintf ppf + "at line %d character %d" + sl sc + else + Format.fprintf ppf + "at line %d characters %d to %d" + sl sc ec + else + Format.fprintf ppf + "from line %d character %d to line %d character %d" + sl sc el ec in + match exn with + | Missing_program_field n -> + Cli_entries.error "missing script %s" n + | Illegal_character (loc, c) -> + Cli_entries.error "%a, illegal character %C" print_loc loc c + | Illegal_escape (loc, c) -> + Cli_entries.error "%a, illegal escape sequence %S" print_loc loc c + | Failure s -> + Cli_entries.error "%s" s + | exn -> + Cli_entries.error "%s" @@ Printexc.to_string exn + +let parse_program s = + let lexbuf = Lexing.from_string s in + try + Lwt.return + (Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |> + List.map Script_located_ir.strip_locations |> fun fields -> + let rec get_field n = function + | Script.Prim (_, pn, [ ctns ]) :: _ when n = pn -> ctns + | _ :: rest -> get_field n rest + | [] -> raise (Script_located_ir.Missing_program_field n) in + Script.{ code = get_field "code" fields ; + arg_type = get_field "parameter" fields ; + ret_type = get_field "return" fields ; + storage_type = get_field "storage" fields } + ) + with + | exn -> report_parse_error "program: " exn lexbuf + +let rec print_ir ppf node = + let open Script in + let rec do_seq = function + | [] -> assert false + | [ last ] -> Format.fprintf ppf "%a }@]" print_ir last + | fst :: rest -> Format.fprintf ppf "%a ;@ " print_ir fst ; do_seq rest in + let rec do_args = function + | [] -> assert false + | [ last ] -> Format.fprintf ppf "%a@]" print_ir last + | fst :: rest -> Format.fprintf ppf "%a@," print_ir fst ; do_args rest in + match node with + | String (_, s) -> Format.fprintf ppf "%S" s + | Int (_, s) -> Format.fprintf ppf "%s" s + | Float (_, s) -> Format.fprintf ppf "%s" s + | Seq (_, [ one ]) -> print_ir ppf one + | Seq (_, []) -> Format.fprintf ppf "{}" ; + | Seq (_, seq) -> + Format.fprintf ppf "{ @[" ; + do_seq seq + | Prim (_, "push", [ Prim (_, name, []) ]) -> + Format.fprintf ppf "push %s" name + | Prim (_, name, []) -> + Format.fprintf ppf "%s" name + | Prim (_, "push", [ Prim (_, name, seq) ]) -> + Format.fprintf ppf "push @[%s@," name ; + do_args seq + | Prim (_, name, seq) -> + Format.fprintf ppf "@[%s@," name ; + do_args seq + +let print_program ppf c = + Format.fprintf ppf + "@[storage@,%a@]@." + print_ir (c : Script.code).Script.storage_type ; + Format.fprintf ppf + "@[parameter@,%a@]@." + print_ir (c : Script.code).Script.arg_type ; + Format.fprintf ppf + "@[return@,%a@]@." + print_ir (c : Script.code).Script.ret_type ; + Format.fprintf ppf + "@[code@,%a@]" + print_ir (c : Script.code).Script.code + +let parse_data s = + let lexbuf = Lexing.from_string s in + try + match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with + | [node] -> Lwt.return (Script_located_ir.strip_locations node) + | _ -> Cli_entries.error "single data expected" + with + | exn -> report_parse_error "data: " exn lexbuf + +let parse_data_type s = + let lexbuf = Lexing.from_string s in + try + match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with + | [node] -> Lwt.return (Script_located_ir.strip_locations node) + | _ -> Cli_entries.error "single data type expected" + with + | exn -> report_parse_error "data_type: " exn lexbuf + +module Program = Client_aliases.Alias (struct + type t = Script.code + let encoding = Script.code_encoding + let of_source s = parse_program s + let to_source p = Lwt.return (Format.asprintf "%a" print_program p) + let name = "program" + end) + +let commands () = + let open Cli_entries in + register_group "programs" "Commands for managing the record of known programs" ; + [ + command + ~group: "programs" + ~desc: "lists all known programs" + (fixed [ "list" ; "known" ; "programs" ]) + (fun () -> Program.load () >>= fun list -> + List.iter (fun (n, _) -> message "%s" n) list ; Lwt.return ()) ; + command + ~group: "programs" + ~desc: "remember a program under some name" + (prefixes [ "remember" ; "program" ] + @@ Program.fresh_alias_param + @@ Program.source_param + @@ stop) + (fun name hash () -> Program.add name hash) ; + command + ~group: "programs" + ~desc: "forget a remembered program" + (prefixes [ "forget" ; "program" ] + @@ Program.alias_param + @@ stop) + (fun (name, _) () -> Program.del name) ; + command + ~group: "programs" + ~desc: "display a program" + (prefixes [ "show" ; "known" ; "program" ] + @@ Program.alias_param + @@ stop) + (fun (_, program) () -> + Program.to_source program >>= fun source -> + Format.printf "%s\n" source ; + Lwt.return ()) ; + command + ~group: "programs" + ~desc: "ask the node to typecheck a program" + (prefixes [ "typecheck" ; "program" ] + @@ Program.source_param + @@ stop) + (fun program () -> + let open Data_encoding in + Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function + | Ok _contracts -> + message "Well typed" ; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "ill-typed program") ; + ] diff --git a/src/client/embedded/bootstrap/client_proto_programs.mli b/src/client/embedded/bootstrap/client_proto_programs.mli new file mode 100644 index 000000000..dbec38b52 --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_programs.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val parse_program: string -> Script.code Lwt.t +val parse_data: string -> Script.expr Lwt.t +val parse_data_type: string -> Script.expr Lwt.t + +val print_program: Format.formatter -> Script.code -> unit + +module Program : Client_aliases.Alias with type t = Script.code + +val commands: unit -> Cli_entries.command list diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.ml b/src/client/embedded/bootstrap/client_proto_rpcs.ml new file mode 100644 index 000000000..024698d5a --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_rpcs.ml @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let string_of_errors exns = + Format.asprintf " @[%a@]" pp_print_error exns + +let handle_error = function + | Ok res -> Lwt.return res + | Error exns -> + pp_print_error Format.err_formatter exns ; + Cli_entries.error "cannot continue" + +type net = State.net_id = Net of Block_hash.t +type block = [ + | `Genesis + | `Head of int | `Prevalidation + | `Test_head of int | `Test_prevalidation + | `Hash of Block_hash.t +] + +let call_service1 s block a1 = + Client_node_rpcs.call_service1 + (s Node_rpc_services.Blocks.proto_path) block a1 +let call_error_service1 s block a1 = + call_service1 s block a1 >|= wrap_error +let call_service2 s block a1 a2 = + Client_node_rpcs.call_service2 + (s Node_rpc_services.Blocks.proto_path) block a1 a2 +let call_error_service2 s block a1 a2 = + call_service2 s block a1 a2 >|= wrap_error + +module Constants = struct + let bootstrap block = call_service1 Services.Constants.bootstrap block () + let errors block = call_service1 Services.Constants.errors block () + let cycle_length block = + call_error_service1 Services.Constants.cycle_length block () + let voting_period_length block = + call_error_service1 Services.Constants.voting_period_length block () + let time_before_reward block = + call_error_service1 Services.Constants.time_before_reward block () + let time_between_slots block = + call_error_service1 Services.Constants.time_between_slots block () + let first_free_mining_slot block = + call_error_service1 Services.Constants.first_free_mining_slot block () + let max_signing_slot block = + call_error_service1 Services.Constants.max_signing_slot block () + let instructions_per_transaction block = + call_error_service1 Services.Constants.instructions_per_transaction block () + let stamp_threshold block = + call_error_service1 Services.Constants.proof_of_work_threshold block () +end + +module Context = struct + + let level block = call_error_service1 Services.Context.level block () + let next_level block = call_error_service1 Services.Context.next_level block () + + module Nonce = struct + + type nonce_info = Services.Context.Nonce.nonce_info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + let get block level = + call_error_service2 Services.Context.Nonce.get block level () + + let hash block = + call_error_service1 Services.Context.Nonce.hash block () + + end + + module Key = struct + + let get block pk_h = + call_error_service2 Services.Context.Key.get block pk_h () + + let list block = + call_error_service1 Services.Context.Key.list block () + + end + + module Contract = struct + let list b = + call_error_service1 Services.Context.Contract.list b () + type info = Services.Context.Contract.info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + script: Script.t ; + assets: Asset.Map.t ; + counter: int32 ; + } + let get b c = + call_error_service2 Services.Context.Contract.get b c () + let balance b c = + call_error_service2 Services.Context.Contract.balance b c () + let manager b c = + call_error_service2 Services.Context.Contract.manager b c () + let delegate b c = + call_error_service2 Services.Context.Contract.delegate b c () + let counter b c = + call_error_service2 Services.Context.Contract.counter b c () + let spendable b c = + call_error_service2 Services.Context.Contract.spendable b c () + let delegatable b c = + call_error_service2 Services.Context.Contract.delegatable b c () + let script b c = + call_error_service2 Services.Context.Contract.script b c () + let assets b c = + call_error_service2 Services.Context.Contract.assets b c () + end + +end + +module Helpers = struct + + let minimal_time block ?prio () = + call_error_service1 Services.Helpers.minimal_timestamp block prio + + let typecheck_code = call_error_service1 Services.Helpers.typecheck_code + + let level block ?offset lvl = + call_error_service2 Services.Helpers.level block lvl offset + + let levels block cycle = + call_error_service2 Services.Helpers.levels block cycle () + + module Rights = struct + type slot = Raw_level.t * int * Time.t option + let mining_rights_for_delegate + b c ?max_priority ?first_level ?last_level () = + call_error_service2 Services.Helpers.Rights.mining_rights_for_delegate + b c (max_priority, first_level, last_level) + let endorsement_rights_for_delegate + b c ?max_priority ?first_level ?last_level () = + call_error_service2 Services.Helpers.Rights.endorsement_rights_for_delegate + b c (max_priority, first_level, last_level) + end + + module Forge = struct + + let script_of_option = function + | None -> Script.No_script + | Some (code, storage) -> Script { code ; storage } + + open Operation + + module Manager = struct + let operations + block ~net ~source ?sourcePubKey ~counter ~fee operations = + let ops = + Manager_operations { source ; public_key = sourcePubKey ; + counter ; operations ; fee } in + (call_error_service1 Services.Helpers.Forge.operations block + ({net_id=net}, Sourced_operations ops)) + >>=? fun (bytes, contracts) -> + return (bytes, match contracts with None -> [] | Some l -> l) + let transaction + block ~net ~source ?sourcePubKey ~counter + ~amount ~destination ?parameters ~fee ()= + operations block ~net ~source ?sourcePubKey ~counter ~fee + Tezos_context.[Transaction { amount ; parameters ; destination }] + >>=? fun (bytes, contracts) -> + assert (contracts = []) ; + return bytes + let origination + block ~net + ~source ?sourcePubKey ~counter + ~managerPubKey ~balance + ?(spendable = true) + ?(delegatable = true) + ?delegatePubKey ?script ~fee () = + let script = script_of_option script in + operations block ~net ~source ?sourcePubKey ~counter ~fee + Tezos_context.[ + Origination { manager = managerPubKey ; + delegate = delegatePubKey ; + script ; + spendable ; + delegatable ; + credit = balance } + ] + >>=? fun (bytes, contracts) -> + match contracts with + | [contract] -> return (contract, bytes) + | _ -> assert false + let issuance + block ~net ~source ?sourcePubKey ~counter ~assetType ~quantity ~fee ()= + operations block ~net ~source ?sourcePubKey ~counter ~fee + Tezos_context.[Issuance { asset = assetType ; amount = quantity }] + >>=? fun (bytes, contracts) -> + assert (contracts = []) ; + return bytes + let delegation + block ~net ~source ?sourcePubKey ~counter ~fee delegate = + operations block ~net ~source ?sourcePubKey ~counter ~fee + Tezos_context.[Delegation delegate] + >>=? fun (bytes, contracts) -> + assert (contracts = []) ; + return bytes + end + module Delegate = struct + let operations + block ~net ~source operations = + let ops = Delegate_operations { source ; operations } in + (call_error_service1 Services.Helpers.Forge.operations block + ({net_id=net}, Sourced_operations ops)) + >>=? fun (hash, _contracts) -> + return hash + let endorsement b ~net ~source ~block ~slot () = + operations b ~net ~source + Tezos_context.[Endorsement { block ; slot }] + end + module Anonymous = struct + let operations block ~net operations = + (call_error_service1 Services.Helpers.Forge.operations block + ({net_id=net}, Anonymous_operations operations)) + >>=? fun (hash, _contracts) -> + return hash + let seed_nonce_revelation + block ~net ~level ~nonce () = + operations block ~net [Seed_nonce_revelation { level ; nonce }] + end + let block_header + block ~net ~predecessor ~timestamp ~fitness ~operations + ~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () = + call_error_service1 Services.Helpers.Forge.block_header block + (net, predecessor, timestamp, fitness, operations, + level, priority, seed_nonce_hash, proof_of_work_nonce) + end + + module Parse = struct + let operations block ?check shell bytes = + call_error_service1 Services.Helpers.Parse.operations block (shell, bytes, check) + end + +end +(* type slot = *) + (* raw_level * int * timestamp option *) + (* let mining_possibilities *) + (* b c ?max_priority ?first_level ?last_level () = *) + (* call_error_service2 Services.Helpers.Context.Contract.mining_possibilities *) + (* b c (max_priority, first_level, last_level) *) + (* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *) + (* call_error_service2 Services.Helpers.Context.Contract.endorsement_possibilities *) + (* b c (max_priority, first_level, last_level) *) diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli new file mode 100644 index 000000000..758b87dac --- /dev/null +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -0,0 +1,217 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val string_of_errors: error list -> string +val handle_error: 'a tzresult -> 'a Lwt.t + +type net = State.net_id = Net of Block_hash.t + +type block = [ + | `Genesis + | `Head of int | `Prevalidation + | `Test_head of int | `Test_prevalidation + | `Hash of Block_hash.t +] + +module Constants : sig + val errors: block -> Json_schema.schema Lwt.t + val bootstrap: block -> Bootstrap.account list Lwt.t + val cycle_length: block -> int32 tzresult Lwt.t + val voting_period_length: block -> int32 tzresult Lwt.t + val time_before_reward: block -> Period.t tzresult Lwt.t + val time_between_slots: block -> Period.t tzresult Lwt.t + val first_free_mining_slot: block -> int32 tzresult Lwt.t + val max_signing_slot: block -> int tzresult Lwt.t + val instructions_per_transaction: block -> int tzresult Lwt.t + val stamp_threshold: block -> int tzresult Lwt.t +end + +module Context : sig + val level: block -> Level.t tzresult Lwt.t + val next_level: block -> Level.t tzresult Lwt.t + module Nonce : sig + val hash: block -> Nonce_hash.t tzresult Lwt.t + type nonce_info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + val get: block -> Raw_level.t -> nonce_info tzresult Lwt.t + end + module Key : sig + val get : + block -> + public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t + val list : + block -> + ((public_key_hash * public_key) list) tzresult Lwt.t + end + module Contract : sig + val list: block -> Contract.t list tzresult Lwt.t + type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + script: Script.t ; + assets: Asset.Map.t ; + counter: int32 ; + } + val get: block -> Contract.t -> info tzresult Lwt.t + val balance: + block -> Contract.t -> + Tez.t tzresult Lwt.t + val manager: + block -> Contract.t -> + public_key_hash tzresult Lwt.t + val delegate: + block -> Contract.t -> + public_key_hash option tzresult Lwt.t + val counter: + block -> Contract.t -> + int32 tzresult Lwt.t + val spendable: + block -> Contract.t -> + bool tzresult Lwt.t + val delegatable: + block -> Contract.t -> + bool tzresult Lwt.t + val script: + block -> Contract.t -> Script.t tzresult Lwt.t + val assets: + block -> Contract.t -> + Asset.Map.t tzresult Lwt.t + end +end + +module Helpers : sig + val minimal_time: + block -> ?prio:int -> unit -> Time.t tzresult Lwt.t + val typecheck_code: block -> Script.code -> unit tzresult Lwt.t + val level: block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t + val levels: block -> Cycle.t -> Level.t list tzresult Lwt.t + + module Rights : sig + type slot = Raw_level.t * int * Time.t option + val mining_rights_for_delegate: + block -> public_key_hash -> + ?max_priority:int -> ?first_level:Raw_level.t -> + ?last_level:Raw_level.t -> unit -> + (slot list) tzresult Lwt.t + val endorsement_rights_for_delegate: + block -> public_key_hash -> + ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> + (slot list) tzresult Lwt.t + end + + module Forge : sig + module Manager : sig + val operations: + block -> + net:net -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + fee:Tez.t -> + manager_operation list -> + (MBytes.t * Contract.t list) tzresult Lwt.t + val transaction: + block -> + net:net -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + amount:Tez.t -> + destination:Contract.t -> + ?parameters:Script.expr -> + fee:Tez.t -> + unit -> MBytes.t tzresult Lwt.t + val origination: + block -> + net:net -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + managerPubKey:public_key_hash -> + balance:Tez.t -> + ?spendable:bool -> + ?delegatable:bool -> + ?delegatePubKey: public_key_hash -> + ?script:(Script.code * Script.storage) -> + fee:Tez.t-> + unit -> + (Contract.t * MBytes.t) tzresult Lwt.t + val issuance: + block -> + net:net -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + assetType:(Asset.t * public_key_hash) -> + quantity:Tez.t -> + fee:Tez.t -> + unit -> MBytes.t tzresult Lwt.t + val delegation: + block -> + net:net -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + fee:Tez.t -> + public_key_hash option -> + MBytes.t tzresult Lwt.t + end + module Delegate : sig + val operations: + block -> + net:net -> + source:public_key -> + delegate_operation list -> + MBytes.t tzresult Lwt.t + val endorsement: + block -> + net:net -> + source:public_key -> + block:Block_hash.t -> + slot:int -> + unit -> MBytes.t tzresult Lwt.t + end + module Anonymous : sig + val operations: + block -> + net:net -> + anonymous_operation list -> + MBytes.t tzresult Lwt.t + val seed_nonce_revelation: + block -> + net:net -> + level:Raw_level.t -> + nonce:Nonce.t -> + unit -> MBytes.t tzresult Lwt.t + end + val block_header: + block -> + net:net -> + predecessor:Block_hash.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + operations:Operation_hash.t list -> + level:Raw_level.t -> + priority:int -> + seed_nonce_hash:Nonce_hash.t -> + proof_of_work_nonce:MBytes.t -> + unit -> MBytes.t tzresult Lwt.t + end + + module Parse : sig + val operations: + block -> ?check:bool -> Updater.shell_operation -> MBytes.t -> + proto_operation tzresult Lwt.t + end + +end diff --git a/src/client/embedded/bootstrap/concrete_lexer.mll b/src/client/embedded/bootstrap/concrete_lexer.mll new file mode 100644 index 000000000..88a227dbd --- /dev/null +++ b/src/client/embedded/bootstrap/concrete_lexer.mll @@ -0,0 +1,392 @@ + +{ + +open Concrete_parser + +open Script_located_ir + +let count_nl s = + let c = ref 0 in + for i = 0 to String.length s - 1 do + if Compare.Char.(s.[i] = '\010') then + incr c + done; + !c + +let update_loc lexbuf nl indent = + let open Lexing in + let lcp = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { lcp with + pos_lnum = lcp.pos_lnum + nl; + pos_bol = lcp.pos_cnum - indent; + } + +let may_update_loc lexbuf nl indent = + if Compare.Int.(nl <> 0) then update_loc lexbuf nl indent + +let start_offset lexbuf = + let open Lexing in + let lsp = lexbuf.lex_start_p in + lsp.pos_cnum - lsp.pos_bol + +let end_offset lexbuf = + let open Lexing in + let lcp = lexbuf.lex_curr_p in + lcp.pos_cnum - lcp.pos_bol + +let curr_location lexbuf = + lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p + +let pos pos = + Lexing.(pos.pos_lnum, pos.pos_cnum - pos.pos_bol) + +let pos2 (start, stop) = + pos start, pos stop + +(* To translate escape sequences *) + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = 100 * (int_of_char(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (int_of_char(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in + if Compare.Int.(c < 0 || c > 255) then + raise @@ Illegal_escape (pos2 (curr_location lexbuf), Lexing.lexeme lexbuf) + else char_of_int c + +let char_for_hexadecimal_code lexbuf i = + let d1 = int_of_char (Lexing.lexeme_char lexbuf i) in + let val1 = if Compare.Int.(d1 >= 97) then d1 - 87 + else if Compare.Int.(d1 >= 65) then d1 - 55 + else d1 - 48 + in + let d2 = int_of_char (Lexing.lexeme_char lexbuf (i+1)) in + let val2 = if Compare.Int.(d2 >= 97) then d2 - 87 + else if Compare.Int.(d2 >= 65) then d2 - 55 + else d2 - 48 + in + char_of_int (val1 * 16 + val2) + + +(* Remove underscores from float literals *) + +let remove_underscores s = + let s = Bytes.of_string s in + let l = Bytes.length s in + let rec remove src dst = + if Compare.Int.(src >= l) then + if Compare.Int.(dst >= l) then s else Bytes.sub s 0 dst + else + match Bytes.get s src with + '_' -> remove (src + 1) dst + | c -> Bytes.set s dst c; remove (src + 1) (dst + 1) + in Bytes.to_string (remove 0 0) + + +(** Lexer state *) + +type state = { + mutable indent_stack: + (int * [`Indent | `Open of (char * (Lexing.position * Lexing.position)) ]) list; + mutable buffer: Concrete_parser.token list; + mutable string_buff: bytes; + mutable string_index: int; + mutable string_start_loc: Lexing.position * Lexing.position; + mutable comment_start_loc: (Lexing.position * Lexing.position) list; +} + +let init_state () = { + indent_stack = []; + buffer = []; + string_index = 0; + string_buff = Bytes.create 256; + string_start_loc = Lexing.dummy_pos, Lexing.dummy_pos; + comment_start_loc = []; +} + + +(** String helpers *) + +let reset_string_buffer st = + st.string_buff <- Bytes.create 256; + st.string_index <- 0 + +let store_string_char st c = + if st.string_index >= Bytes.length st.string_buff then begin + let new_buff = Bytes.create (Bytes.length (st.string_buff) * 2) in + Bytes.blit st.string_buff 0 new_buff 0 (Bytes.length st.string_buff); + st.string_buff <- new_buff + end; + Bytes.set st.string_buff st.string_index c; + st.string_index <- st.string_index + 1 + +let store_string st s = + for i = 0 to String.length s - 1 do + store_string_char st s.[i]; + done + +let store_lexeme st lexbuf = + store_string st (Lexing.lexeme lexbuf) + +let get_stored_string st = + let s = Bytes.sub st.string_buff 0 st.string_index in + st.string_buff <- Bytes.create 256; + Bytes.to_string s + + +(** Indentation helpers *) + +let first_token st = + match st.indent_stack with + | [] -> true + | _ :: _ -> false + +let starting_offset (start, _) = + let open Lexing in + start.pos_cnum - start.pos_bol + +let rec pop_indent st loc xs i = + match xs with + | [] -> assert false + | ((x, _) :: _) as xs when Compare.Int.(x = i) -> + st.indent_stack <- xs; + [NEWLINE] + | (x, `Indent) :: xs -> + if Compare.Int.(x > i) then + DEDENT :: pop_indent st loc xs i + else + raise @@ Invalid_indentation (pos2 loc) + | (_, `Open (c, opener_loc)) :: _ -> + let opener_offset = starting_offset opener_loc in + if Compare.Int.(i > opener_offset) then + raise @@ Invalid_indentation_in_block (pos2 loc, c, pos2 opener_loc) + else + raise @@ Unclosed (pos2 loc, c, pos2 opener_loc) + +let indent_token st loc = + let i = starting_offset loc in + match st.indent_stack with + | (x, `Indent) :: xs when Compare.Int.(x > i) -> + DEDENT :: pop_indent st loc xs i; + | (x, `Open (c, opener_loc)) :: _ when Compare.Int.(x > i) -> + let opener_offset = starting_offset opener_loc in + if Compare.Int.(i > opener_offset) then + raise @@ Invalid_indentation_in_block (pos2 loc, c, pos2 opener_loc) + else + raise @@ Unclosed (pos2 loc, c, pos2 opener_loc) + | (x, _) :: _ when Compare.Int.(x = i) -> + [NEWLINE] + | [] | (_, _) :: _ (* when Compare.Int.(x < i) *) -> + st.indent_stack <- (i, `Indent) :: st.indent_stack; + [INDENT] + +let open_block st opener opener_loc token_offset = + let opener_offset = starting_offset opener_loc in + if Compare.Int.(token_offset <= opener_offset) then + raise @@ Invalid_indentation_after_opener (pos2 opener_loc, opener) ; + st.indent_stack <- + (token_offset, `Open (opener, opener_loc)) :: st.indent_stack; + match opener with + | '{' -> [LBRACE] + | '(' -> [LPAREN] + | _ -> assert false + +let close_block st bol closer closer_loc = + let closer_offset = starting_offset closer_loc in + let rec pop xs = + match xs with + | [] -> raise @@ Unopened (pos2 closer_loc, closer) + | (_, `Indent) :: xs -> DEDENT :: pop xs + | (_, `Open (opener, opener_loc)) :: xs -> + let opener_offset = starting_offset opener_loc in + if bol && Compare.Int.(opener_offset <> closer_offset) then + raise @@ + Unaligned_closer (pos2 closer_loc, opener, closer, pos2 opener_loc) ; + st.indent_stack <- xs; + [ match opener, closer with + | '{', '}' -> RBRACE + | '(', ')' -> RPAREN + | _ -> + raise @@ Unclosed (pos2 closer_loc, opener, pos2 opener_loc) ] + in + pop st.indent_stack + +} + +let eol_comment = '#' [^ '\010'] * +let newline = eol_comment ? ('\010' | "\013\010" ) +let space = [' '] +let firstidentchar = ['A'-'Z' 'a'-'z' '_'] +let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] +let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* +let hex_literal = + '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* +let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* +let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* +let int_literal = + '-' ? ( decimal_literal | hex_literal | oct_literal | bin_literal) +let float_literal = + '-' ? + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? +let cadr = + ['c' 'C'] ['a' 'A' 'd' 'D']+ ['r' 'R'] + +rule indent_tokens st nl = parse + +| space { indent_tokens st nl lexbuf } +| newline { Lexing.new_line lexbuf; indent_tokens st (nl + 1) lexbuf } + +| "" + { let bol = nl <> 0 || first_token st in + if bol then indent_token st (curr_location lexbuf) else [] } + +| "/*" + { st.comment_start_loc <- [curr_location lexbuf]; + comment st nl lexbuf } + +| ('{' | '(' as opener) + { let opener_loc = curr_location lexbuf in + let token_offset = next_token_indent st lexbuf in + let bol = nl <> 0 || first_token st in + let prefix = + if bol then indent_token st opener_loc else [] in + prefix @ open_block st opener opener_loc token_offset } + +| ('}' | ')' as closer) + { let closer_loc = curr_location lexbuf in + let bol = Compare.Int.(nl <> 0) in + close_block st bol closer closer_loc } + +| eof + { List.map + (function + | (_, `Indent) -> DEDENT + | (_, `Open (c, loc)) -> + raise @@ Unclosed (pos2 (curr_location lexbuf), c, pos2 loc)) + st.indent_stack + @ [EOF] + } + +and comment st nl = parse + +| "/*" { st.comment_start_loc <- + curr_location lexbuf :: st.comment_start_loc; + comment st nl lexbuf } + +| "*/" { match st.comment_start_loc with + | [] -> assert false + | [_] -> indent_tokens st nl lexbuf + | _ :: xs -> st.comment_start_loc <- xs; comment st nl lexbuf } + +| "\"" { st.string_start_loc <- curr_location lexbuf; + let nl = + try string st nl lexbuf + with Unterminated_string str_start -> + match st.comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev st.comment_start_loc) in + raise @@ + Unterminated_string_in_comment (pos2 loc, pos2 start, str_start) + in + comment st nl lexbuf } + +| newline { Lexing.new_line lexbuf; comment st (nl+1) lexbuf } + +| eof { match st.comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev st.comment_start_loc) in + raise @@ Unterminated_comment (pos2 loc, pos2 start) } + +| _ { comment st nl lexbuf } + + +(** Eat spacings and return the next token offset. *) +and next_token_indent st = parse + +| space { next_token_indent st lexbuf } + +| newline { Lexing.new_line lexbuf; next_token_indent st lexbuf } + +| "" { end_offset lexbuf } + +(** The lexer for non-indentation tokens. + It should not care about 'space', 'newline', '{}()' nor comments. *) +and raw_token st = parse + +| ";" { SEMICOLON } + +| firstidentchar identchar * + { PRIM (String.lowercase_ascii (Lexing.lexeme lexbuf)) } + +| int_literal + { INT (Lexing.lexeme lexbuf) } + +| float_literal + { FLOAT (remove_underscores (Lexing.lexeme lexbuf)) } + +| "\"" + { reset_string_buffer st; + let string_start = lexbuf.Lexing.lex_start_p in + st.string_start_loc <- curr_location lexbuf; + ignore (string st 0 lexbuf); + lexbuf.Lexing.lex_start_p <- string_start; + STRING (get_stored_string st) } + +| _ + { raise (Illegal_character (pos2 (curr_location lexbuf), + Lexing.lexeme_char lexbuf 0)) + } + +and string st nl = parse + '"' + { nl } + | '\\' newline ([' ' '\t'] * as space) + { update_loc lexbuf 1 (String.length space); + string st nl lexbuf + } + | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] + { store_string_char st (char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string st nl lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char st (char_for_decimal_code lexbuf 1); + string st nl lexbuf } + | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] + { store_string_char st (char_for_hexadecimal_code lexbuf 2); + string st nl lexbuf } + | newline + { match st.comment_start_loc with + | [] -> raise @@ Newline_in_string (pos2 (curr_location lexbuf)) + | _ -> Lexing.new_line lexbuf; string st (nl+1) lexbuf } + | eof + { raise @@ Unterminated_string (pos2 st.string_start_loc) } + | _ + { store_string_char st (Lexing.lexeme_char lexbuf 0); + string st nl lexbuf } + + +{ + + let rec token st lexbuf = + match st.buffer with + | tok :: tokens -> + st.buffer <- tokens; + tok + | [] -> + match indent_tokens st 0 lexbuf with + | [] -> raw_token st lexbuf + | _ :: _ as tokens -> st.buffer <- tokens; token st lexbuf + +} diff --git a/src/client/embedded/bootstrap/concrete_parser.mly b/src/client/embedded/bootstrap/concrete_parser.mly new file mode 100644 index 000000000..3af044279 --- /dev/null +++ b/src/client/embedded/bootstrap/concrete_parser.mly @@ -0,0 +1,71 @@ + +%token DEDENT +%token EOF +%token INDENT +%token LBRACE +%token LPAREN +%token NEWLINE +%token RBRACE +%token RPAREN +%token SEMICOLON + +%token FLOAT +%token INT +%token PRIM +%token STRING + +%left PRIM INT FLOAT LPAREN LBRACE STRING +%left apply + +%start tree + +%{ + +open Script_located_ir + +let apply node arg = + match node with + | Prim (loc, n, args) -> Prim (loc, n, args @ [arg]) + | Int _ | Float _ | String _ | Seq _ as _node -> + raise (Invalid_application (node_location arg)) + +let rec apply_seq node = function + | [] -> node + | n1 :: n2 -> apply_seq (apply node n1) n2 + +let pos p1 p2 = + Lexing.((p1.pos_lnum, p1.pos_cnum - p1.pos_bol), + (p2.pos_lnum, p2.pos_cnum - p2.pos_bol)) + +%} + +%% + +%public tree: +| node = nodes EOF { node } +| INDENT node = nodes DEDENT EOF { node } + +nodes: +| { [] } +| n1 = node { [n1] } +| n1 = node SEMICOLON n2 = nodes { n1 :: n2 } +| n1 = node SEMICOLON NEWLINE n2 = nodes { n1 :: n2 } +| n1 = node NEWLINE n2 = nodes { n1 :: n2 } + +node: +| node = line_node { node } +| line_node error + (* Un seul elt par bloc de '(' ... ')' (pas de NEWLINE ou de ';' *) + { raise (Sequence_in_parens (pos $startpos $endpos)) } +| node = line_node INDENT nodes = nodes DEDENT { apply_seq node nodes } + +line_node: +| n1 = line_node n2 = line_node %prec apply { apply n1 n2 } +| LPAREN node = node RPAREN { node } +| LBRACE nodes = nodes RBRACE { Seq (pos $startpos $endpos, nodes) } +| prim = PRIM { Prim (pos $startpos $endpos, prim, []) } +| i = INT { Int (pos $startpos $endpos, i) } +| f = FLOAT { Float (pos $startpos $endpos, f) } +| s = STRING { String (pos $startpos $endpos, s) } + +%% diff --git a/src/client/embedded/bootstrap/local_error_monad.ml b/src/client/embedded/bootstrap/local_error_monad.ml new file mode 100644 index 000000000..5e2773457 --- /dev/null +++ b/src/client/embedded/bootstrap/local_error_monad.ml @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Shell_error_monad = Error_monad + +module Error_monad = struct + type error_category = [ `Branch | `Temporary | `Permanent ] + include Shell_error_monad.Make() +end + +type error += Ecoproto_error of Error_monad.error list + +let wrap = function + | Ok x -> Ok x + | Error errors -> Error [Ecoproto_error errors] diff --git a/src/client/embedded/bootstrap/mining/Makefile b/src/client/embedded/bootstrap/mining/Makefile new file mode 100644 index 000000000..33d3a09b0 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/Makefile @@ -0,0 +1,23 @@ + +SOURCE_DIRECTORIES += mining + +INTFS += \ + mining/client_mining_blocks.mli \ + mining/client_mining_operations.mli \ + mining/client_mining_endorsement.mli \ + mining/client_mining_denunciation.mli \ + mining/client_mining_revelation.mli \ + mining/client_mining_forge.mli \ + mining/client_mining_daemon.mli \ + mining/client_mining_main.mli \ + +IMPLS += \ + mining/client_mining_blocks.ml \ + mining/client_mining_operations.ml \ + mining/client_mining_endorsement.ml \ + mining/client_mining_denunciation.ml \ + mining/client_mining_revelation.ml \ + mining/client_mining_forge.ml \ + mining/client_mining_daemon.ml \ + mining/client_mining_main.ml \ + diff --git a/src/client/embedded/bootstrap/mining/client_mining_blocks.ml b/src/client/embedded/bootstrap/mining/client_mining_blocks.ml new file mode 100644 index 000000000..a7f0e41dc --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_blocks.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + level: Level.t ; +} + +let convert_block_info + ( { hash ; predecessor ; fitness ; timestamp ; protocol } + : Client_node_rpcs.Blocks.block_info ) = + Client_proto_rpcs.Context.level (`Hash hash) >>= function + | Ok level -> + Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level }) + | Error _ -> + (* TODO log error *) + Lwt.return_none + +let convert_block_info_err + ( { hash ; predecessor ; fitness ; timestamp ; protocol } + : Client_node_rpcs.Blocks.block_info ) = + Client_proto_rpcs.Context.level (`Hash hash) >>=? fun level -> + return { hash ; predecessor ; fitness ; timestamp ; protocol ; level } + +let info ?operations block = + Client_node_rpcs.Blocks.info ?operations block >>= fun block -> + convert_block_info_err block + +let compare (bi1 : block_info) (bi2 : block_info) = + match Fitness.compare bi1.fitness bi2.fitness with + | 0 -> begin + match compare bi1.level bi2.level with + | 0 -> begin + match Time.compare bi1.timestamp bi2.timestamp with + | 0 -> Block_hash.compare bi1.predecessor bi2.predecessor + | x -> - x + end + | x -> - x + end + | x -> x + +let sort_blocks ?(compare = compare) blocks = + Lwt_list.map_p convert_block_info blocks >|= fun blocks -> + let blocks = Utils.unopt_list blocks in + List.sort compare blocks + +let monitor ?operations ?length ?heads ?delay ?compare () = + Client_node_rpcs.Blocks.monitor ?operations ?length ?heads ?delay + () >>= fun block_stream -> + let convert blocks = sort_blocks ?compare (List.flatten blocks) in + Lwt.return (Lwt_stream.map_s convert block_stream) + +let blocks_from_cycle block cycle = + let block = + match block with + | `Prevalidation -> `Head 0 + | `Test_prevalidation -> `Test_head 0 + | _ -> block in + Client_node_rpcs.Blocks.hash block >>= fun block_hash -> + Client_proto_rpcs.Context.level block >>=? fun level -> + Client_proto_rpcs.Helpers.levels block cycle >>=? fun block_levels -> + begin + match List.sort Level.compare block_levels with + | [] -> failwith "Internal error" + | hd :: _ -> return hd + end >>=? fun min_level -> + let length = 1 + Int32.to_int (Level.diff level min_level) in + begin + Client_node_rpcs.Blocks.list ~length ~heads:[block_hash] () >>= function + | [] | _::_::_ -> failwith "Unexpected RPC result" + | [blocks] -> return blocks + end >>=? fun block_infos -> + let block_infos = + Utils.remove_elem_from_list (length - List.length block_levels) block_infos in + map_s convert_block_info_err block_infos >>=? fun block_res -> + return block_res diff --git a/src/client/embedded/bootstrap/mining/client_mining_blocks.mli b/src/client/embedded/bootstrap/mining/client_mining_blocks.mli new file mode 100644 index 000000000..d5618726e --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_blocks.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + level: Level.t ; +} + +val info: + ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t + +val compare: block_info -> block_info -> int + +val monitor: + ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> + ?compare:(block_info -> block_info -> int) -> + unit -> block_info list Lwt_stream.t Lwt.t + +val blocks_from_cycle: + Client_node_rpcs.Blocks.block -> + Cycle.t -> + block_info list tzresult Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_daemon.ml b/src/client/embedded/bootstrap/mining/client_mining_daemon.ml new file mode 100644 index 000000000..20c369a99 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_daemon.ml @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Client.Mining + +let run ?max_priority ~delay delegates = + (* TODO really detach... *) + let endorsement = + if Client_proto_args.Daemon.(!all || !endorsement) then + Client_mining_blocks.monitor () >>= fun block_stream -> + Client_mining_endorsement.create ~delay delegates block_stream + else + Lwt.return_unit + in + let denunciation = + if Client_proto_args.Daemon.(!all || !denunciation) then + Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream -> + Client_mining_denunciation.create endorsement_stream + else + Lwt.return_unit + in + let forge = + Client_mining_blocks.monitor () >>= fun block_stream -> + Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream -> + if Client_proto_args.Daemon.(!all || !mining) then + Client_mining_forge.create + ?max_priority delegates block_stream endorsement_stream + else + Lwt.return_unit + in + denunciation >>= fun () -> + endorsement >>= fun () -> + forge diff --git a/src/client/embedded/bootstrap/mining/client_mining_daemon.mli b/src/client/embedded/bootstrap/mining/client_mining_daemon.mli new file mode 100644 index 000000000..a6f907b1a --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_daemon.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val run: + ?max_priority: int -> + delay: int -> + public_key_hash list -> unit Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml b/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml new file mode 100644 index 000000000..c2fbb8f38 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Client.Denunciation + +let create endorsement_stream = + let last_get_endorsement = ref None in + let get_endorsement () = + match !last_get_endorsement with + | None -> + let t = Lwt_stream.get endorsement_stream in + last_get_endorsement := Some t ; + t + | Some t -> t in + let rec worker_loop () = + (* let timeout = compute_timeout state in *) + Lwt.choose [ + (* (timeout >|= fun () -> `Timeout) ; *) + (get_endorsement () >|= fun e -> `Endorsement e) ; + ] >>= function + | `Endorsement None -> + Lwt.return_unit + | `Endorsement (Some e) -> + last_get_endorsement := None ; + Client_keys.Public_key_hash.name + e.Client_mining_operations.source >>= fun source -> + lwt_debug + "Discovered endorsement for block %a by %s (slot @[%a@])" + Block_hash.pp_short e.block + source + Format.(pp_print_list pp_print_int) e.slots >>= fun () -> + worker_loop () in + lwt_log_info "Starting denunciation daemon" >>= fun () -> + worker_loop () diff --git a/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli b/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli new file mode 100644 index 000000000..bd7ee8932 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli @@ -0,0 +1,12 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val create: + Client_mining_operations.valid_endorsement Lwt_stream.t -> + unit Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml new file mode 100644 index 000000000..b6478a31d --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -0,0 +1,345 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Client.Endorsement +open Cli_entries + +module State : sig + + val get_endorsement: + Raw_level.t -> + int -> + (Block_hash.t * Operation_hash.t) option tzresult Lwt.t + + val record_endorsement: + Raw_level.t -> + Block_hash.t -> + int -> Operation_hash.t -> unit tzresult Lwt.t + +end = struct + + module LevelMap = Map.Make(Raw_level) + + type t = (int * Block_hash.t * Operation_hash.t) list LevelMap.t + let encoding : t Data_encoding.t = + let open Data_encoding in + conv + (fun x -> LevelMap.bindings x) + (fun l -> List.fold_left (fun x (y, z) -> LevelMap.add y z x) LevelMap.empty l) + (list (obj2 + (req "level" Raw_level.encoding) + (req "endorsement" + (list (obj3 + (req "slot" int31) + (req "block" Block_hash.encoding) + (req "operation" Operation_hash.encoding)))))) + + let filename () = + Client_config.(base_dir#get // "endorsements") + + let load () = + let filename = filename () in + if not (Sys.file_exists filename) then return LevelMap.empty else + Data_encoding.Json.read_file filename >>= function + | None -> + error "couldn't to read the endorsement file" + | Some json -> + match Data_encoding.Json.destruct encoding json with + | exception _ -> (* TODO print_error *) + error "didn't understand the endorsement file" + | map -> + return map + + let save map = + Lwt.catch + (fun () -> + let dirname = Client_config.base_dir#get in + (if not (Sys.file_exists dirname) then Utils.create_dir dirname + else Lwt.return ()) >>= fun () -> + let filename = filename () in + let json = Data_encoding.Json.construct encoding map in + Data_encoding.Json.write_file filename json >>= function + | false -> failwith "Json.write_file" + | true -> return ()) + (fun exn -> + error "could not write the endorsement file: %s." + (Printexc.to_string exn)) + + let lock = Lwt_mutex.create () + + let get_endorsement level slot = + Lwt_mutex.with_lock lock + (fun () -> + load () >>=? fun map -> + try + let _, block, op = + LevelMap.find level map + |> List.find (fun (slot',_,_) -> slot = slot') in + return (Some (block, op)) + with Not_found -> return None) + + let record_endorsement level hash slot oph = + Lwt_mutex.with_lock lock + (fun () -> + load () >>=? fun map -> + let previous = + try LevelMap.find level map + with Not_found -> [] in + save + (LevelMap.add level ((slot, hash, oph) :: previous) map)) + +end + +let get_block_hash = function + | `Hash hash -> Lwt.return hash + | `Genesis | `Head _ | `Test_head _ as block -> + Client_node_rpcs.Blocks.hash block + | `Prevalidation -> Client_node_rpcs.Blocks.hash (`Head 0) + | `Test_prevalidation -> Client_node_rpcs.Blocks.hash (`Test_head 0) + +let get_signing_slots ?max_priority block delegate level = + Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate + ?max_priority ~first_level:level ~last_level:level + block delegate () >>=? fun possibilities -> + let slots = + List.map (fun (_,slot,_) -> slot) + @@ List.filter (fun (l, _, _) -> l = level) possibilities in + return slots + +let inject_endorsement + block level ?wait ?force + src_sk source slot = + get_block_hash block >>= fun block_hash -> + Client_node_rpcs.Blocks.net block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Delegate.endorsement + block + ~net + ~source + ~block:block_hash + ~slot:slot + () >>=? fun bytes -> + let signed_bytes = Ed25519.append_signature src_sk bytes in + Client_node_rpcs.inject_operation ?force ?wait signed_bytes >>=? fun oph -> + State.record_endorsement level block_hash slot oph >>=? fun () -> + return oph + + +let previously_endorsed_slot level slot = + State.get_endorsement level slot >>=? function + | None -> return false + | Some _ -> return true + +let check_endorsement level slot = + State.get_endorsement level slot >>=? function + | None -> return () + | Some (block, _) -> + failwith + "Already signed block %a at level %a, slot %d" + Block_hash.pp_short block Raw_level.pp level slot + + +let forge_endorsement + block ?(force = false) + ~src_sk ?slot ?max_priority src_pk = + let src_pkh = Ed25519.hash src_pk in + Client_proto_rpcs.Context.next_level block >>=? fun level -> + let level = Raw_level.succ @@ level.level in + begin + match slot with + | Some slot -> return slot + | None -> + get_signing_slots ?max_priority block src_pkh level >>=? function + | slot::_ -> return slot + | [] -> error "No slot found at level %a" Raw_level.pp level + end >>=? fun slot -> + (if force then return () else check_endorsement level slot) >>=? fun () -> + inject_endorsement + block level ~wait:true ~force + src_sk src_pk slot + + +(** Worker *) + +type state = { + delegates: public_key_hash list ; + mutable best_fitness: Fitness.t ; + mutable to_endorse: endorsement list ; + delay: int64; +} +and endorsement = { + time: Time.t ; + delegate: public_key_hash ; + block: Client_mining_blocks.block_info ; + slot: int; +} + +let create_state delegates best_fitness delay = + { delegates ; + best_fitness ; + to_endorse = [] ; + delay ; + } + +let rec insert ({time} as e) = function + | [] -> [e] + | ({time = time'} :: _) as l when Time.compare time time' < 0 -> + e :: l + | e' :: l -> e' :: insert e l + +let schedule_endorsements state bis = + let may_endorse (block: Client_mining_blocks.block_info) delegate time = + Client_keys.Public_key_hash.name delegate >>= fun name -> + lwt_log_info "May endorse block %a for %s" + Block_hash.pp_short block.hash name >>= fun () -> + let b = `Hash block.hash in + let level = Raw_level.succ block.level.level in + get_signing_slots b delegate level >>=? fun slots -> + lwt_debug "Found slots for %a/%s (%d)" + Block_hash.pp_short block.hash name (List.length slots) >>= fun () -> + iter_p + (fun slot -> + previously_endorsed_slot level slot >>=? function + | true -> + lwt_debug "slot %d: previously endorsed." slot >>= fun () -> + return () + | false -> + try + let same_slot e = + e.block.level = block.level && e.slot = slot in + let old = List.find same_slot state.to_endorse in + if Fitness.compare old.block.fitness block.fitness < 0 then begin + lwt_log_info + "Schedule endorsement for block %a \ + \ (level %a, slot %d, time %a) (replace block %a)" + Block_hash.pp_short block.hash + Raw_level.pp level + slot + Time.pp_hum time + Block_hash.pp_short old.block.hash + >>= fun () -> + state.to_endorse <- + insert + { time ; delegate ; block ; slot } + (List.filter (fun e -> not (same_slot e)) state.to_endorse) ; + return () + end else begin + lwt_debug "slot %d: better pending endorsement" slot >>= fun () -> + return () + end + with Not_found -> + lwt_log_info + "Schedule endorsement for block %a \ + \ (level %a, slot %d, time %a)" + Block_hash.pp_short block.hash + Raw_level.pp level + slot + Time.pp_hum time >>= fun () -> + state.to_endorse <- + insert { time ; delegate ; block ; slot } state.to_endorse ; + return ()) + slots in + let time = Time.(add (now ()) state.delay) in + iter_p + (fun delegate -> + iter_p + (fun bi -> may_endorse bi delegate time) + bis) + state.delegates >>= function + | Error exns -> + lwt_log_error + "@[Error(s) while scheduling endorsements@,%a@]" + pp_print_error exns + | Ok () -> Lwt.return_unit + +let pop_endorsements state = + let now = Time.now () in + let rec pop acc = function + | [] -> List.rev acc, [] + | {time} :: _ as slots when Time.compare now time <= 0 -> + List.rev acc, slots + | slot :: slots -> pop (slot :: acc) slots in + let to_endorse, future_endorsement = pop [] state.to_endorse in + state.to_endorse <- future_endorsement ; + to_endorse + +let endorse state = + let to_endorse = pop_endorsements state in + iter_p + (fun {delegate;block;slot} -> + let hash = block.hash in + let b = `Hash hash in + let level = Raw_level.succ block.level.level in + previously_endorsed_slot level slot >>=? function + | true -> return () + | false -> + Client_keys.get_key delegate >>=? fun (name, pk, sk) -> + lwt_debug "Endorsing %a for %s (slot %d)!" + Block_hash.pp_short hash name slot >>= fun () -> + inject_endorsement + b level ~wait:false ~force:true + sk pk slot >>=? fun oph -> + message + "Injected endorsement for block '%a' \ + \ (level %a, slot %d, contract %s) '%a'" + Block_hash.pp_short hash + Raw_level.pp level + slot name + Operation_hash.pp_short oph ; + return ()) + to_endorse + +let compute_timeout state = + match state.to_endorse with + | [] -> Lwt_utils.never_ending + | {time} :: _ -> + let delay = (Time.diff time (Time.now ())) in + if delay <= 0L then + Lwt.return_unit + else + Lwt_unix.sleep (Int64.to_float delay) + +let create ~delay contracts block_stream = + lwt_log_info "Starting endorsement daemon" >>= fun () -> + Lwt_stream.get block_stream >>= function + | None | Some [] -> + error "Can't fetch the current block head." + | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) -> + let last_get_block = ref None in + let get_block () = + match !last_get_block with + | None -> + let t = Lwt_stream.get block_stream in + last_get_block := Some t ; + t + | Some t -> t in + let state = create_state contracts fitness (Int64.of_int delay) in + let rec worker_loop () = + let timeout = compute_timeout state in + Lwt.choose [ (timeout >|= fun () -> `Timeout) ; + (get_block () >|= fun b -> `Hash b) ] >>= function + | `Hash None -> + Lwt.return_unit + | `Hash (Some bis) -> + Lwt.cancel timeout ; + last_get_block := None ; + schedule_endorsements state bis >>= fun () -> + worker_loop () + | `Timeout -> + begin + endorse state >>= function + | Ok () -> Lwt.return_unit + | Error errs -> + lwt_log_error "Error while endorsing:\n%a" + pp_print_error + errs >>= fun () -> + Lwt.return_unit + end >>= fun () -> + worker_loop () in + schedule_endorsements state initial_heads >>= fun () -> + worker_loop () diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli b/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli new file mode 100644 index 000000000..afb6a33df --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val forge_endorsement: + Client_proto_rpcs.block -> + ?force:bool -> + src_sk:secret_key -> + ?slot:int -> + ?max_priority:int -> + public_key -> + Operation_hash.t tzresult Lwt.t + +val create: + delay: int -> + public_key_hash list -> + Client_mining_blocks.block_info list Lwt_stream.t -> + unit Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml new file mode 100644 index 000000000..fdee8d753 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -0,0 +1,454 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Client.Mining + +let generate_proof_of_work_nonce () = + Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size + +let generate_seed_nonce () = + match Nonce.of_bytes @@ + Sodium.Random.Bigbytes.generate Constants.nonce_length with + | Error _ -> assert false + | Ok nonce -> nonce + +let rec compute_stamp block delegate_sk shell mining_slot seed_nonce_hash = + Client_proto_rpcs.Constants.stamp_threshold block >>=? fun stamp_threshold -> + let rec loop () = + let proof_of_work_nonce = generate_proof_of_work_nonce () in + let unsigned_header = + Tezos_context.Block.forge_header + shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in + let signed_header = + Ed25519.append_signature delegate_sk unsigned_header in + let block_hash = Block_hash.hash_bytes [signed_header] in + if Mining.check_hash block_hash stamp_threshold then + proof_of_work_nonce + else + loop () in + return (loop ()) + +let inject_block block + ?force + ~priority ~timestamp ~fitness ~seed_nonce + ~src_sk operations = + let block = match block with `Prevalidation -> `Head 0 | block -> block in + Client_node_rpcs.Blocks.info block >>= fun bi -> + let seed_nonce_hash = Nonce.hash seed_nonce in + Client_proto_rpcs.Context.next_level block >>=? fun level -> + let shell = + { Store.net_id = bi.net ; predecessor = bi.hash ; + timestamp ; fitness ; operations } in + let slot = level.level, Int32.of_int priority in + compute_stamp block + src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> + Client_proto_rpcs.Helpers.Forge.block_header + block + ~net:bi.net + ~predecessor:bi.hash + ~timestamp + ~fitness + ~operations + ~level:level.level + ~priority:priority + ~seed_nonce_hash + ~proof_of_work_nonce + () >>=? fun unsigned_header -> + let signed_header = Ed25519.append_signature src_sk unsigned_header in + Client_node_rpcs.inject_block + ~wait:true ?force signed_header >>=? fun block_hash -> + return block_hash + +let forge_block block + ?force + ?operations ?(best_effort = operations = None) ?(sort = best_effort) + ?timestamp ?max_priority ?priority + ~seed_nonce ~src_sk src_pkh = + let block = + match block with + | `Prevalidation -> `Head 0 + | `Test_prevalidation -> `Test_head 0 + | block -> block in + Client_proto_rpcs.Context.level block >>=? fun level -> + let level = Raw_level.succ level.level in + begin + match operations with + | None -> + Client_node_rpcs.Blocks.pending_operations block >|= fun (ops, pendings) -> + Operation_hash_set.elements @@ + Operation_hash_set.union (Updater.operations ops) pendings + | Some operations -> Lwt.return operations + end >>= fun operations -> + begin + match priority with + | Some prio -> begin + Client_proto_rpcs.Helpers.minimal_time block ~prio () >>=? fun time -> + return (prio, Some time) + end + | None -> + Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate + ?max_priority + ~first_level:level + ~last_level:level + block src_pkh () >>=? fun possibilities -> + try + let _, prio, time = + List.find (fun (l,_,_) -> l = level) possibilities in + return (prio, time) + with Not_found -> + failwith "No slot found at level %a" Raw_level.pp level + end >>=? fun (priority, minimal_timestamp) -> + lwt_log_info "Mining block at level %a prio %d" + Raw_level.pp level priority >>= fun () -> + begin + match timestamp, minimal_timestamp with + | None, None -> failwith "Can't compute the expected timestamp" + | None, timestamp | timestamp, None -> return timestamp + | Some timestamp, Some minimal_timestamp -> + if timestamp < minimal_timestamp then + failwith + "Proposed timestamp %a is earlier than minimal timestamp %a" + Time.pp_hum timestamp + Time.pp_hum minimal_timestamp + else + return (Some timestamp) + end >>=? fun timestamp -> + let request = List.length operations in + Client_node_rpcs.Blocks.preapply block ?timestamp ~sort operations >>=? + fun { operations ; fitness ; timestamp } -> + let valid = List.length operations.applied in + lwt_log_info "Found %d valid operations (%d refused) for timestamp %a" + valid (request - valid) + Time.pp_hum timestamp >>= fun () -> + lwt_log_info "Computed fitness %a" Fitness.pp fitness >>= fun () -> + if best_effort + || ( Operation_hash_map.is_empty operations.refused + && Operation_hash_map.is_empty operations.branch_refused + && Operation_hash_map.is_empty operations.branch_delayed ) then + inject_block ?force ~src_sk + ~priority ~timestamp ~fitness ~seed_nonce block operations.applied + else + failwith "Cannot (fully) validate the given operations." + + +(** Worker *) + +module State : sig + + val get_block: + Raw_level.t -> Block_hash.t list tzresult Lwt.t + + val record_block: + Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t + +end = struct + + module LevelMap = Map.Make(Raw_level) + + type t = Block_hash.t list LevelMap.t + let encoding : t Data_encoding.t = + let open Data_encoding in + conv + (fun x -> LevelMap.bindings x) + (fun l -> List.fold_left (fun x (y, z) -> LevelMap.add y z x) LevelMap.empty l) + (list (obj2 + (req "level" Raw_level.encoding) + (req "blocks" (list Block_hash.encoding)))) + + let filename () = + Client_config.(base_dir#get // "blocks") + + let load () = + let filename = filename () in + if not (Sys.file_exists filename) then return LevelMap.empty else + Data_encoding.Json.read_file filename >>= function + | None -> + failwith "couldn't to read the block file" + | Some json -> + match Data_encoding.Json.destruct encoding json with + | exception _ -> (* TODO print_error *) + failwith "didn't understand the block file" + | map -> + return map + + let save map = + Lwt.catch + (fun () -> + let dirname = Client_config.base_dir#get in + (if not (Sys.file_exists dirname) then Utils.create_dir dirname + else Lwt.return ()) >>= fun () -> + let filename = filename () in + let json = Data_encoding.Json.construct encoding map in + Data_encoding.Json.write_file filename json >>= function + | false -> failwith "Json.write_file" + | true -> return ()) + (fun exn -> + failwith + "could not write the block file: %s." + (Printexc.to_string exn)) + + let lock = Lwt_mutex.create () + + let get_block level = + Lwt_mutex.with_lock lock + (fun () -> + load () >>=? fun map -> + try + let blocks = LevelMap.find level map in + return blocks + with Not_found -> return []) + + let record_block level hash nonce = + Lwt_mutex.with_lock lock + (fun () -> + load () >>=? fun map -> + let previous = + try LevelMap.find level map + with Not_found -> [] in + save + (LevelMap.add level (hash :: previous) map)) >>=? fun () -> + Client_proto_nonces.add hash nonce + +end + +let get_mining_slot + ?max_priority (bi: Client_mining_blocks.block_info) delegates = + let block = `Hash bi.hash in + let level = Raw_level.succ bi.level.level in + Lwt_list.filter_map_p + (fun delegate -> + Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate + ?max_priority + ~first_level:level + ~last_level:level + block delegate () >>= function + | Error errs -> + log_error "Error while fetching mining possibilities:\n%a" + pp_print_error errs ; + Lwt.return_none + | Ok slots -> + let convert = function + | (_,_,None) -> None + | (_lvl, slot, Some timestamp) -> + Some (timestamp, (bi, slot, delegate)) in + Lwt.return (Some (Utils.filter_map convert slots))) + delegates >>= fun slots -> + let sorted_slots = + List.sort (fun (t1,_) (t2,_) -> Time.compare t1 t2) (List.flatten slots) in + match sorted_slots with + | [] -> Lwt.return None + | slot :: _ -> Lwt.return (Some slot) + +let rec insert_mining_slot slot = function + | [] -> [slot] + | ((timestamp,_) :: _) as slots when Time.(fst slot < timestamp) -> slot :: slots + | slot' :: slots -> slot' :: insert_mining_slot slot slots + +type state = { + genesis: Block_hash.t ; + delegates: public_key_hash list ; + mutable best_fitness: Fitness.t ; + mutable future_slots: + (Time.t * (Client_mining_blocks.block_info * int * public_key_hash)) list ; +} + +let create_state genesis delegates best_fitness = + { genesis ; + delegates ; + best_fitness ; + future_slots = [] ; + } + +let compute_timeout { future_slots } = + match future_slots with + | [] -> + Lwt_utils.never_ending + | (timestamp, _) :: _ -> + let now = Time.now () in + let delay = Time.diff timestamp now in + if delay <= 0L then + Lwt.return_unit + else + Lwt_unix.sleep (Int64.to_float delay) + +let insert_block ?max_priority state (bi: Client_mining_blocks.block_info) = + if Fitness.compare state.best_fitness bi.fitness < 0 then + state.best_fitness <- bi.fitness ; + get_mining_slot ?max_priority bi state.delegates >>= function + | None -> + lwt_debug + "Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () -> + Lwt.return_unit + | Some ((timestamp, (_,_,delegate)) as slot) -> + Client_keys.Public_key_hash.name delegate >>= fun name -> + lwt_log_info "New mining slot at %a for %s after %a" + Time.pp_hum timestamp + name + Block_hash.pp_short bi.hash >>= fun () -> + state.future_slots <- insert_mining_slot slot state.future_slots ; + Lwt.return_unit + +let pop_mining_slots state = + let now = Time.now () in + let rec pop acc = function + | [] -> List.rev acc, [] + | ((timestamp,_) :: _) as slots when Time.compare now timestamp < 0 -> + List.rev acc, slots + | slot :: slots -> pop (slot :: acc) slots in + let slots, future_slots = pop [] state.future_slots in + state.future_slots <- future_slots ; + slots + +let insert_blocks ?max_priority state bis = + Lwt_list.iter_s (insert_block ?max_priority state) bis + +let mine state = + let slots = pop_mining_slots state in + Lwt_list.map_p + (fun (timestamp, (bi, prio, delegate)) -> + let block = `Hash bi.Client_mining_blocks.hash in + let timestamp = + if Block_hash.equal bi.Client_mining_blocks.hash state.genesis then + Time.now () + else + timestamp in + Client_keys.Public_key_hash.name delegate >>= fun name -> + lwt_debug "Try mining after %a (slot %d) for %s (%a)" + Block_hash.pp_short bi.hash + prio name Time.pp_hum timestamp >>= fun () -> + Client_node_rpcs.Blocks.pending_operations + block >>= fun (res, ops) -> + let operations = + let open Operation_hash_set in + elements (union ops (Updater.operations res)) in + let request = List.length operations in + Client_node_rpcs.Blocks.preapply block + ~timestamp ~sort:true operations >>= function + | Error errs -> + lwt_log_error "Error while prevalidating operations:\n%a" + pp_print_error + errs >>= fun () -> + Lwt.return_none + | Ok { operations ; fitness ; timestamp } -> + lwt_debug + "Computed condidate block after %a (slot %d): %d/%d fitness: %a" + Block_hash.pp_short bi.hash prio + (List.length operations.applied) request + Fitness.pp fitness + >>= fun () -> + Lwt.return + (Some (bi, prio, fitness, timestamp, operations, delegate))) + slots >>= fun candidates -> + let candidates = + List.sort + (fun (_,_,f1,_,_,_) (_,_,f2,_,_,_) -> ~- (Fitness.compare f1 f2)) + (Utils.unopt_list candidates) in + match candidates with + | (bi, priority, fitness, timestamp, operations, delegate) :: _ + when Fitness.compare state.best_fitness fitness < 0 -> begin + let level = Raw_level.succ bi.level.level in + lwt_log_info + "Select candidate block after %a (slot %d) fitness: %a" + Block_hash.pp_short bi.hash priority + Fitness.pp fitness >>= fun () -> + let seed_nonce = generate_seed_nonce () in + Client_keys.get_key delegate >>=? fun (_,_,src_sk) -> + inject_block ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce + (`Hash bi.hash) operations.applied + |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash -> + State.record_block level block_hash seed_nonce + |> trace_exn (Failure "Error while recording block") >>=? fun () -> + Client_keys.Public_key_hash.name delegate >>= fun name -> + Cli_entries.message + "Injected block %a for %s after %a \ + \ (level %a, slot %d, fitness %a, operations %d)" + Block_hash.pp_short block_hash + name + Block_hash.pp_short bi.hash + Raw_level.pp level priority + Fitness.pp fitness + (List.length operations.applied) ; + return () + end + | _ -> + lwt_debug "No valid candidates." >>= fun () -> + return () + +let create ?max_priority delegates + (block_stream: Client_mining_blocks.block_info list Lwt_stream.t) + (endorsement_stream: Client_mining_operations.valid_endorsement Lwt_stream.t) = + Lwt_stream.get block_stream >>= function + | None | Some [] -> + Cli_entries.error "Can't fetch the current block head." + | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) -> + Client_node_rpcs.Blocks.hash `Genesis >>= fun genesis_hash -> + let last_get_block = ref None in + let get_block () = + match !last_get_block with + | None -> + let t = Lwt_stream.get block_stream in + last_get_block := Some t ; + t + | Some t -> t in + let last_get_endorsement = ref None in + let get_endorsement () = + match !last_get_endorsement with + | None -> + let t = Lwt_stream.get endorsement_stream in + last_get_endorsement := Some t ; + t + | Some t -> t in + let state = create_state genesis_hash delegates fitness in + insert_blocks ?max_priority state initial_heads >>= fun () -> + let rec worker_loop () = + let timeout = compute_timeout state in + Lwt.choose [ (timeout >|= fun () -> `Timeout) ; + (get_block () >|= fun b -> `Hash b) ; + (get_endorsement () >|= fun e -> `Endorsement e) ; + ] >>= function + | `Hash None + | `Endorsement None -> + Lwt.return_unit + | `Hash (Some bis) -> begin + Lwt.cancel timeout ; + last_get_block := None ; + lwt_debug + "@[Discoverer blocks:@ %a@]" + (Format.pp_print_list + (fun ppf bi -> + Block_hash.pp_short ppf bi.Client_mining_blocks.hash)) + bis + >>= fun () -> + insert_blocks ?max_priority state bis >>= fun () -> + worker_loop () + end + | `Endorsement (Some e) -> + Lwt.cancel timeout ; + last_get_endorsement := None ; + Client_keys.Public_key_hash.name + e.Client_mining_operations.source >>= fun _source -> + (* TODO *) + worker_loop () + | `Timeout -> + lwt_debug "Waking up for mining..." >>= fun () -> + begin + mine state >>= function + | Ok () -> Lwt.return_unit + | Error errs -> + lwt_log_error "Error while mining:\n%a" + pp_print_error + errs >>= fun () -> + Lwt.return_unit + end >>= fun () -> + worker_loop () in + lwt_log_info "Starting mining daemon" >>= fun () -> + worker_loop () + +(* FIXME bug in ocamldep ?? *) +open Level diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.mli b/src/client/embedded/bootstrap/mining/client_mining_forge.mli new file mode 100644 index 000000000..2eb38ec07 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val generate_seed_nonce: unit -> Nonce.t + +val inject_block: + Client_proto_rpcs.block -> + ?force:bool -> + priority:int -> + timestamp:Time.t -> + fitness:Fitness.t -> + seed_nonce:Nonce.t -> + src_sk:secret_key -> + Operation_hash.t list -> + Block_hash.t tzresult Lwt.t + +val forge_block: + Client_proto_rpcs.block -> + ?force:bool -> + ?operations:Operation_hash.t list -> + ?best_effort:bool -> + ?sort:bool -> + ?timestamp:Time.t -> + ?max_priority:int -> + ?priority:int -> + seed_nonce:Nonce.t -> + src_sk:secret_key -> + public_key_hash -> + Block_hash.t tzresult Lwt.t + +module State : sig + val get_block: Raw_level.t -> Block_hash.t list tzresult Lwt.t + val record_block: Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t +end + +val create: + ?max_priority: int -> + public_key_hash list -> + Client_mining_blocks.block_info list Lwt_stream.t -> + Client_mining_operations.valid_endorsement Lwt_stream.t -> + unit Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml new file mode 100644 index 000000000..ee93b2928 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -0,0 +1,166 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Cli_entries +open Client_proto_contracts + +let mine_block block ?force ?max_priority ?src_sk delegate = + begin + match src_sk with + | None -> + Client_keys.get_key delegate >>=? fun (_, _, src_sk) -> + return src_sk + | Some sk -> return sk + end >>=? fun src_sk -> + Client_proto_rpcs.Context.level block >>=? fun level -> + let level = Raw_level.succ level.level in + let seed_nonce = Client_mining_forge.generate_seed_nonce () in + Client_mining_forge.forge_block + ~timestamp:(Time.now ()) + ?force ?max_priority + ~seed_nonce ~src_sk block delegate >>=? fun block_hash -> + Client_mining_forge.State.record_block level block_hash seed_nonce + |> trace_exn (Failure "Error while recording block") >>=? fun () -> + message "Injected block %a" Block_hash.pp_short block_hash ; + return () + +let endorse_block ?force ?max_priority delegate = + let block = Client_proto_args.block () in + Client_keys.get_key delegate >>=? fun (_src_name, src_pk, src_sk) -> + Client_mining_endorsement.forge_endorsement + block ?force ?max_priority ~src_sk src_pk >>=? fun oph -> + answer "Operation successfully injected in the node." ; + answer "Operation hash is '%a'." Operation_hash.pp oph ; + return () + +let get_predecessor_cycle cycle = + match Cycle.pred cycle with + | None -> + if Cycle.(cycle = root) then + error "No predecessor for the first cycle" + else + error + "Cannot compute the predecessor of cycle %a" + Cycle.pp cycle + | Some cycle -> Lwt.return cycle + +let do_reveal ?force block blocks = + let nonces = List.map snd blocks in + Client_mining_revelation.forge_seed_nonce_revelation + block ?force nonces >>=? fun () -> + Client_proto_nonces.dels (List.map fst blocks) >>=? fun () -> + return () + +let reveal_block_nonces ?force block_hashes = + let block = Client_proto_args.block () in + Lwt_list.filter_map_p + (fun hash -> + Lwt.catch + (fun () -> + Client_mining_blocks.info (`Hash hash) >>= function + | Ok bi -> Lwt.return (Some bi) + | Error _ -> + Lwt.fail Not_found) + (fun _ -> + Format.eprintf "Cannot find block %a in the chain. (ignoring)@." + Block_hash.pp_short hash ; + Lwt.return_none)) + block_hashes >>= fun block_infos -> + map_filter_s (fun (bi : Client_mining_blocks.block_info) -> + Client_proto_nonces.find bi.hash >>= function + | None -> + Format.eprintf "Cannot find nonces for block %a (ignoring)@." + Block_hash.pp_short bi.hash ; + return None + | Some nonce -> + return (Some (bi.hash, (bi.level.level, nonce)))) + block_infos >>=? fun blocks -> + do_reveal ?force block blocks + +let reveal_nonces ?force () = + let block = Client_proto_args.block () in + Client_proto_rpcs.Context.next_level block >>=? fun level -> + let cur_cycle = level.cycle in + get_predecessor_cycle cur_cycle >>= fun cycle -> + Client_mining_blocks.blocks_from_cycle block cycle >>=? fun block_infos -> + map_filter_s (fun (bi : Client_mining_blocks.block_info) -> + Client_proto_nonces.find bi.hash >>= function + | None -> return None + | Some nonce -> + Format.eprintf "Found nonce for %a (level: %a)@." + Block_hash.pp_short bi.hash Level.pp bi.level ; + return (Some (bi.hash, (bi.level.level, nonce)))) + block_infos >>=? fun blocks -> + do_reveal ?force block blocks + +open Client_proto_args + +let run_daemon delegates = + Client_mining_daemon.run + ?max_priority:!max_priority + ~delay:!endorsement_delay + (List.map snd delegates) + +let commands () = + let open Cli_entries in + register_group "delegate" "Commands related to delegate operations." ; + [ + command + ~group: "delegate" + ~desc: "Launch a daemon that handles delegate operations." + ~args: [endorsement_delay_arg; max_priority_arg; + Daemon.mining_arg ; Daemon.endorsement_arg ; Daemon.denunciation_arg] + (prefixes [ "launch" ; "daemon" ] + @@ seq_of_param Client_keys.Public_key_hash.alias_param ) + run_daemon ; + command + ~group: "delegate" + ~desc: "Forge and inject an endorsement operation" + ~args: [ force_arg ] + (prefixes [ "endorse"; "for" ] + @@ Client_keys.Public_key_hash.alias_param + ~n:"miner" ~desc: "name of the delegate owning the endorsement right" + @@ stop) + (fun (_, delegate) () -> + endorse_block + ~force:!force ?max_priority:!max_priority delegate >>= + Client_proto_rpcs.handle_error) ; + command + ~group: "delegate" + ~desc: "Forge and inject block using the delegate rights" + ~args: [ max_priority_arg ; force_arg ] + (prefixes [ "mine"; "for" ] + @@ Client_keys.Public_key_hash.alias_param + ~n:"miner" ~desc: "name of the delegate owning the mining right" + @@ stop) + (fun (_, delegate) () -> + mine_block (block ()) + ~force:!force ?max_priority:!max_priority delegate >>= + Client_proto_rpcs.handle_error) ; + command + ~group: "delegate" + ~desc: "Forge and inject a seed-nonce revelation operation" + ~args: [ force_arg ] + (prefixes [ "reveal"; "nonce"; "for" ] + @@ Cli_entries.seq_of_param Block_hash.param) + (fun block_hashes -> + reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ; + command + ~group: "delegate" + ~desc: "Forge and inject redemption operations" + ~args: [ force_arg ] + (prefixes [ "reveal"; "nonces" ] + @@ stop) + (fun () -> + reveal_nonces ~force:!force () >>= Client_proto_rpcs.handle_error) ; + ] + +let () = + Client_version.register Client_proto_main.protocol @@ + commands () diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.mli b/src/client/embedded/bootstrap/mining/client_mining_main.mli new file mode 100644 index 000000000..85f38966e --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_main.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val mine_block: + Client_proto_rpcs.block -> + ?force:bool -> + ?max_priority: int -> + ?src_sk:secret_key -> + public_key_hash -> + unit tzresult Lwt.t + +val commands: unit -> Cli_entries.command list diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.ml b/src/client/embedded/bootstrap/mining/client_mining_operations.ml new file mode 100644 index 000000000..6df2bde39 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.ml @@ -0,0 +1,102 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Client.Mining + +open Operation + +type operation = { + hash: Operation_hash.t ; + content: (Updater.shell_operation * proto_operation) option +} + +let monitor ?contents ?check () = + Client_node_rpcs.Operations.monitor ?contents () >>= fun ops_stream -> + let convert ops = + Lwt_list.filter_map_p + (fun (hash, bytes) -> + match bytes with + | None -> Lwt.return (Some { hash; content = None }) + | Some ({ Store.shell ; proto } : Updater.raw_operation) -> + Client_proto_rpcs.Helpers.Parse.operations + `Prevalidation ?check shell proto >>= function + | Ok proto -> Lwt.return (Some { hash ; content = Some (shell, proto) }) + | Error err -> + lwt_log_error + "@[Error while parsing operations@,%a@[" + pp_print_error err >>= fun () -> + Lwt.return None) + ops + in + Lwt.return (Lwt_stream.map_s convert ops_stream) + + +type valid_endorsement = { + hash: Operation_hash.t ; + source: public_key_hash ; + block: Block_hash.t ; + slots: int list ; +} + +let filter_valid_endorsement { hash; content } = + let open Tezos_context in + match content with + | None + | Some (_, Anonymous_operations _) + | Some (_, Sourced_operations (Manager_operations _ )) -> + Lwt.return_none + | Some ({net_id}, Sourced_operations (Delegate_operations { source ; operations })) -> + let source = Ed25519.hash source in + let endorsements = + Utils.unopt_list @@ List.map + (function + | Endorsement { block ; slot } -> Some (block, slot) + | _ -> None) + operations in + match endorsements with + | [] -> Lwt.return_none + | ((block, _) :: _) as slots -> + try + let slots = + List.map + (fun (block', slot) -> + if not (Block_hash.equal block block') then raise Not_found ; + slot) + slots in + (* Ensure thath the block has been previously validated by + the node. This might took some times... *) + Client_node_rpcs.validate_block net_id block >>= function + | Error error -> + lwt_log_info + "@[Found endorsement for an invalid block@,%a@[" + pp_print_error error >>= fun () -> + Lwt.return_none + | Ok () -> + Client_node_rpcs.Blocks.preapply (`Hash block) [hash] >>= function + | Ok _ -> + Lwt.return (Some { hash ; source ; block ; slots }) + | Error error -> + lwt_log_error + "@[Error while prevalidating endorsements@,%a@[" + pp_print_error error >>= fun () -> + Lwt.return_none + with Not_found -> Lwt.return_none + +let monitor_endorsement () = + monitor ~contents:true ~check:true () >>= fun ops_stream -> + let endorsement_stream, push = Lwt_stream.create () in + Lwt_stream.on_termination ops_stream (fun () -> push None) ; + Lwt.async (fun () -> + Lwt_stream.iter_p + (Lwt_list.iter_p (fun e -> + filter_valid_endorsement e >>= function + | None -> Lwt.return_unit + | Some e -> push (Some e) ; Lwt.return_unit)) + ops_stream) ; + Lwt.return endorsement_stream diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.mli b/src/client/embedded/bootstrap/mining/client_mining_operations.mli new file mode 100644 index 000000000..daca93419 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.mli @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type operation = { + hash: Operation_hash.t ; + content: (Updater.shell_operation * proto_operation) option +} + +val monitor: + ?contents:bool -> ?check:bool -> unit -> + operation list Lwt_stream.t Lwt.t + +type valid_endorsement = { + hash: Operation_hash.t ; + source: public_key_hash ; + block: Block_hash.t ; + slots: int list ; +} + +val filter_valid_endorsement: + operation -> valid_endorsement option Lwt.t + +val monitor_endorsement: + unit -> valid_endorsement Lwt_stream.t Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_revelation.ml b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml new file mode 100644 index 000000000..696891d90 --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Cli_entries +open Tezos_context +open Logging.Client.Revelation + +let inject_seed_nonce_revelation block ?force ?wait nonces = + let operations = + List.map + (fun (level, nonce) -> + Seed_nonce_revelation { level ; nonce }) nonces in + Client_node_rpcs.Blocks.net block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Anonymous.operations + block ~net operations >>=? fun bytes -> + Client_node_rpcs.inject_operation ?force ?wait bytes >>=? fun oph -> + return oph + +type Error_monad.error += Bad_revelation + +let forge_seed_nonce_revelation block ?(force = false) redempted_nonces = + begin + if force then return redempted_nonces else + map_filter_s (fun (level, nonce) -> + Client_proto_rpcs.Context.Nonce.get block level >>=? function + | Forgotten -> + message "Too late revelation for level %a" + Raw_level.pp level ; + return None + | Revealed _ -> + message "Ignoring previously-revealed nonce for level %a" + Raw_level.pp level ; + return None + | Missing nonce_hash -> + if Nonce.check_hash nonce nonce_hash then + return (Some (level, nonce)) + else + lwt_log_error "Incoherent nonce for level %a" + Raw_level.pp level >>= fun () -> + return None) + redempted_nonces + end >>=? fun nonces -> + match nonces with + | [] -> + message "No nonce to reveal"; + return () + | _ -> + inject_seed_nonce_revelation + block ~force ~wait:true nonces >>=? fun oph -> + answer "Operation successfully injected in the node." ; + answer "Operation hash is '%a'." Operation_hash.pp_short oph ; + return () diff --git a/src/client/embedded/bootstrap/mining/client_mining_revelation.mli b/src/client/embedded/bootstrap/mining/client_mining_revelation.mli new file mode 100644 index 000000000..f426f473b --- /dev/null +++ b/src/client/embedded/bootstrap/mining/client_mining_revelation.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val inject_seed_nonce_revelation: + Client_proto_rpcs.block -> + ?force:bool -> + ?wait:bool -> + (Raw_level.t * Nonce.t) list -> + Operation_hash.t tzresult Lwt.t + +val forge_seed_nonce_revelation: + Client_proto_rpcs.block -> + ?force:bool -> + (Raw_level.t * Nonce.t) list -> + unit tzresult Lwt.t diff --git a/src/client/embedded/bootstrap/script_located_ir.ml b/src/client/embedded/bootstrap/script_located_ir.ml new file mode 100644 index 000000000..dceb0d0b4 --- /dev/null +++ b/src/client/embedded/bootstrap/script_located_ir.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type point = + int * int + +type location = + point * point + +type node = + | Int of location * string + | Float of location * string + | String of location * string + | Prim of location * string * node list + | Seq of location * node list + +let node_location = function + | Int (loc, _) + | Float (loc, _) + | String (loc, _) + | Prim (loc, _, _) + | Seq (loc, _) -> loc + +(*-- Located errors ---------------------------------------------------------*) + +(* Lexer error *) +exception Illegal_character of location * char +exception Illegal_escape of location * string +exception Invalid_indentation of location +exception Invalid_indentation_after_opener of location * char +exception Invalid_indentation_in_block of location * char * location +exception Newline_in_string of location +exception Unaligned_closer of location * char * char * location +exception Unclosed of location * char * location +exception Unopened of location * char +exception Unterminated_comment of location * location +exception Unterminated_string of location +exception Unterminated_string_in_comment of location * location * location + +(* Parser error *) +exception Invalid_application of location +exception Sequence_in_parens of location +exception Missing_program_field of string + +(*-- Converters between IR and Located IR -----------------------------------*) + +let strip_locations root = + let id = let id = ref (-1) in fun () -> incr id ; !id in + let rec strip_locations l = + let id = id () in + match l with + | Int (_, v) -> + Script.Int (id, v) + | Float (_, v) -> + Script.Float (id, v) + | String (_, v) -> + Script.String (id, v) + | Seq (_, seq) -> + Script.Seq (id, List.map strip_locations seq) + | Prim (_, name, seq) -> + Script.Prim (id, name, List.map strip_locations seq) in + strip_locations root diff --git a/src/client/embedded/demo/.merlin b/src/client/embedded/demo/.merlin new file mode 100644 index 000000000..3a1cffa6d --- /dev/null +++ b/src/client/embedded/demo/.merlin @@ -0,0 +1,9 @@ +REC +S . +B . +S ../../../proto +B ../../../proto +S ../../../proto/demo +B _tzbuild +FLG -open Client_embedded_proto_demo +FLG -open Register_client_embedded_proto_demo diff --git a/src/client/embedded/demo/Makefile b/src/client/embedded/demo/Makefile new file mode 100644 index 000000000..a3eec6135 --- /dev/null +++ b/src/client/embedded/demo/Makefile @@ -0,0 +1,12 @@ + +PROTO_VERSION = demo + +IMPLS = \ + client_proto_rpcs.ml \ + client_proto_main.ml + +INTFS = \ + client_proto_rpcs.mli \ + client_proto_main.mli + +include ../Makefile.shared diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml new file mode 100644 index 000000000..af367ffc1 --- /dev/null +++ b/src/client/embedded/demo/client_proto_main.ml @@ -0,0 +1,92 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let protocol = + Protocol_hash.of_b48check + "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let demo () = + let block = Client_config.block () in + Cli_entries.message "Calling the 'echo' RPC." ; + let msg = "test" in + Client_proto_rpcs.echo block msg >>= fun reply -> + fail_unless (reply = msg) (Unclassified "...") >>=? fun () -> + begin + Cli_entries.message "Calling the 'failing' RPC." ; + Client_proto_rpcs.failing block 3 >>= function + | Error [Ecoproto_error [Error.Demo_error 3]] -> + return () + | _ -> failwith "..." + end >>=? fun () -> + Cli_entries.message "Direct call to `demo_error`." ; + begin Error.demo_error 101010 >|= wrap_error >>= function + | Error [Ecoproto_error [Error.Demo_error 101010]] -> + return () + | _ -> failwith "...." + end >>=? fun () -> + Cli_entries.answer "All good!" ; + return () + +let mine () = + let block = + match Client_config.block () with + | `Prevalidation -> `Head 0 + | `Test_prevalidation -> `Test_head 0 + | b -> b in + Client_node_rpcs.Blocks.info block >>= fun bi -> + let fitness = + match bi.fitness with + | [ v ; b ] -> + let f = MBytes.get_int64 b 0 in + MBytes.set_int64 b 0 (Int64.succ f) ; + [ v ; b ] + | _ -> + Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness ; + exit 2 in + Client_node_rpcs.forge_block + ~net:bi.net ~predecessor:bi.hash + fitness [] (MBytes.create 0) >>= fun bytes -> + Client_node_rpcs.inject_block ~wait:true bytes >>=? fun hash -> + Cli_entries.answer "Injected %a" Block_hash.pp_short hash ; + return () + +let handle_error = function + | Ok res -> + Lwt.return res + | Error exns -> + pp_print_error Format.err_formatter exns ; + Cli_entries.error "cannot continue" + +let commands () = + let open Cli_entries in + register_group "demo" "Some demo command" ; + [ + command + ~group: "demo" + ~desc: "A demo command" + (fixed [ "demo" ]) + (fun () -> demo () >>= handle_error) ; + command + ~group: "demo" + ~desc: "An failing command" + (fixed [ "fail" ]) + (fun () -> + Error.demo_error 101010 + >|= wrap_error + >>= handle_error ) ; + command + ~group: "demo" + ~desc: "Mine an empty block" + (fixed [ "mine" ]) + (fun () -> mine () >>= handle_error) ; + ] + +let () = + Client_version.register protocol @@ + commands () diff --git a/src/client/embedded/demo/client_proto_main.mli b/src/client/embedded/demo/client_proto_main.mli new file mode 100644 index 000000000..3a12a30c8 --- /dev/null +++ b/src/client/embedded/demo/client_proto_main.mli @@ -0,0 +1,9 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + diff --git a/src/client/embedded/demo/client_proto_rpcs.ml b/src/client/embedded/demo/client_proto_rpcs.ml new file mode 100644 index 000000000..f43445e2c --- /dev/null +++ b/src/client/embedded/demo/client_proto_rpcs.ml @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let call_service1 s block a1 = + Client_node_rpcs.call_service1 + (s Node_rpc_services.Blocks.proto_path) block a1 +let call_error_service1 s block a1 = + call_service1 s block a1 >|= wrap_error + +let echo = call_service1 Services.echo_service +let failing = call_error_service1 Services.failing_service diff --git a/src/client/embedded/demo/client_proto_rpcs.mli b/src/client/embedded/demo/client_proto_rpcs.mli new file mode 100644 index 000000000..bfb965889 --- /dev/null +++ b/src/client/embedded/demo/client_proto_rpcs.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Node_rpc_services + +val echo: Blocks.block -> string -> string Lwt.t +val failing: Blocks.block -> int -> unit tzresult Lwt.t diff --git a/src/client_main.ml b/src/client_main.ml new file mode 100644 index 000000000..b907ce0e3 --- /dev/null +++ b/src/client_main.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Main Program *) + +open Lwt + +(* Main (lwt) entry *) +let main () = + Random.self_init () ; + Sodium.Random.stir () ; + catch + (fun () -> + let block = Client_config.preparse_args () in + Lwt.catch + (fun () -> + Client_node_rpcs.Blocks.protocol block) + (fun _ -> + Cli_entries.message "\n\ + The connection to the RPC server failed, \ + using the default protocol version.\n" ; + Lwt.return Client_bootstrap.Client_proto_main.protocol) + >>= fun version -> + let commands = + Client_generic_rpcs.commands @ + Client_keys.commands () @ + Client_version.commands_for_version version in + Client_config.parse_args ~version + (Cli_entries.usage commands) + (Cli_entries.inline_dispatcher commands)) + (function + | Arg.Help help -> + Format.printf "%s%!" help ; + Pervasives.exit 0 + | Arg.Bad help -> + Format.eprintf "%s%!" help ; + Pervasives.exit 1 + | Cli_entries.Command_not_found -> + Format.eprintf "Unkonwn command, try `-help`.\n%!" ; + Pervasives.exit 1 + | Client_version.Version_not_found -> + Format.eprintf "Unkonwn protocol version, try `list versions`.\n%!" ; + Pervasives.exit 1 + | Cli_entries.Bad_argument (idx, _n, v) -> + Format.eprintf "There's a problem with argument %d, %s.\n%!" idx v ; + Pervasives.exit 1 + | Cli_entries.Command_failed message -> + Format.eprintf "Command failed, %s.\n%!" message ; + Pervasives.exit 1 + | exn -> + Format.printf "Fatal internal error: %s\n%!" + (Printexc.to_string exn) ; + Pervasives.exit 1) + +(* Where all the user friendliness starts *) +let () = Lwt_main.run (main ()) diff --git a/src/compiler/.merlin b/src/compiler/.merlin new file mode 100644 index 000000000..6634308ed --- /dev/null +++ b/src/compiler/.merlin @@ -0,0 +1,2 @@ +REC +FLG -open Error_monad -open Hash -open Utils diff --git a/src/compiler/embedded_cmis.mli b/src/compiler/embedded_cmis.mli new file mode 100644 index 000000000..288657844 --- /dev/null +++ b/src/compiler/embedded_cmis.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val camlinternalFormatBasics_cmi: string +val error_monad_cmi: string +val error_monad_mli: string +val logging_mli: string +val proto_environment_cmi: string +val register_cmi: string diff --git a/src/compiler/node_compiler_main.ml b/src/compiler/node_compiler_main.ml new file mode 100644 index 000000000..5511ac940 --- /dev/null +++ b/src/compiler/node_compiler_main.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let compiler_name = "tezos-protocol-compiler" + +let () = + if Filename.basename Sys.argv.(0) = compiler_name then begin + try + Tezos_compiler.main (); + Pervasives.exit 0 + with exn -> + Format.eprintf "%a\n%!" Opterrors.report_error exn; + Pervasives.exit 1 + end diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml new file mode 100644 index 000000000..5ea8eb1ff --- /dev/null +++ b/src/compiler/tezos_compiler.ml @@ -0,0 +1,442 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** The OCaml compiler not being implemented with Lwt, the compilation + take place in a separated process (by using [Lwt_process.exec]). + + The [main] function is the entry point for the forked process. + While [Updater.compile] is the 'forking' function to be called by + the [tezos-node] process. + +*) + +(* GRGR TODO: fail in the presence of "external" *) + +module Backend = struct + (* See backend_intf.mli. *) + + let symbol_for_global' = Compilenv.symbol_for_global' + let closure_symbol = Compilenv.closure_symbol + + let really_import_approx = Import_approx.really_import_approx + let import_symbol = Import_approx.import_symbol + + let size_int = Arch.size_int + let big_endian = Arch.big_endian + + let max_sensible_number_of_arguments = + (* The "-1" is to allow for a potential closure environment parameter. *) + Proc.max_arguments_for_tailcalls - 1 +end +let backend = (module Backend : Backend_intf.S) + +let usage () = + Printf.eprintf + "Usage: %s output.cmxs source_dir [--in-place]\n%!" + Sys.argv.(0) + +let warnings = "+a-4-6-7-9-29-40..42-44-45-48" +let warn_error = "-a" + +let () = + Clflags.unsafe_string := false ; + Clflags.native_code := true + +(** Compilation environment. + + [tezos_protocol_env] defines the list of [cmi] available while compiling + the protocol version. The [cmi] are packed into the [tezos-node] + binary by using [ocp-ocamlres], see the Makefile. + + [register_env] defines a complementary list of [cmi] available + while compiling the generated [register.ml] file (that register + the protocol first-class module into the [Updater.versions] + hashtable). + + *) + +let tezos_protocol_env = + [ "camlinternalFormatBasics", Embedded_cmis.camlinternalFormatBasics_cmi ; + "proto_environment", Embedded_cmis.proto_environment_cmi ; + ] + +let register_env = + [ "register", Embedded_cmis.register_cmi ] + +(** Helpers *) + +let (//) = Filename.concat + +let create_file ?(perm = 0o644) name content = + let open Unix in + let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in + ignore(write_substring fd content 0 (String.length content)); + close fd + +let read_md5 file = + let ic = open_in file in + let md5 = input_line ic in + close_in ic ; + md5 + +let rec create_dir ?(perm = 0o755) dir = + if not (Sys.file_exists dir) then begin + create_dir (Filename.dirname dir); + Unix.mkdir dir perm + end + +let dump_cmi dir (file, content) = + create_file (dir // file ^ ".cmi") content + +let safe_unlink file = + try Unix.unlink file + with Unix.Unix_error(Unix.ENOENT, _, _) -> () + +let unlink_cmi dir (file, _) = + safe_unlink (dir // file ^ ".cmi") + +let unlink_object obj = + safe_unlink obj; + safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi"); + safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o") + + +(** TEZOS_PROTOCOL files *) + +module Meta = struct + + let hash_wrapper = + let open Config_file in + { to_raw = (fun h -> Raw.String (Protocol_hash.to_b48check h)); + of_raw = (function + | Raw.String h -> begin try + Protocol_hash.of_b48check h + with _ -> + let error oc = Printf.fprintf oc "Invalid Base48Check-encoded SHA256 key %S" h in + raise (Wrong_type error) + end + | _ -> + let error oc = + Printf.fprintf oc "Unexcepted value: should be a Base48Check-encoded SHA256 key." in + raise (Wrong_type error)); + } + + class protocol_hash_cp = + [Protocol_hash.t] Config_file.cp_custom_type hash_wrapper + + let to_file file hash modules = + let group = new Config_file.group in + let _ = new protocol_hash_cp ~group ["hash"] hash "" in + let _ = + new Config_file.list_cp Config_file.string_wrappers ~group + ["modules"] modules "" in + group#write file + + let of_file file = + let group = new Config_file.group in + let hash = + new protocol_hash_cp ~group ["hash"] + (Protocol_hash.of_b48check + "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr") + "" in + let modules = + new Config_file.list_cp Config_file.string_wrappers ~group + ["modules"] [] "" in + group#read file; + (hash#get, modules#get) + +end + +(** Semi-generic compilation functions *) + +let compile_mli ?(ctxt = "") ?(keep_object = false) target mli = + Printf.printf "OCAMLOPT%s %s\n%!" ctxt (Filename.basename target ^ ".cmi"); + Compenv.(readenv Format.err_formatter (Before_compile mli)) ; + Optcompile.interface Format.err_formatter mli target ; + if not keep_object then + at_exit (fun () -> safe_unlink (target ^ ".cmi")) + + +let compile_ml ?(ctxt = "") ?(keep_object = false) ?for_pack target ml = + Printf.printf "OCAMLOPT%s %s\n%!" ctxt (Filename.basename target ^ ".cmx") ; + Compenv.(readenv Format.err_formatter (Before_compile ml)); + Clflags.for_package := for_pack; + Optcompile.implementation + ~backend Format.err_formatter ml target; + Clflags.for_package := None; + if not keep_object then + at_exit (fun () -> unlink_object (target ^ ".cmx")) ; + target ^ ".cmx" + +let modification_date file = Unix.((stat file).st_mtime) + +let compile_units + ?ctxt + ?(update_needed = true) + ?keep_object ?for_pack ~source_dir ~build_dir units = + let compile_unit update_needed unit = + let basename = String.uncapitalize_ascii unit in + let mli = source_dir // basename ^ ".mli" in + let cmi = build_dir // basename ^ ".cmi" in + let ml = source_dir // basename ^ ".ml" in + let cmx = build_dir // basename ^ ".cmx" in + let target = build_dir // basename in + let update_needed = + update_needed + || not (Sys.file_exists cmi) + || ( Sys.file_exists mli + && modification_date cmi < modification_date mli ) + || not (Sys.file_exists cmx) + || modification_date cmx < modification_date ml in + if update_needed then begin + unlink_object cmx ; + if Sys.file_exists mli then compile_mli ?ctxt ?keep_object target mli ; + ignore (compile_ml ?ctxt ?keep_object ?for_pack target ml) + end ; + update_needed, cmx in + List.fold_left + (fun (update_needed, acc) unit-> + let update_needed, output = compile_unit update_needed unit in + update_needed, output :: acc) + (update_needed, []) units + |> snd |> List.rev + +let pack_objects ?(ctxt = "") ?(keep_object = false) output objects = + Printf.printf "PACK%s %s\n%!" ctxt (Filename.basename output); + Compmisc.init_path true; + Asmpackager.package_files + ~backend Format.err_formatter Env.initial_safe_string objects output; + if not keep_object then at_exit (fun () -> unlink_object output) ; + Warnings.check_fatal () + +let link_shared output objects = + Printf.printf "LINK %s\n%!" (Filename.basename output); + Compenv.(readenv Format.err_formatter Before_link); + Compmisc.init_path true; + if Filename.check_suffix output ".cmxa" then + Asmlibrarian.create_archive objects output + else + Asmlink.link_shared Format.err_formatter objects output; + Warnings.check_fatal () + +(** Main for the 'forked' compiler. + + It expect the following arguments: + + output.cmxs source_dir + + where, [source_dir] should contains a TEZOS_PROTOCOL file such as: + + hash = "69872d2940b7d11c9eabbc685115bd7867a94424" + modules = [Data; Main] + + The [source_dir] should also contains the corresponding source + file. For instance: [data.ml], [main.ml] and optionnaly [data.mli] + and [main.mli]. + + *) + +let create_register_file client file hash packname modules = + let unit = List.hd (List.rev modules) in + let error_monad = packname ^ ".Local_error_monad.Error_monad" in + create_file file + (Printf.sprintf + "module Packed_protocol = struct\n\ + \ let hash = (Hash.Protocol_hash.of_b48check %S)\n\ + \ type error = %s.error = ..\n\ + \ type 'a tzresult = 'a %s.tzresult\n\ + \ include %s.%s\n\ + \ let error_encoding = %s.error_encoding ()\n\ + \ let classify_errors = %s.classify_errors\n\ + \ let pp = %s.pp\n\ + \ end\n\ + \ %s\n\ + " + (Protocol_hash.to_b48check hash) + error_monad + error_monad + packname (String.capitalize_ascii unit) + error_monad + error_monad + error_monad + (if client then + "include Register.Make(Packed_protocol)" + else + "let () = Register.register (module Packed_protocol : PACKED_PROTOCOL)")) + +let mktemp_dir () = + Filename.get_temp_dir_name () // + Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF) + +let main () = + + Random.self_init () ; + Sodium.Random.stir () ; + + let anonymous = ref [] + and client = ref false + and build_dir = ref None + and include_dirs = ref [] in + let args_spec = [ + "--client", Arg.Set client, "TODO" ; + "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), "TODO" ; + "--build-dir", Arg.String (fun s -> build_dir := Some s), "TODO"] in + let usage_msg = "TODO" in + Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) "TODO" ; + + let client = !client and include_dirs = !include_dirs in + let output, source_dir = + match List.rev !anonymous with + | [ output ; source_dir ] -> output, source_dir + | _ -> Arg.usage args_spec usage_msg ; Pervasives.exit 1 in + if include_dirs <> [] && not client then begin + Arg.usage args_spec usage_msg ; Pervasives.exit 1 + end ; + + let keep_object, build_dir, sigs_dir = + match !build_dir with + | None -> + let build_dir = mktemp_dir () in + false, build_dir, build_dir // "sigs" + | Some build_dir -> + true, build_dir, mktemp_dir () in + create_dir build_dir ; + create_dir sigs_dir ; + at_exit (fun () -> + Unix.rmdir sigs_dir ; + if not keep_object then Unix.rmdir build_dir ) ; + + let hash, units = Meta.of_file (source_dir // "TEZOS_PROTOCOL") in + let packname = + if keep_object then + String.capitalize_ascii (Filename.(basename @@ chop_extension output)) + else + Format.asprintf "Protocol_%a" Protocol_hash.pp hash in + let packed_objects = + if keep_object then + Filename.dirname output // String.uncapitalize_ascii packname ^ ".cmx" + else + build_dir // packname ^ ".cmx" in + let ctxt = Printf.sprintf " (%s)" (Filename.basename output) in + let logname = + if keep_object then + try + Scanf.sscanf + Filename.(basename @@ chop_extension output) + "embedded_proto_%s" + (fun s -> "proto." ^ s) + with _ -> + Filename.(basename @@ chop_extension output) + else + Format.asprintf "proto.%a" Protocol_hash.pp hash in + + (* TODO proper error *) + assert (List.length units >= 1); + + (* Initialize the compilers *) + Compenv.(readenv Format.err_formatter Before_args); + if not client then Clflags.no_std_include := true; + Clflags.include_dirs := build_dir :: sigs_dir :: include_dirs; + Clflags.nopervasives := true; + Warnings.parse_options false warnings; + Warnings.parse_options true warn_error; + if keep_object then Clflags.binary_annotations := true; + + let md5 = + if not client then + Digest.(to_hex (file Sys.executable_name)) + else + try + let environment_cmi = + Misc.find_in_path_uncap !Clflags.include_dirs "environment.cmi" in + let environment_cmx = + Misc.find_in_path_uncap !Clflags.include_dirs "environment.cmx" in + Digest.(to_hex (file Sys.executable_name) ^ + (to_hex (file environment_cmi)) ^ + (to_hex (file environment_cmx))) + with Not_found -> + Printf.eprintf "%s: Cannot find 'environment.cmi'.\n%!" Sys.argv.(0); + Pervasives.exit 1 + in + let update_needed = + not (Sys.file_exists (build_dir // ".tezos_compiler")) + || read_md5 (build_dir // ".tezos_compiler") <> md5 in + + if keep_object then + create_file (build_dir // ".tezos_compiler") (md5 ^ "\n"); + + Compenv.implicit_modules := + if client then [ "Environment" ] else [ "Proto_environment" ] ; + + (* Compile the /ad-hoc/ Error_monad. *) + List.iter (dump_cmi sigs_dir) tezos_protocol_env ; + at_exit (fun () -> List.iter (unlink_cmi sigs_dir) tezos_protocol_env ) ; + let error_monad_unit = "local_error_monad" in + let error_monad_ml = build_dir // error_monad_unit ^ ".ml" in + create_file error_monad_ml @@ Printf.sprintf {| + module Error_monad = struct + type error_category = [ `Branch | `Temporary | `Permanent ] + include Error_monad.Make() + end + module Logging = Logging.Make(struct let name = %S end) + |} + logname ; + let error_monad_mli = build_dir // error_monad_unit ^ ".mli" in + create_file error_monad_mli @@ Printf.sprintf {| + module Error_monad : sig %s end + module Logging : sig %s end + |} + Embedded_cmis.error_monad_mli + Embedded_cmis.logging_mli ; + if not keep_object then + at_exit (fun () -> + safe_unlink error_monad_mli ; + safe_unlink error_monad_ml) ; + let error_monad_object = + compile_units + ~ctxt + ~for_pack:packname + ~keep_object + ~build_dir ~source_dir:build_dir [error_monad_unit] + in + + Compenv.implicit_modules := + !Compenv.implicit_modules @ + [ "Local_error_monad"; "Error_monad" ; "Hash" ; "Logging" ]; + + (* Compile the protocol *) + let objects = + compile_units + ~ctxt + ~update_needed + ~keep_object ~for_pack:packname ~build_dir ~source_dir units in + pack_objects ~ctxt ~keep_object + packed_objects (error_monad_object @ objects) ; + + (* Compiler the 'registering module' *) + List.iter (dump_cmi sigs_dir) register_env; + at_exit (fun () -> List.iter (unlink_cmi sigs_dir) register_env ) ; + let register_unit = + if client then + Filename.dirname output // + "register_" ^ + Filename.(basename @@ chop_extension output) + else + build_dir // Format.asprintf "register_%s" packname in + let register_file = register_unit ^ ".ml" in + create_register_file client register_file hash packname units ; + if not keep_object then at_exit (fun () -> safe_unlink register_file) ; + if keep_object then + Clflags.include_dirs := !Clflags.include_dirs @ [Filename.dirname output] ; + let register_object = + compile_ml ~keep_object:client (register_unit) register_file in + + (* Create the final [cmxs] *) + Clflags.link_everything := true ; + link_shared output [packed_objects; register_object] diff --git a/src/compiler/tezos_compiler.mli b/src/compiler/tezos_compiler.mli new file mode 100644 index 000000000..e2548ac2f --- /dev/null +++ b/src/compiler/tezos_compiler.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Low-level part of the [Updater]. *) + +module Meta : sig + + val to_file: string -> Protocol_hash.t -> string list -> unit + val of_file: string -> Protocol_hash.t * string list + +end + +val main: unit -> unit diff --git a/src/compiler_main.ml b/src/compiler_main.ml new file mode 100644 index 000000000..42ffd3ce2 --- /dev/null +++ b/src/compiler_main.ml @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let () = + try + Tezos_compiler.main (); + Pervasives.exit 0 + with exn -> + Format.eprintf "%a\n%!" Opterrors.report_error exn; + Pervasives.exit 1 diff --git a/src/node/.merlin b/src/node/.merlin new file mode 100644 index 000000000..6634308ed --- /dev/null +++ b/src/node/.merlin @@ -0,0 +1,2 @@ +REC +FLG -open Error_monad -open Hash -open Utils diff --git a/src/node/db/context.ml b/src/node/db/context.ml new file mode 100644 index 000000000..de16809f0 --- /dev/null +++ b/src/node/db/context.ml @@ -0,0 +1,327 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Versionned (key x value) store (over Irmin) *) + +open Logging.Db + +module IrminPath = Irmin.Path.String_list + +module rec S : sig + + module type STORE = sig + + include Irmin.S with type commit_id = Irmin.Hash.SHA1.t + and type key = IrminPath.t + and type value = MBytes.t + and type branch_id = string + + module FunView : sig + + type v + + val of_path: t -> IrminPath.t -> v Lwt.t + val update_path: t -> IrminPath.t -> v -> unit Lwt.t + + val mem: v -> IrminPath.t -> bool Lwt.t + val get: v -> IrminPath.t -> MBytes.t option Lwt.t + val set: v -> IrminPath.t -> MBytes.t-> v Lwt.t + val del: v -> IrminPath.t -> v Lwt.t + val list: v -> IrminPath.t list -> IrminPath.t list Lwt.t + val remove_rec: v -> IrminPath.t -> v Lwt.t + + end + val path : string + val local_repo : Repo.t + val patch_context : (module S.VIEW) -> (module S.VIEW) Lwt.t + end + + module type VIEW = sig + module Store : STORE + val s : Store.t + val v : Store.FunView.v + end + +end = struct + module type STORE = S.STORE + module type VIEW = S.VIEW +end + +include S + +let pack (type s) (type v) + (module S : STORE with type t = s and type FunView.v = v) (s : s) (v : v) = + (module struct + module Store = S + let s = s + let v = v + end : VIEW) + +type index = (module STORE) + +type store = (module VIEW) + +(*-- Version Access and Update -----------------------------------------------*) + +let genesis_block_key = ["genesis";"block"] +let genesis_protocol_key = ["genesis";"protocol"] +let genesis_time_key = ["genesis";"time"] +let current_protocol_key = ["protocol"] +let current_test_protocol_key = ["test_protocol"] +let current_test_network_key = ["test_network"] +let current_test_network_expiration_key = ["test_network_expiration"] +let current_fork_test_network_key = ["fork_test_network"] +let invalid_context_key = ["invalid_context"] + +let exists (module GitStore : STORE) key = + GitStore.of_branch_id + Irmin.Task.none (Block_hash.to_b48check key) GitStore.local_repo >>= fun t -> + let store = t () in + GitStore.read store genesis_block_key >>= function + | Some _ -> + Lwt.return true + | None -> + GitStore.read store invalid_context_key >>= function + | Some _ -> + Lwt.return true + | None -> + Lwt.return false + +let checkout ((module GitStore : STORE) as index) key = + lwt_debug "-> Context.checkout %a" + Block_hash.pp_short key >>= fun () -> + exists index key >>= fun exists -> + if not exists then + Lwt.return None + else + GitStore.of_branch_id + Irmin.Task.none (Block_hash.to_b48check key) GitStore.local_repo >>= fun t -> + let store = t () in + GitStore.FunView.of_path store [] >>= fun v -> + lwt_debug "<- Context.checkout %a OK" + Block_hash.pp_short key >>= fun () -> + GitStore.FunView.get v invalid_context_key >>= function + | None -> + GitStore.patch_context (pack (module GitStore) store v) >>= fun ctxt -> + Lwt.return (Some (Ok ctxt)) + | Some bytes -> + match Data_encoding.Json.from_string (MBytes.to_string bytes) with + | Ok (`A errors) -> + Lwt.return (Some (Error (List.map error_of_json errors))) + | Error _ | Ok _-> + Lwt.return (Some (generic_error (MBytes.to_string bytes))) + +exception Invalid_context of error list + +let checkout_exn index key = + checkout index key >>= function + | None -> Lwt.fail Not_found + | Some (Error error) -> Lwt.fail (Invalid_context error) + | Some (Ok p) -> Lwt.return p + +let exists ((module GitStore : STORE) as index) key = + lwt_debug "-> Context.exists %a" + Block_hash.pp_short key >>= fun () -> + exists index key >>= fun exists -> + lwt_debug "<- Context.exists %a %B" + Block_hash.pp_short key exists >>= fun () -> + Lwt.return exists + +exception Preexistent_context of string * Block_hash.t +exception Empty_head of string * Block_hash.t + +let commit (module GitStore : STORE) block key (module View : VIEW) = + let module GitStore = View.Store in + let task = + Irmin.Task.create + ~date:(Time.to_seconds block.Store.shell.timestamp) ~owner:"tezos" in + GitStore.clone task View.s (Block_hash.to_b48check key) >>= function + | `Empty_head -> Lwt.fail (Empty_head (GitStore.path, key)) + | `Duplicated_branch -> Lwt.fail (Preexistent_context (GitStore.path, key)) + | `Ok store -> + let msg = + Format.asprintf "%a %a" + Fitness.pp block.shell.fitness + Block_hash.pp_short key in + GitStore.FunView.update_path (store msg) [] View.v + +let commit_invalid (module GitStore : STORE) block key exns = + let task = + Irmin.Task.create + ~date:(Time.to_seconds block.Store.shell.timestamp) ~owner:"tezos" in + GitStore.of_branch_id + task (Block_hash.to_b48check key) GitStore.local_repo >>= fun t -> + let msg = + Format.asprintf "%a %a" + Fitness.pp block.shell.fitness + Block_hash.pp_short key in + let store = t msg in + GitStore.clone Irmin.Task.none store (Block_hash.to_b48check key) >>= function + | `Empty_head -> + GitStore.update store invalid_context_key + (MBytes.of_string @@ Data_encoding.Json.to_string @@ + `A (List.map json_of_error exns)) + | `Duplicated_branch | `Ok _ -> + Lwt.fail (Preexistent_context (GitStore.path, key)) + + +(*-- Generic Store Primitives ------------------------------------------------*) + +type t = store + +type key = string list + +let data_key key = "data" :: key +let undata_key = function + | "data" :: key -> key + | _ -> assert false + +let mem (module View : VIEW) key = + let module GitStore = View.Store in + GitStore.FunView.mem View.v (data_key key) >>= fun v -> + Lwt.return v + +let raw_get (module View : VIEW) key = + let module GitStore = View.Store in + GitStore.FunView.get View.v key >>= function + | None -> Lwt.return_none + | Some bytes -> Lwt.return (Some bytes) +let get t key = raw_get t (data_key key) + +let raw_set (module View : VIEW) key data = + let module GitStore = View.Store in + GitStore.FunView.set View.v key data >>= fun v -> + Lwt.return (pack (module GitStore) View.s v) +let set t key data = raw_set t (data_key key) data + +let raw_del (module View : VIEW) key = + let module GitStore = View.Store in + GitStore.FunView.del View.v key >>= fun v -> + Lwt.return (pack (module GitStore) View.s v) +let del t key = raw_del t (data_key key) + +let list (module View : VIEW) keys = + let module GitStore = View.Store in + GitStore.FunView.list View.v (List.map data_key keys) >>= fun v -> + Lwt.return (List.map undata_key v) + +let remove_rec (module View : VIEW) key = + let module GitStore = View.Store in + GitStore.FunView.remove_rec View.v (data_key key) >>= fun v -> + Lwt.return (pack (module GitStore) View.s v) + + + +(*-- Initialisation ----------------------------------------------------------*) + +let init ?patch_context ~root = + let module GitStore = + Irmin_unix.Irmin_git.FS + (Store.MBytesContent) (Irmin.Ref.String) (Irmin.Hash.SHA1) in + GitStore.Repo.create + (Irmin_unix.Irmin_git.config ~root ~bare:true ()) >>= fun local_repo -> + let module GitStoreView = Irmin.View (GitStore) in + let module ViewStore = struct + + let path = root + let local_repo = local_repo + let patch_context = + match patch_context with + | None -> (fun ctxt -> Lwt.return ctxt) + | Some patch_context -> patch_context + + include GitStore + + module FunView = struct + include Ir_funview.Make (GitStore) + type v = t + let get = read + let del = remove + let set = update + let list v k = Lwt_list.map_p (list v) k >|= List.flatten + end + end in + Lwt.return (module ViewStore : STORE) + +let create_genesis_context (module GitStore : STORE) genesis test_protocol = + GitStore.of_branch_id + Irmin.Task.none (Block_hash.to_b48check genesis.Store.block) + GitStore.local_repo >>= fun t -> + let store = t () in + GitStore.FunView.of_path store [] >>= fun v -> + GitStore.FunView.set v genesis_block_key + (Block_hash.to_bytes genesis.block) >>= fun v -> + GitStore.FunView.set v genesis_protocol_key + (Protocol_hash.to_bytes genesis.protocol) >>= fun v -> + GitStore.FunView.set v genesis_time_key + (MBytes.of_string (Time.to_notation genesis.time)) >>= fun v -> + GitStore.FunView.set v current_protocol_key + (Protocol_hash.to_bytes genesis.protocol) >>= fun v -> + GitStore.FunView.set v current_test_protocol_key + (Protocol_hash.to_bytes test_protocol) >>= fun v -> + let ctxt = pack (module GitStore) store v in + GitStore.patch_context ctxt >>= fun ctxt -> + let (module View : VIEW) = ctxt in + View.Store.FunView.update_path View.s [] View.v >>= fun () -> + Lwt.return ctxt + +(*-- Predefined Fields -------------------------------------------------------*) + +let get_protocol v = + raw_get v current_protocol_key >>= function + | None -> assert false + | Some data -> Lwt.return (Protocol_hash.of_bytes data) +let set_protocol v key = + raw_set v current_protocol_key (Protocol_hash.to_bytes key) + +let get_test_protocol v = + raw_get v current_test_protocol_key >>= function + | None -> assert false + | Some data -> Lwt.return (Protocol_hash.of_bytes data) +let set_test_protocol v data = + raw_set v current_test_protocol_key (Protocol_hash.to_bytes data) + +let get_test_network v = + raw_get v current_test_network_key >>= function + | None -> Lwt.return_none + | Some data -> Lwt.return (Some (Store.Net (Block_hash.of_bytes data))) +let set_test_network v (Store.Net data) = + raw_set v current_test_network_key (Block_hash.to_bytes data) +let del_test_network v = raw_del v current_test_network_key + +let get_test_network_expiration v = + raw_get v current_test_network_expiration_key >>= function + | None -> Lwt.return_none + | Some data -> Lwt.return (Time.of_notation @@ MBytes.to_string data) +let set_test_network_expiration v data = + raw_set v current_test_network_expiration_key + (MBytes.of_string @@ Time.to_notation data) +let del_test_network_expiration v = + raw_del v current_test_network_expiration_key + +let read_and_reset_fork_test_network v = + raw_get v current_fork_test_network_key >>= function + | None -> Lwt.return (false, v) + | Some _ -> + raw_del v current_fork_test_network_key >>= fun v -> + Lwt.return (true, v) + +let fork_test_network v = + raw_set v current_fork_test_network_key (MBytes.of_string "fork") + +let get_genesis_block v = + raw_get v genesis_block_key >>= function + | None -> assert false + | Some block -> Lwt.return (Block_hash.of_bytes block) + +let get_genesis_time v = + raw_get v genesis_time_key >>= function + | None -> assert false + | Some time -> Lwt.return (Time.of_notation_exn (MBytes.to_string time)) + diff --git a/src/node/db/context.mli b/src/node/db/context.mli new file mode 100644 index 000000000..3f1523ab3 --- /dev/null +++ b/src/node/db/context.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Versionned, block indexed (key x value) store *) + +(** A block-indexed (key x value) store directory. *) +type index + +(** A (key x value) store for a given block. *) +type store + +(** Open or initialize a versionned store at a given path. *) +val init: + ?patch_context:(store -> store Lwt.t) -> + root:string -> + index Lwt.t + +val create_genesis_context: + index -> Store.genesis -> Protocol_hash.t -> store Lwt.t + +(** {2 Generic interface} ****************************************************) + +include Persist.STORE with type t = store + +(** {2 Accessing and Updating Versions} **************************************) + +exception Preexistent_context of string * Block_hash.t +val exists: index -> Block_hash.t -> bool Lwt.t +val commit: index -> Store.block_header -> Block_hash.t -> store -> unit Lwt.t +val commit_invalid: + index -> Store.block_header -> Block_hash.t -> error list -> unit Lwt.t +val checkout: index -> Block_hash.t -> store tzresult option Lwt.t +exception Invalid_context of error list +val checkout_exn: index -> Block_hash.t -> store Lwt.t + +(** {2 Predefined Fields} ****************************************************) + +val get_protocol: store -> Protocol_hash.t Lwt.t +val set_protocol: store -> Protocol_hash.t -> store Lwt.t + +val get_test_protocol: store -> Protocol_hash.t Lwt.t +val set_test_protocol: store -> Protocol_hash.t -> store Lwt.t + +val get_test_network: store -> Store.net_id option Lwt.t +val set_test_network: store -> Store.net_id -> store Lwt.t +val del_test_network: store -> store Lwt.t + +val get_test_network_expiration: store -> Time.t option Lwt.t +val set_test_network_expiration: store -> Time.t -> store Lwt.t +val del_test_network_expiration: store -> store Lwt.t + +val read_and_reset_fork_test_network: store -> (bool * store) Lwt.t +val fork_test_network: store -> store Lwt.t + +val get_genesis_time: store -> Time.t Lwt.t +val get_genesis_block: store -> Block_hash.t Lwt.t diff --git a/src/node/db/db_proxy.ml b/src/node/db/db_proxy.ml new file mode 100644 index 000000000..2777256e6 --- /dev/null +++ b/src/node/db/db_proxy.ml @@ -0,0 +1,108 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type DISTRIBUTED_DB = sig + type t + type state + type store + type key + type value + val create: state -> store Persist.shared_ref -> t + val known: t -> key -> bool Lwt.t + val read: t -> key -> value option Lwt.t + val prefetch: t -> Store.net_id -> key -> unit + val fetch: t -> Store.net_id -> key -> value Lwt.t + val pending: t -> key -> bool + val store: t -> key -> value -> bool Lwt.t + val update: t -> key -> value -> bool Lwt.t + val remove: t -> key -> bool Lwt.t + val shutdown: t -> unit Lwt.t +end + +type operation_state = { + request_operations: Store.net_id -> Operation_hash.t list -> unit ; +} + +module Operation_scheduler = struct + let name = "operation_scheduler" + type rdata = Store.net_id + type data = float ref + type state = operation_state + let init_request _ _ = Lwt.return (ref 0.0) + let request net ~get:_ ~set:_ pendings = + let current_time = Unix.gettimeofday () in + let time = current_time -. (3. +. Random.float 8.) in + let operations = + List.fold_left + (fun acc (hash, last_request, Store.Net net_id) -> + if !last_request < time then begin + last_request := current_time ; + let prev = + try Block_hash_map.find net_id acc + with Not_found -> [] in + Block_hash_map.add net_id (hash :: prev) acc + end else + acc) + Block_hash_map.empty + pendings in + if Block_hash_map.is_empty operations then + 0. + else begin + Block_hash_map.iter + (fun net_id -> net.request_operations (Net net_id)) + operations ; + 1. +. Random.float 4. + end +end + +module Operation = + Persist.MakeImperativeProxy + (Store.Faked_functional_operation) + (Operation_hash_table) (Operation_scheduler) + +type block_state = { + request_blocks: Store.net_id -> Block_hash.t list -> unit ; +} + +module Block_scheduler = struct + let name = "block_scheduler" + type rdata = Store.net_id + type data = float ref + type state = block_state + let init_request _ _ = Lwt.return (ref 0.0) + let request net ~get:_ ~set:_ pendings = + let current_time = Unix.gettimeofday () in + let limit = current_time -. (3. +. Random.float 8.) in + let blocks = + List.fold_left + (fun acc (hash, last_request, Store.Net net_id) -> + if !last_request < limit then begin + last_request := current_time ; + let prev = + try Block_hash_map.find net_id acc + with Not_found -> [] in + Block_hash_map.add net_id (hash :: prev) acc + end else + acc) + Block_hash_map.empty + pendings in + if Block_hash_map.is_empty blocks then + 0. + else begin + Block_hash_map.iter + (fun net_id -> net.request_blocks (Net net_id)) + blocks ; + 1. +. Random.float 4. + end +end + +module Block = + Persist.MakeImperativeProxy + (Store.Faked_functional_block) + (Block_hash_table) (Block_scheduler) diff --git a/src/node/db/db_proxy.mli b/src/node/db/db_proxy.mli new file mode 100644 index 000000000..9370a1754 --- /dev/null +++ b/src/node/db/db_proxy.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type DISTRIBUTED_DB = sig + type t + type state + type store + type key + type value + val create: state -> store Persist.shared_ref -> t + val known: t -> key -> bool Lwt.t + val read: t -> key -> value option Lwt.t + val prefetch: t -> Store.net_id -> key -> unit + val fetch: t -> Store.net_id -> key -> value Lwt.t + val pending: t -> key -> bool + val store: t -> key -> value -> bool Lwt.t + val update: t -> key -> value -> bool Lwt.t + val remove: t -> key -> bool Lwt.t + val shutdown: t -> unit Lwt.t +end + +type operation_state = { + request_operations: Store.net_id -> Operation_hash.t list -> unit ; +} + +module Operation : + DISTRIBUTED_DB with type store := Store.Operation.t + and type key := Store.Operation.key + and type value := Store.Operation.value + and type state := operation_state + +type block_state = { + request_blocks: Store.net_id -> Block_hash.t list -> unit ; +} + +module Block : + DISTRIBUTED_DB with type store := Store.Block.t + and type key := Store.Block.key + and type value := Store.Block.value + and type state := block_state diff --git a/src/node/db/ir_funview.ml b/src/node/db/ir_funview.ml new file mode 100644 index 000000000..acaf941b3 --- /dev/null +++ b/src/node/db/ir_funview.ml @@ -0,0 +1,673 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* + * Copyright (c) 2013-2015 Thomas Gazagnaire + * Copyright (c) 2016 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Infix + +(* Import Ir_hum.S *) +module type Hum = sig + include Tc.S0 + val to_hum: t -> string + val of_hum: string -> t +end + + +(***** views *) + +module type NODE = sig + type t + type node + type contents + module Contents: Tc.S0 with type t = contents + module Path : sig + (* Import Ir_S.PATH *) + include Hum + type step + val empty: t + val create: step list -> t + val is_empty: t -> bool + val cons: step -> t -> t + val rcons: t -> step -> t + val decons: t -> (step * t) option + val rdecons: t -> (t * step) option + val map: t -> (step -> 'a) -> 'a list + module Step: Hum with type t = step + end + + val empty: unit -> t + val is_empty: t -> bool Lwt.t + + val read: t -> node option Lwt.t + + val read_contents: t -> Path.step -> contents option Lwt.t + + val with_contents: t -> Path.step -> contents option -> t option Lwt.t + (* Return [true] iff the contents has actually changed. Used for + invalidating the view cache if needed. *) + + val read_succ: node -> Path.step -> t option + + val with_succ: t -> Path.step -> t option -> t option Lwt.t + (* Return [true] iff the successors has actually changes. Used for + invalidating the view cache if needed. *) + + val steps: t -> Path.step list Lwt.t +end + +module Ir_misc = struct + module Set (K: Tc.S0) = struct + + include Set.Make(K) + + let of_list l = + List.fold_left (fun set elt -> add elt set) empty l + + let to_list = elements + + include Tc.As_L0(struct + type u = t + type t = u + module K = K + let to_list = to_list + let of_list = of_list + end) + end + (* assume l1 and l2 are key-sorted *) + let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = match l1, l2 with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1,v1)::t1, (k2,v2)::t2 -> + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + aux t1 t2 + | x -> if x < 0 then ( + f k1 (`Left v1); + aux t1 l2 + ) else ( + f k2 (`Right v2); + aux l1 t2 + ) + in + aux l1 l2 + module Map_ext (M: Map.S) (K: Tc.S0 with type t = M.key) = struct + + include M + + let keys m = + List.map fst (bindings m) + + let of_alist l = + List.fold_left (fun map (k, v) -> add k v map) empty l + + let to_alist = bindings + + let add_multi key data t = + try + let l = find key t in + add key (data :: l) t + with Not_found -> + add key [data] t + + let iter2 f t1 t2 = + alist_iter2 K.compare f (bindings t1) (bindings t2) + + module Lwt = struct + open Lwt + + let iter2 f m1 m2 = + let m3 = ref [] in + iter2 (fun key data -> + m3 := f key data :: !m3 + ) m1 m2; + Lwt_list.iter_p + (fun b -> b >>= fun () -> return_unit) (List.rev !m3) + + let merge f m1 m2 = + let l3 = ref [] in + let f key data = + f key data >>= function + | None -> return_unit + | Some v -> l3 := (key, v) :: !l3; return_unit + in + iter2 f m1 m2 >>= fun () -> + let m3 = of_alist !l3 in + return m3 + + end + + include Tc.As_AL1(struct + type 'a r = 'a t + type 'a t = 'a r + module K = K + let of_alist = of_alist + let to_alist = to_alist + end) + end + module Map (S: Tc.S0) = Map_ext (Map.Make(S))(S) + +end + +module Make (S: Irmin.S) = struct + + module P = S.Private + module Path = S.Key + module PathSet = Ir_misc.Set(Path) + + module Step = Path.Step + module StepMap = Ir_misc.Map(Path.Step) + module StepSet = Ir_misc.Set(Path.Step) + + module Contents = struct + + type key = S.Repo.t * S.Private.Contents.key + + type contents_or_key = + | Key of key + | Contents of S.value + | Both of key * S.value + + type t = contents_or_key ref + (* Same as [Contents.t] but can either be a raw contents or a key + that will be fetched lazily. *) + + let create c = + ref (Contents c) + + let export c = + match !c with + | Both ((_, k), _) + | Key (_, k) -> k + | Contents _ -> Pervasives.failwith "Contents.export" + + let key db k = + ref (Key (db, k)) + + let read t = + match !t with + | Both (_, c) + | Contents c -> Lwt.return (Some c) + | Key (db, k as key) -> + P.Contents.read (P.Repo.contents_t db) k >>= function + | None -> Lwt.return_none + | Some c -> + t := Both (key, c); + Lwt.return (Some c) + + let equal (x:t) (y:t) = + x == y + || + match !x, !y with + | (Key (_,x) | Both ((_,x),_)), (Key (_,y) | Both ((_,y),_)) -> + P.Contents.Key.equal x y + | (Contents x | Both (_, x)), (Contents y | Both (_, y)) -> + P.Contents.Val.equal x y + | _ -> false + + end + + module Node = struct + + type contents = S.value + type key = S.Repo.t * P.Node.key + + type node = { + contents: Contents.t StepMap.t; + succ : t StepMap.t; + alist : (Path.step * [`Contents of Contents.t | `Node of t ]) list Lazy.t; + } + + and t = { + mutable node: node option ; + mutable key: key option ; + } + + let rec equal (x:t) (y:t) = + match x, y with + | { key = Some (_,x) ; _ }, { key = Some (_,y) ; _ } -> + P.Node.Key.equal x y + | { node = Some x ; _ }, { node = Some y ; _ } -> + List.length (Lazy.force x.alist) = List.length (Lazy.force y.alist) + && List.for_all2 (fun (s1, n1) (s2, n2) -> + Step.equal s1 s2 + && match n1, n2 with + | `Contents n1, `Contents n2 -> Contents.equal n1 n2 + | `Node n1, `Node n2 -> equal n1 n2 + | _ -> false) (Lazy.force x.alist) (Lazy.force y.alist) + | _ -> false + + let mk_alist contents succ = + lazy ( + StepMap.fold + (fun step c acc -> (step, `Contents c) :: acc) + contents @@ + StepMap.fold + (fun step c acc -> (step, `Node c) :: acc) + succ + []) + let mk_index alist = + List.fold_left (fun (contents, succ) (l, x) -> + match x with + | `Contents c -> StepMap.add l c contents, succ + | `Node n -> contents, StepMap.add l n succ + ) (StepMap.empty, StepMap.empty) alist + + let create_node contents succ = + let alist = mk_alist contents succ in + { contents; succ; alist } + + let create contents succ = + { key = None ; node = Some (create_node contents succ) } + + let key db k = + { key = Some (db, k) ; node = None } + + let both db k v = + { key = Some (db, k) ; node = Some v } + + let empty () = create StepMap.empty StepMap.empty + + let import t n = + let alist = P.Node.Val.alist n in + let alist = List.map (fun (l, x) -> + match x with + | `Contents (c, _meta) -> (l, `Contents (Contents.key t c)) + | `Node n -> (l, `Node (key t n)) + ) alist in + let contents, succ = mk_index alist in + create_node contents succ + + let export n = + match n.key with + | Some (_, k) -> k + | None -> Pervasives.failwith "Node.export" + + let export_node n = + let alist = List.map (fun (l, x) -> + match x with + | `Contents c -> (l, `Contents (Contents.export c, + P.Node.Val.Metadata.default)) + | `Node n -> (l, `Node (export n)) + ) (Lazy.force n.alist) + in + P.Node.Val.create alist + + let read t = + match t with + | { key = None ; node = None } -> assert false + | { node = Some n ; _ } -> Lwt.return (Some n) + | { key = Some (db, k) ; _ } -> + P.Node.read (P.Repo.node_t db) k >>= function + | None -> Lwt.return_none + | Some n -> + let n = import db n in + t.node <- Some n; + Lwt.return (Some n) + + let is_empty t = + read t >>= function + | None -> Lwt.return false + | Some n -> Lwt.return (Lazy.force n.alist = []) + + let steps t = + read t >>= function + | None -> Lwt.return_nil + | Some n -> + let steps = ref StepSet.empty in + List.iter + (fun (l, _) -> steps := StepSet.add l !steps) + (Lazy.force n.alist); + Lwt.return (StepSet.to_list !steps) + + let read_contents t step = + read t >>= function + | None -> Lwt.return_none + | Some t -> + try + StepMap.find step t.contents + |> Contents.read + with Not_found -> + Lwt.return_none + + let read_succ t step = + try Some (StepMap.find step t.succ) + with Not_found -> None + + let with_contents t step contents = + read t >>= function + | None -> begin + match contents with + | None -> Lwt.return_none + | Some c -> + let contents = StepMap.singleton step (Contents.create c) in + Lwt.return (Some (create contents StepMap.empty)) + end + | Some n -> begin + match contents with + | None -> + if StepMap.mem step n.contents then + let contents = StepMap.remove step n.contents in + Lwt.return (Some (create contents n.succ)) + else + Lwt.return_none + | Some c -> + try + let previous = StepMap.find step n.contents in + if not (Contents.equal (Contents.create c) previous) then + raise Not_found; + Lwt.return_none + with Not_found -> + let contents = + StepMap.add step (Contents.create c) n.contents in + Lwt.return (Some (create contents n.succ)) + end + + let with_succ t step succ = + read t >>= function + | None -> begin + match succ with + | None -> Lwt.return_none + | Some c -> + let succ = StepMap.singleton step c in + Lwt.return (Some (create StepMap.empty succ)) + end + | Some n -> begin + match succ with + | None -> + if StepMap.mem step n.succ then + let succ = StepMap.remove step n.succ in + Lwt.return (Some (create n.contents succ)) + else + Lwt.return_none + | Some c -> + try + let previous = StepMap.find step n.succ in + if c != previous then raise Not_found; + Lwt.return_none + with Not_found -> + let succ = StepMap.add step c n.succ in + Lwt.return (Some (create n.contents succ)) + end + + end + + type key = Path.t + type value = Node.contents + + type t = [`Empty | `Node of Node.t | `Contents of Node.contents] + + module CO = Tc.Option(P.Contents.Val) + module PL = Tc.List(Path) + + let empty = `Empty + + let sub t path = + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (Some node) + | Some (h, p) -> + Node.read node >>= function + | None -> Lwt.return_none + | Some t -> + match Node.read_succ t h with + | None -> Lwt.return_none + | Some v -> aux v p + in + match t with + | `Empty -> Lwt.return_none + | `Node n -> aux n path + | `Contents _ -> Lwt.return_none + + let read_contents t path = + match t, Path.rdecons path with + | `Contents c, None -> Lwt.return (Some c) + | _ , None -> Lwt.return_none + | _ , Some (path, file) -> + sub t path >>= function + | None -> Lwt.return_none + | Some n -> Node.read_contents n file + + let read t k = read_contents t k + + let err_not_found n k = + Printf.ksprintf + invalid_arg "Irmin.View.%s: %s not found" n (Path.to_hum k) + + let read_exn t k = + read t k >>= function + | None -> err_not_found "read" k + | Some v -> Lwt.return v + + let mem t k = + read t k >>= function + | None -> Lwt.return false + | _ -> Lwt.return true + + let list_aux t path = + sub t path >>= function + | None -> Lwt.return [] + | Some n -> + Node.steps n >>= fun steps -> + let paths = + List.fold_left (fun set p -> + PathSet.add (Path.rcons path p) set + ) PathSet.empty steps + in + Lwt.return (PathSet.to_list paths) + + let list t path = + list_aux t path + + let iter t fn = + let rec aux = function + | [] -> Lwt.return_unit + | path::tl -> + list t path >>= fun childs -> + let todo = childs @ tl in + mem t path >>= fun exists -> + begin + if not exists then Lwt.return_unit + else fn path (fun () -> read_exn t path) + end >>= fun () -> + aux todo + in + list t Path.empty >>= aux + + let update_contents_aux t k v = + match Path.rdecons k with + | None -> begin + match t, v with + | `Empty, None -> Lwt.return t + | `Contents c, Some v when P.Contents.Val.equal c v -> Lwt.return t + | _, None -> Lwt.return `Empty + | _, Some c -> Lwt.return (`Contents c) + end + | Some (path, file) -> + let rec aux view path = + match Path.decons path with + | None -> Node.with_contents view file v + | Some (h, p) -> + Node.read view >>= function + | None -> + if v = None then Lwt.return_none + else err_not_found "update_contents" k (* XXX ?*) + | Some n -> + match Node.read_succ n h with + | Some child -> begin + aux child p >>= function + | None -> Lwt.return_none + | Some child -> begin + if v = None then + (* remove empty dirs *) + Node.is_empty child >>= function + | true -> Lwt.return_none + | false -> Lwt.return (Some child) + else + Lwt.return (Some child) + end >>= fun child -> + Node.with_succ view h child + end + | None -> + if v = None then + Lwt.return_none + else + aux (Node.empty ()) p >>= function + | None -> assert false + | Some _ as child -> Node.with_succ view h child + in + let n = match t with `Node n -> n | _ -> Node.empty () in + aux n path >>= function + | None -> Lwt.return t + | Some node -> + Node.is_empty node >>= function + | true -> Lwt.return `Empty + | false -> Lwt.return (`Node node) + + let update_contents t k v = + update_contents_aux t k v + + let update t k v = update_contents t k (Some v) + + let remove t k = update_contents t k None + + let remove_rec t k = + match Path.decons k with + | None -> Lwt.return t + | _ -> + match t with + | `Contents _ -> Lwt.return `Empty + | `Empty -> Lwt.return t + | `Node n -> + let rec aux view path = + match Path.decons path with + | None -> assert false + | Some (h,p) -> + if Path.is_empty p then + Node.with_succ view h None + else + Node.read view >>= function + | None -> Lwt.return_none + | Some n -> + match Node.read_succ n h with + | None -> Lwt.return_none + | Some child -> aux child p + in + aux n k >>= function + | None -> Lwt.return t + | Some node -> + Node.is_empty node >>= function + | true -> Lwt.return `Empty + | false -> Lwt.return (`Node node) + + type db = S.t + + let import db key = + let repo = S.repo db in + begin P.Node.read (P.Repo.node_t repo) key >|= function + | None -> `Empty + | Some n -> `Node (Node.both repo key (Node.import repo n)) + end + + let export repo t = + let node n = P.Node.add (P.Repo.node_t repo) (Node.export_node n) in + let todo = Stack.create () in + let rec add_to_todo n = + match n with + | { Node.key = Some _ ; _ } -> () + | { Node.key = None ; node = None } -> assert false + | { Node.key = None ; node = Some x } -> + (* 1. we push the current node job on the stack. *) + Stack.push (fun () -> + node x >>= fun k -> + n.Node.key <- Some (repo, k); + n.Node.node <- None; (* Clear cache ?? *) + Lwt.return_unit + ) todo; + (* 2. we push the contents job on the stack. *) + List.iter (fun (_, x) -> + match x with + | `Node _ -> () + | `Contents c -> + match !c with + | Contents.Both _ + | Contents.Key _ -> () + | Contents.Contents x -> + Stack.push (fun () -> + P.Contents.add (P.Repo.contents_t repo) x >>= fun k -> + c := Contents.Key (repo, k); + Lwt.return_unit + ) todo + ) (Lazy.force x.Node.alist); + (* 3. we push the children jobs on the stack. *) + List.iter (fun (_, x) -> + match x with + | `Contents _ -> () + | `Node n -> + Stack.push (fun () -> add_to_todo n; Lwt.return_unit) todo + ) (Lazy.force x.Node.alist); + in + let rec loop () = + let task = + try Some (Stack.pop todo) + with Stack.Empty -> None + in + match task with + | None -> Lwt.return_unit + | Some t -> t () >>= loop + in + match t with + | `Empty -> Lwt.return `Empty + | `Contents c -> Lwt.return (`Contents c) + | `Node n -> + add_to_todo n; + loop () >|= fun () -> + `Node (Node.export n) + + let of_path db path = + P.read_node db path >>= function + | None -> Lwt.return `Empty + | Some n -> import db n + + let update_path db path view = + let repo = S.repo db in + export repo view >>= function + | `Empty -> P.remove_node db path + | `Contents c -> S.update db path c + | `Node node -> P.update_node db path node + +end + +module type S = sig + include Irmin.RO + val update: t -> key -> value -> t Lwt.t + val remove: t -> key -> t Lwt.t + val list: t -> key -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t + val empty: t + type db + val of_path: db -> key -> t Lwt.t + val update_path: db -> key -> t -> unit Lwt.t +end diff --git a/src/node/db/ir_funview.mli b/src/node/db/ir_funview.mli new file mode 100644 index 000000000..bdf1671cb --- /dev/null +++ b/src/node/db/ir_funview.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type S = sig + include Irmin.RO + val update: t -> key -> value -> t Lwt.t + val remove: t -> key -> t Lwt.t + val list: t -> key -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t + val empty: t + type db + val of_path: db -> key -> t Lwt.t + val update_path: db -> key -> t -> unit Lwt.t +end + +module Make (S: Irmin.S): + S with type db = S.t + and type key = S.key + and type value = S.value diff --git a/src/node/db/persist.ml b/src/node/db/persist.ml new file mode 100644 index 000000000..43811d6ab --- /dev/null +++ b/src/node/db/persist.ml @@ -0,0 +1,571 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos - Persistent structures on top of {!Store} or {!Context} *) + +open Lwt + +(*-- Signatures --------------------------------------------------------------*) + +type key = string list +type value = MBytes.t + +module type STORE = sig + type t + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +module type BYTES_STORE = sig + type t + type key + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +module type TYPED_STORE = sig + type t + type key + type value + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t +end + +module type KEY = sig + type t + val prefix: key + val length: int + val to_path: t -> key + val of_path: key -> t + val compare: t -> t -> int +end + +module type VALUE = sig + type t + val of_bytes: value -> t option + val to_bytes: t -> value +end + +module type PERSISTENT_SET = sig + type t and key + val mem : t -> key -> bool Lwt.t + val set : t -> key -> t Lwt.t + val del : t -> key -> t Lwt.t + val elements : t -> key list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +module type BUFFERED_PERSISTENT_SET = sig + include PERSISTENT_SET + module Set : Set.S with type elt = key + val read : t -> Set.t Lwt.t + val write : t -> Set.t -> t Lwt.t +end + +module type PERSISTENT_MAP = sig + type t and key and value + val mem : t -> key -> bool Lwt.t + val get : t -> key -> value option Lwt.t + val set : t -> key -> value -> t Lwt.t + val del : t -> key -> t Lwt.t + val bindings : t -> (key * value) list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +module type BUFFERED_PERSISTENT_MAP = sig + include PERSISTENT_MAP + module Map : Map.S with type key = key + val read : t -> value Map.t Lwt.t + val write : t -> value Map.t -> t Lwt.t +end + +(*-- Utils -------------------------------------------------------------------*) + +let prefix prf key = + prf @ key + +let unprefix prf key = + let rec eat = function + | k :: key, p :: prefix -> + assert (k = p) ; + eat (key, prefix) + | key, [] -> key + | _ -> assert false in + eat (key, prf) + +(*-- Typed Store Overlays ----------------------------------------------------*) + +module MakeBytesStore + (S : STORE) (K : KEY) = struct + + type t = S.t + type key = K.t + type value = MBytes.t + + let to_path k = + let suffix = K.to_path k in + prefix K.prefix suffix + let of_path k = K.of_path (unprefix K.prefix k) + + let mem s k = + S.mem s (to_path k) + + let get s k = + S.get s (to_path k) + + let set s k v = + S.set s (to_path k) v + + let del s k = + S.del s (to_path k) + + let list s l = + S.list s (List.map to_path l) >>= fun res -> + return (List.map of_path res) + + let remove_rec s k = + S.remove_rec s (to_path k) + +end + +module MakeTypedStore + (S : STORE) (K : KEY) (C : VALUE) = struct + + type t = S.t + type key = K.t + type value = C.t + + module S = MakeBytesStore (S) (K) + + let mem = S.mem + let get s k = + S.get s k >>= function + | None -> return None + | Some v -> return (C.of_bytes v) + let set s k v = S.set s k (C.to_bytes v) + let del = S.del + + let raw_get = S.get + +end + +module RawKey = struct + type t = key + let prefix = [] + let length = 0 + let to_path p = p + let of_path p = p + let compare pa pb = Pervasives.compare pa pb +end +module RawValue = struct + type t = value + let to_bytes b = b + let of_bytes b = Some b +end + +(*-- Set Builders ------------------------------------------------------------*) + +module MakePersistentSet + (S : STORE) (K : KEY) = struct + + let to_path k = + let suffix = K.to_path k in + assert (List.length suffix = K.length) ; + prefix K.prefix suffix + + let of_path p = K.of_path (unprefix K.prefix p) + + let empty = + MBytes.of_string "" + + let inited_key = + prefix K.prefix [ "inited" ] + + let mem c k = + S.mem c (to_path k) + + let set c k = + S.set c inited_key empty >>= fun c -> + S.set c (to_path k) empty + + let del c k = + S.del c (to_path k) + + let clear c = + S.remove_rec c K.prefix + + let fold c x ~f = + let rec dig i root acc = + if root = inited_key then + Lwt.return acc + else if i <= 0 then + f (of_path root) acc + else + S.list c [root] >>= fun roots -> + Lwt_list.fold_right_s (dig (i - 1)) roots acc in + S.mem c inited_key >>= function + | true -> dig K.length K.prefix x + | false -> Lwt.return x + + let iter c ~f = fold c () (fun x () -> f x) + let elements c = fold c [] (fun p xs -> Lwt.return (p :: xs)) + +end + +module MakeBufferedPersistentSet + (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) = struct + + include MakePersistentSet(S)(K) + + let read c = + fold c Set.empty (fun p set -> Lwt.return (Set.add p set)) + + let write c set = + S.set c inited_key empty >>= fun c -> + read c >>= fun old_set -> + Lwt_list.fold_left_s + (fun c h -> S.del c (to_path h)) + c Set.(elements (diff old_set set)) >>= fun c -> + Lwt_list.fold_left_s + (fun c h -> S.set c (to_path h) empty) + c Set.(elements (diff set old_set)) + +end + +(*-- Map Builders ------------------------------------------------------------*) + +module MakePersistentMap + (S : STORE) (K : KEY) (C : VALUE) = struct + + let to_path k = + let suffix = K.to_path k in + assert (List.length suffix = K.length) ; + prefix K.prefix suffix + + let of_path p = K.of_path (unprefix K.prefix p) + + let empty = + MBytes.of_string "" + + let inited_key = + prefix K.prefix [ "inited" ] + + let mem c k = + S.mem c (to_path k) + + let get c k = + S.get c (to_path k) >|= function + | None -> None + | Some b -> C.of_bytes b + + let set c k b = + S.set c inited_key empty >>= fun c -> + S.set c (to_path k) (C.to_bytes b) + + let del c k = + S.del c (to_path k) + + let clear c = + S.remove_rec c K.prefix + + let fold c x ~f = + let rec dig i root acc = + if root = inited_key then + Lwt.return acc + else if i <= 0 then + S.get c root >>= function + | None -> Lwt.return acc + | Some b -> + match C.of_bytes b with + | None -> Lwt.return acc + | Some v -> f (of_path root) v acc + else + S.list c [root] >>= fun roots -> + Lwt_list.fold_right_s (dig (i - 1)) roots acc in + S.mem c inited_key >>= function + | true -> dig K.length K.prefix x + | false -> Lwt.return x + + let iter c ~f = fold c () (fun k v () -> f k v) + let bindings c = fold c [] (fun k v acc -> Lwt.return ((k, v) :: acc)) + +end + +module MakeBufferedPersistentMap + (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) = struct + + include MakePersistentMap(S)(K)(C) + + let read c = fold c Map.empty (fun k v m -> Lwt.return (Map.add k v m)) + + let write c m = + clear c >>= fun c -> + S.set c inited_key empty >>= fun c -> + Lwt_list.fold_left_s + (fun c (k, b) -> S.set c (to_path k) (C.to_bytes b)) + c (Map.bindings m) + +end + +(*-- Imperative overlays ----------------------------------------------------*) + +type 'a shared_ref = + { mutable contents : 'a ; + lock : Lwt_mutex.t } +let share contents = + { contents ; + lock = Lwt_mutex.create () } +let update r f = + Lwt_mutex.with_lock r.lock + (fun () -> f r.contents >>= function + | None -> Lwt.return false + | Some new_contents -> + r.contents <- new_contents ; + Lwt.return true) +let update_with_res r f = + Lwt_mutex.with_lock r.lock + (fun () -> f r.contents >>= function + | (None, x) -> Lwt.return (false, x) + | (Some new_contents, x) -> + r.contents <- new_contents ; + Lwt.return (true, x)) +let use r f = + Lwt_mutex.with_lock r.lock + (fun () -> f r.contents) + +module type IMPERATIVE_PROXY = sig + module Store : TYPED_STORE + + type t + type rdata + type state + val create: state -> Store.t shared_ref -> t + val known: t -> Store.key -> bool Lwt.t + val read: t -> Store.key -> Store.value option Lwt.t + val store: t -> Store.key -> Store.value -> bool Lwt.t + val update: t -> Store.key -> Store.value -> bool Lwt.t + val remove: t -> Store.key -> bool Lwt.t + val prefetch: t -> rdata -> Store.key -> unit + val fetch: t -> rdata -> Store.key -> Store.value Lwt.t + val pending: t -> Store.key -> bool + val shutdown: t -> unit Lwt.t +end + +module type IMPERATIVE_PROXY_SCHEDULER = sig + module Store : TYPED_STORE + type state + type rdata + type data + + val name : string + val init_request : + state -> Store.key -> data Lwt.t + val request : + state -> + get:(rdata -> Store.key -> Store.value Lwt.t) -> + set:(Store.key -> Store.value -> unit Lwt.t) -> + (Store.key * data * rdata) list -> float +end + +module MakeImperativeProxy + (Store : TYPED_STORE) + (Table : Hashtbl.S with type key = Store.key) + (Scheduler : IMPERATIVE_PROXY_SCHEDULER with module Store := Store) + : IMPERATIVE_PROXY with module Store := Store and type state = Scheduler.state and type rdata = Scheduler.rdata = struct + + type rdata = Scheduler.rdata + type data = + { rdata: rdata ; + state: [ `Inited of Scheduler.data | `Initing of Scheduler.data Lwt.t ] ; + wakener: Store.value Lwt.u } + type store = Store.t + type state = Scheduler.state + type key = Store.key + type value = Store.value + + type t = + { tbl : data Table.t ; + store : Store.t shared_ref ; + cancelation: unit -> unit Lwt.t ; + cancel: unit -> unit Lwt.t ; + on_cancel: (unit -> unit Lwt.t) -> unit ; + worker_trigger: unit -> unit; + worker_waiter: unit -> unit Lwt.t ; + worker: unit Lwt.t ; + gstate : state } + + let pending_requests { tbl } = + Table.fold + (fun h data acc -> + match data.state with + | `Initing _ -> acc + | `Inited d -> (h, d, data.rdata) :: acc) + tbl [] + + let pending { tbl } hash = Table.mem tbl hash + + let request { tbl ; worker_trigger ; gstate } rdata hash = + assert (not (Table.mem tbl hash)); + let waiter, wakener = Lwt.wait () in + let data = Scheduler.init_request gstate hash in + match Lwt.state data with + | Lwt.Return data -> + let state = `Inited data in + Table.add tbl hash { rdata ; state ; wakener } ; + worker_trigger () ; + waiter + | _ -> + let state = `Initing data in + Table.add tbl hash { rdata ; state ; wakener } ; + Lwt.async + (fun () -> + data >>= fun data -> + let state = `Inited data in + Table.add tbl hash { rdata ; state ; wakener } ; + worker_trigger () ; + Lwt.return_unit) ; + waiter + + let prefetch ({ store ; tbl } as session) rdata hash = + Lwt.ignore_result + (use store (fun store -> Store.mem store hash) >>= fun exists -> + if not exists && not (Table.mem tbl hash) then + request session rdata hash >>= fun _ -> Lwt.return_unit + else + Lwt.return_unit) + + let known { store } hash = + use store (fun store -> Store.mem store hash) + + let read { store } hash = + use store (fun store -> Store.get store hash) + + let fetch ({ store ; tbl } as session) rdata hash = + try Lwt.waiter_of_wakener (Table.find tbl hash).wakener + with Not_found -> + use store (fun store -> Store.get store hash) >>= function + | Some op -> Lwt.return op + | None -> + try Lwt.waiter_of_wakener (Table.find tbl hash).wakener + with Not_found -> request session rdata hash + + let store { store ; tbl } hash data = + update store (fun store -> + Store.mem store hash >>= fun exists -> + if exists then Lwt.return_none + else ( Store.set store hash data >>= fun store -> + Lwt.return (Some store) ) ) >>= fun changed -> + try + let wakener = (Table.find tbl hash).wakener in + Table.remove tbl hash; + Lwt.wakeup wakener data; + Lwt.return changed + with Not_found -> Lwt.return changed + + let remove { store ; _ } hash = + update store (fun store -> + Store.mem store hash >>= fun exists -> + if not exists then Lwt.return_none + else ( Store.del store hash >>= fun store -> + Lwt.return (Some store) ) ) + + let update { store ; _ } hash data = + update store (fun store -> + Store.mem store hash >>= fun exists -> + if not exists then Lwt.return_none + else ( Store.set store hash data >>= fun store -> + Lwt.return (Some store) ) ) + + let create gstate st = + let tbl = Table.create 50 in + let cancelation, cancel, on_cancel = Lwt_utils.canceler () in + let worker_trigger, worker_waiter = Lwt_utils.trigger () in + let session = + { tbl ; gstate ; store = st ; worker = Lwt.return () ; + cancelation ; cancel ; on_cancel ; + worker_trigger ; worker_waiter } in + let worker = + let rec worker_loop () = + Lwt.pick [(worker_waiter () >|= fun () -> `Process); + (cancelation () >|= fun () -> `Cancel)] >>= function + | `Cancel -> Lwt.return_unit + | `Process -> + begin + match pending_requests session with + | [] -> () + | requests -> + let get = fetch session + and set k v = store session k v >>= fun _ -> Lwt.return_unit in + let timeout = Scheduler.request gstate ~get ~set requests in + if timeout > 0. then + Lwt.ignore_result (Lwt_unix.sleep timeout >|= worker_trigger); + end; + worker_loop () + in + Lwt_utils.worker Scheduler.name ~run:worker_loop ~cancel in + { session with worker } + + let shutdown { cancel ; worker } = + cancel () >>= fun () -> worker + +end + +(*-- Predefined Instances ----------------------------------------------------*) + +module MBytesValue = struct + type t = MBytes.t + let of_bytes x = Some x + let to_bytes x = x +end + +module MakePersistentBytesMap + (S : STORE) (K : KEY) = + MakePersistentMap(S)(K)(MBytesValue) + +module MakeBufferedPersistentBytesMap + (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) = + MakeBufferedPersistentMap(S)(K)(MBytesValue)(Map) + +module type TYPED_VALUE_REPR = sig + type value + val encoding: value Data_encoding.t +end + +module TypedValue (T : TYPED_VALUE_REPR) = struct + type t = T.value + let of_bytes x = Data_encoding.Binary.of_bytes T.encoding x + let to_bytes x = Data_encoding.Binary.to_bytes T.encoding x +end + +module MakePersistentTypedMap + (S : STORE) (K : KEY) + (T : TYPED_VALUE_REPR) = + MakePersistentMap(S)(K)(TypedValue(T)) + +module MakeBufferedPersistentTypedMap + (S : STORE) + (K : KEY) + (T : TYPED_VALUE_REPR) + (Map : Map.S with type key = K.t) + = + MakeBufferedPersistentMap(S)(K)(TypedValue(T))(Map) diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli new file mode 100644 index 000000000..69380e0a6 --- /dev/null +++ b/src/node/db/persist.mli @@ -0,0 +1,251 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Persistent structures on top of {!Context} *) + +open Lwt + + +(** Keys in (kex x value) database implementations *) +type key = string list + +(** Values in (kex x value) database implementations *) +type value = MBytes.t + +(** Low level view over a (key x value) database implementation. *) +module type STORE = sig + type t + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +(** Projection of OCaml keys of some abstract type to concrete storage + keys. For practical reasons, all such keys must fall under a same + {!prefix} and have the same relative {!length}. Functions + {!to_path} and {!of_path} only take the relative part into account + (the prefix is added and removed when needed). *) +module type KEY = sig + type t + val prefix: key + val length: int + val to_path: t -> key + val of_path: key -> t + val compare: t -> t -> int +end + +(** A KEY instance for using raw implementation paths as keys *) +module RawKey : KEY with type t = key + +module type BYTES_STORE = sig + type t + type key + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +module MakeBytesStore (S : STORE) (K : KEY) : + BYTES_STORE with type t = S.t and type key = K.t + +(** {2 Typed Store Overlays} *************************************************) + +(** Projection of OCaml values of some abstract type to concrete + storage data. *) +module type VALUE = sig + type t + val of_bytes: value -> t option + val to_bytes: t -> value +end + +(** A VALUE instance for using the raw bytes values *) +module RawValue : VALUE with type t = value + +(** Signature of a typed store as returned by {!MakeTypedStore} *) +module type TYPED_STORE = sig + type t + type key + type value + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t +end + +(** Gives a typed view of a store (values of a given type stored under + keys of a given type). The view is also restricted to a prefix, + (which can be empty). For all primitives to work as expected, all + keys under this prefix must be homogeneously typed. *) +module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) : + TYPED_STORE with type t = S.t and type key = K.t and type value = C.t + +(** {2 Persistent Sets} ******************************************************) + +(** Signature of a set as returned by {!MakePersistentSet} *) +module type PERSISTENT_SET = sig + type t and key + val mem : t -> key -> bool Lwt.t + val set : t -> key -> t Lwt.t + val del : t -> key -> t Lwt.t + val elements : t -> key list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +(** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *) +module type BUFFERED_PERSISTENT_SET = sig + include PERSISTENT_SET + module Set : Set.S with type elt = key + val read : t -> Set.t Lwt.t + val write : t -> Set.t -> t Lwt.t +end + +(** Build a set in the (key x value) storage by encoding elements as + keys and using the association of (any) data to these keys as + membership. For this to work, the prefix passed must be reserved + for the set (every key under it is considered a member). *) +module MakePersistentSet (S : STORE) (K : KEY) + : PERSISTENT_SET with type t := S.t and type key := K.t + +(** Same as {!MakePersistentSet} but also provides a way to use an + OCaml set as an explicitly synchronized in-memory buffer. *) +module MakeBufferedPersistentSet + (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) + : BUFFERED_PERSISTENT_SET + with type t := S.t + and type key := K.t + and module Set := Set + +(** {2 Persistent Maps} ******************************************************) + +(** Signature of a map as returned by {!MakePersistentMap} *) +module type PERSISTENT_MAP = sig + type t and key and value + val mem : t -> key -> bool Lwt.t + val get : t -> key -> value option Lwt.t + val set : t -> key -> value -> t Lwt.t + val del : t -> key -> t Lwt.t + val bindings : t -> (key * value) list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +(** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *) +module type BUFFERED_PERSISTENT_MAP = sig + include PERSISTENT_MAP + module Map : Map.S with type key = key + val read : t -> value Map.t Lwt.t + val write : t -> value Map.t -> t Lwt.t +end + +(** Build a map in the (key x value) storage. For this to work, the + prefix passed must be reserved for the map (every key under it is + considered the key of a binding). *) +module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := C.t + +(** Same as {!MakePersistentMap} but also provides a way to use an + OCaml map as an explicitly synchronized in-memory buffer. *) +module MakeBufferedPersistentMap + (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := C.t + and module Map := Map + +(** {2 Imperative overlays} **************************************************) + +type 'a shared_ref +val share : 'a -> 'a shared_ref +val update : 'a shared_ref -> ('a -> 'a option Lwt.t) -> bool Lwt.t +val update_with_res : + 'a shared_ref -> ('a -> ('a option * 'b) Lwt.t) -> (bool * 'b) Lwt.t +val use : 'a shared_ref -> ('a -> 'b Lwt.t) -> 'b Lwt.t + +module type IMPERATIVE_PROXY = sig + module Store : TYPED_STORE + + type t + type rdata + type state + val create: state -> Store.t shared_ref -> t + val known: t -> Store.key -> bool Lwt.t + val read: t -> Store.key -> Store.value option Lwt.t + val store: t -> Store.key -> Store.value -> bool Lwt.t + val update: t -> Store.key -> Store.value -> bool Lwt.t + val remove: t -> Store.key -> bool Lwt.t + val prefetch: t -> rdata -> Store.key -> unit + val fetch: t -> rdata -> Store.key -> Store.value Lwt.t + val pending: t -> Store.key -> bool + val shutdown: t -> unit Lwt.t +end + +module type IMPERATIVE_PROXY_SCHEDULER = sig + module Store : TYPED_STORE + type state + type rdata + type data + + val name : string + val init_request : + state -> Store.key -> data Lwt.t + val request : + state -> + get:(rdata -> Store.key -> Store.value Lwt.t) -> + set:(Store.key -> Store.value -> unit Lwt.t) -> + (Store.key * data * rdata) list -> float +end + +module MakeImperativeProxy + (Store : TYPED_STORE) + (Table : Hashtbl.S with type key = Store.key) + (Scheduler : IMPERATIVE_PROXY_SCHEDULER with module Store := Store) + : IMPERATIVE_PROXY with module Store := Store and type state = Scheduler.state + and type rdata = Scheduler.rdata + +(** {2 Predefined Instances} *************************************************) + +module MakePersistentBytesMap (S : STORE) (K : KEY) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := MBytes.t + +module MakeBufferedPersistentBytesMap + (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := MBytes.t + and module Map := Map + +module type TYPED_VALUE_REPR = sig + type value + val encoding: value Data_encoding.t +end + +module MakePersistentTypedMap (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := T.value + +module MakeBufferedPersistentTypedMap + (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := T.value + and module Map := Map diff --git a/src/node/db/store.ml b/src/node/db/store.ml new file mode 100644 index 000000000..24fcd0c0d --- /dev/null +++ b/src/node/db/store.ml @@ -0,0 +1,648 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos - Simple (key x value) store *) + +open Logging.Db + +let (//) = Filename.concat + +(*-- Generic static storage in a Unix directory ------------------------------*) + +type key = string list + +module IrminPath = Irmin.Path.String_list + +type value = MBytes.t + +module MBytesContent = struct + module Tc_S0 = + (val Tc.biject Tc.cstruct Cstruct.to_bigarray Cstruct.of_bigarray) + include Tc_S0 + module Path = Irmin.Path.String_list + let merge = + let fn = Irmin.Merge.(option (module Tc_S0) (default (module Tc_S0))) in + fun _path -> fn +end + +module FS = struct + + type t = string + + let init dir = + IO.check_dir dir >>= fun () -> + Lwt.return dir + + let file_of_key root key = + String.concat Filename.dir_sep (root :: key) + + let key_of_file root file = + let len = String.length root + 1 in + String.sub file len (String.length file - len) + + let mem root key = + let file = file_of_key root key in + Lwt.return (Sys.file_exists file && not (Sys.is_directory file)) + + let get root key = + mem root key >>= function + | true -> + Lwt.catch + (fun () -> + IO.with_file_in (file_of_key root key) + (fun ba -> Lwt.return (Some ba))) + (fun e -> + warn "warn: can't read %s: %s" + (file_of_key root key) (Printexc.to_string e); + Lwt.return_none) + | false -> Lwt.return_none + + let del root key = + IO.remove_file (file_of_key root key) + + let set root key value = + del root key >>= fun () -> + IO.with_file_out (file_of_key root key) value + + let list root keys = + let dirs = List.map (file_of_key root) keys in + Lwt_list.map_p + (fun dir -> + Lwt.catch + (fun () -> + IO.list_files dir >|= fun files -> + List.map (fun file -> + Utils.split_path (key_of_file root (dir // file))) files) + (fun _ -> Lwt.return [])) + dirs >>= fun files -> + Lwt.return (List.concat files) + + let remove_rec root key = + IO.remove_rec (file_of_key root key) + +end + +type generic_store = FS.t +type block_store = FS.t +type blockchain_store = FS.t +type operation_store = FS.t + +type store = { + block: block_store Persist.shared_ref ; + blockchain: blockchain_store Persist.shared_ref ; + operation: operation_store Persist.shared_ref ; + global_store: generic_store Persist.shared_ref ; + net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ; + net_read: net_id -> net_store tzresult Lwt.t ; + net_destroy: net_store -> unit Lwt.t ; +} + +and net_store = { + net_genesis: genesis ; + net_expiration: Time.t option ; + net_store: generic_store Persist.shared_ref ; +} + +and genesis = { + time: Time.t ; + block: Block_hash.t ; + protocol: Protocol_hash.t ; +} + +and net_id = Net of Block_hash.t + +module type TYPED_IMPERATIVE_STORE = sig + type t + type key + type value + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val get_exn: t -> key -> value Lwt.t + val set: t -> key -> value -> unit Lwt.t + val del: t -> key -> unit Lwt.t +end + +module type IMPERATIVE_STORE = sig + type t + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val get_exn: t -> key -> value Lwt.t + val set: t -> key -> value -> unit Lwt.t + val del: t -> key -> unit Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> unit Lwt.t +end + +(*-- Generic data store under "data/" ----------------------------------------*) + +module type KEY = sig + type t + val to_path: t -> string list +end + +module Raw_key = struct + type t = string list + let to_path x = x +end + +module type VALUE = sig + type t + val of_bytes: MBytes.t -> t option + val to_bytes: t -> MBytes.t +end + +module Raw_value = struct + type t = MBytes.t + let to_bytes b = b + let of_bytes b = Some b +end + +module Block_hash_value = struct + type t = Block_hash.t + let to_bytes = Block_hash.to_bytes + let of_bytes v = try Some (Block_hash.of_bytes v) with _ -> None +end + +module Block_hash_set_value = struct + type t = Block_hash_set.t + let to_bytes = Data_encoding.Binary.to_bytes Block_hash_set.encoding + let of_bytes = Data_encoding.Binary.of_bytes Block_hash_set.encoding +end + +module Time_value = struct + type t = Time.t + let to_bytes v = MBytes.of_string @@ Time.to_notation v + let of_bytes b = Time.of_notation (MBytes.to_string b) +end + +module Errors_value = struct + type t = error list + let to_bytes v = Data_encoding.(Binary.to_bytes (list (error_encoding ()))) v + let of_bytes b = Data_encoding.(Binary.of_bytes (list (error_encoding ()))) b +end + + +module Make (K : KEY) (V : Persist.VALUE) = struct + type t = FS.t + type key = K.t + type value = V.t + let mem t k = FS.mem t (K.to_path k) + let get t k = + FS.get t (K.to_path k) >|= function + | None -> None + | Some v -> V.of_bytes v + let get_exn t key = + get t key >>= function + | None -> Lwt.fail Not_found + | Some v -> Lwt.return v + let set t k v = FS.set t (K.to_path k) (V.to_bytes v) + let del t k = FS.del t (K.to_path k) + let list t ks = FS.list t (List.map K.to_path ks) + let remove_rec t k = FS.remove_rec t (K.to_path k) +end + +module Data_store : IMPERATIVE_STORE with type t = FS.t = + Make (Raw_key) (Raw_value) + +include Data_store + +(*-- Typed block store under "blocks/" ---------------------------------------*) + +type shell_block_header = { + net_id: net_id ; + predecessor: Block_hash.t ; + timestamp: Time.t ; + fitness: MBytes.t list ; + operations: Operation_hash.t list ; +} +type block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} + +let net_id_encoding = + let open Data_encoding in + conv + (fun (Net net_id) -> net_id) + (fun net_id -> Net net_id) + Block_hash.encoding + +let pp_net_id ppf (Net id) = Block_hash.pp_short ppf id + +let shell_block_header_encoding = + let open Data_encoding in + conv + (fun { net_id ; predecessor ; timestamp ; fitness ; operations } -> + (net_id, predecessor, timestamp, fitness, operations)) + (fun (net_id, predecessor, timestamp, fitness, operations) -> + { net_id ; predecessor ; timestamp ; fitness ; operations }) + (obj5 + (req "net_id" net_id_encoding) + (req "predecessor" Block_hash.encoding) + (req "timestamp" Time.encoding) + (req "fitness" Fitness.encoding) + (req "operations" (list Operation_hash.encoding))) + +let block_header_encoding = + let open Data_encoding in + conv + (fun { shell ; proto } -> (shell, proto)) + (fun (shell, proto) -> { shell ; proto }) + (merge_objs + shell_block_header_encoding + (obj1 (req "data" Variable.bytes))) + +module Raw_block_value = struct + type t = block_header + let to_bytes v = + Data_encoding.Binary.to_bytes block_header_encoding v + let of_bytes b = + Data_encoding.Binary.of_bytes block_header_encoding b +end + +module Block_header_key = struct + type t = Block_hash.t + let to_path p = "blocks" :: Block_hash.to_path p @ [ "contents" ] +end +module Block_header = Make (Block_header_key) (Raw_block_value) +module Raw_block = Make (Block_header_key) (Raw_value) + +module Block_pred_key = struct + type t = Block_hash.t + let to_path p = "blocks" :: Block_hash.to_path p @ [ "pred" ] +end +module Block_pred = Make (Block_pred_key) (Block_hash_value) + +module Block_time_key = struct + type t = Block_hash.t + let to_path p = "blocks" :: Block_hash.to_path p @ [ "discovery_time" ] +end +module Block_time = Make (Block_time_key) (Time_value) + +module Block_errors_key = struct + type t = Block_hash.t + let to_path p = "blocks" :: Block_hash.to_path p @ [ "errors" ] +end +module Block_errors = Make (Block_errors_key) (Errors_value) + +module Block = struct + type t = FS.t + type key = Block_hash.t + type value = Block_hash.t * + block_header Time.timed_data option Lwt.t Lazy.t + let mem = Block_pred.mem + let full_get s k = + Block_time.get s k >>= function + | None -> Lwt.return_none + | Some time -> + Block_header.get s k >>= function + | None -> Lwt.return_none + | Some data -> Lwt.return (Some { Time.data ; time }) + let get s k = + Block_pred.get s k >>= function + | None -> Lwt.return_none + | Some pred -> + Lwt.return (Some (pred, lazy (full_get s k))) + let get_exn s k = + get s k >>= function + | None -> Lwt.fail Not_found + | Some x -> Lwt.return x + let set s k (p, lazy r) = + Block_pred.set s k p >>= fun () -> + r >>= function + | None -> Lwt.return_unit + | Some { Time.data ; time } -> + Block_header.set s k data >>= fun () -> + Block_time.set s k time + let full_set s k r = + set s k (r.Time.data.shell.predecessor, Lazy.from_val (Lwt.return (Some r))) + let del s k = + Block_pred.del s k >>= fun () -> + Block_time.del s k >>= fun () -> + Block_header.del s k + + let compare b1 b2 = + let (>>) x y = if x = 0 then y () else x in + let rec list compare xs ys = + match xs, ys with + | [], [] -> 0 + | _ :: _, [] -> -1 + | [], _ :: _ -> 1 + | x :: xs, y :: ys -> + compare x y >> fun () -> list compare xs ys in + Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () -> + compare b1.proto b2.proto >> fun () -> + list Operation_hash.compare + b1.shell.operations b2.shell.operations >> fun () -> + Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () -> + list compare b1.shell.fitness b2.shell.fitness + + let equal b1 b2 = compare b1 b2 = 0 + let of_bytes = Raw_block_value.of_bytes + let to_bytes = Raw_block_value.to_bytes + let hash block = Block_hash.hash_bytes [to_bytes block] + + let raw_get t k = Raw_block.get t k + +end + +module Blockchain_succ_key = struct + type t = Block_hash.t + let to_path p = + "blocks" :: Block_hash.to_path p @ ["blockchain_successor"] +end +module Blockchain_succ = Make (Blockchain_succ_key) (Block_hash_value) + +module Blockchain_test_succ_key = struct + type t = Block_hash.t + let to_path p = + "blocks" :: Block_hash.to_path p @ ["test_blockchain_successor"] +end +module Blockchain_test_succ = Make (Blockchain_test_succ_key) (Block_hash_value) + +module Block_valid_succs_key = struct + type t = Block_hash.t + let to_path p = + "blocks" :: Block_hash.to_path p @ ["valid_successors"] +end +module Block_valid_succs = + Make (Block_valid_succs_key) (Block_hash_set_value) + +module Block_invalid_succs_key = struct + type t = Block_hash.t + let to_path p = + "blocks" :: Block_hash.to_path p @ ["invalid_successors"] +end +module Block_invalid_succs = + Make (Block_invalid_succs_key) (Block_hash_set_value) + +module Blockchain_key = struct + type t = Block_hash.t + let to_path p = + "blocks" :: Block_hash.to_path p @ ["time"] +end +module Blockchain = Make (Blockchain_key) (Time_value) + + +(*-- Typed operation store under "operations/" -------------------------------*) + +type shell_operation = { + net_id: net_id ; +} +type operation = { + shell: shell_operation ; + proto: MBytes.t ; +} + +let shell_operation_encoding = + let open Data_encoding in + conv + (fun { net_id } -> net_id) + (fun net_id -> { net_id }) + (obj1 (req "net_id" net_id_encoding)) + +let operation_encoding = + let open Data_encoding in + conv + (fun { shell ; proto } -> (shell, proto)) + (fun (shell, proto) -> { shell ; proto }) + (merge_objs + shell_operation_encoding + (obj1 (req "data" Variable.bytes))) + +module Raw_operation_value = struct + type t = operation + let to_bytes v = Data_encoding.Binary.to_bytes operation_encoding v + let of_bytes b = Data_encoding.Binary.of_bytes operation_encoding b +end + +module Raw_operation_key = struct + type t = Operation_hash.t + let to_path p = "operations" :: Operation_hash.to_path p @ [ "contents" ] +end +module Operation_data = Make (Raw_operation_key) (Raw_operation_value) +module Raw_operation_data = Make (Raw_operation_key) (Raw_value) + +module Operation_time_key = struct + type t = Operation_hash.t + let to_path p = "operations" :: Operation_hash.to_path p @ [ "discovery_time" ] +end +module Operation_time = Make (Operation_time_key) (Time_value) + +module Operation_errors_key = struct + type t = Operation_hash.t + let to_path p = "operations" :: Operation_hash.to_path p @ [ "errors" ] +end +module Operation_errors = Make (Operation_errors_key) (Errors_value) + +module Operation = struct + type t = FS.t + type key = Operation_hash.t + type value = operation tzresult Time.timed_data + let mem = Operation_data.mem + let get s k = + Operation_time.get s k >>= function + | None -> Lwt.return_none + | Some time -> + Operation_errors.get s k >>= function + | Some exns -> Lwt.return (Some { Time.data = Error exns ; time }) + | None -> + Operation_data.get s k >>= function + | None -> Lwt.return_none + | Some bytes -> Lwt.return (Some { Time.data = Ok bytes ; time }) + let get_exn s k = + get s k >>= function + | None -> Lwt.fail Not_found + | Some x -> Lwt.return x + let set s k { Time.data ; time } = + Operation_time.set s k time >>= fun () -> + match data with + | Ok bytes -> + Operation_data.set s k bytes >>= fun () -> + Operation_errors.del s k + | Error exns -> + Operation_errors.set s k exns >>= fun () -> + Operation_data.del s k + let del s k = + Operation_time.del s k >>= fun () -> + Operation_data.del s k >>= fun () -> + Operation_errors.del s k + let compare o1 o2 = + let (>>) x y = if x = 0 then y () else x in + let Net net_id1 = o1.shell.net_id + and Net net_id2 = o2.shell.net_id in + Block_hash.compare net_id1 net_id2 >> fun () -> + MBytes.compare o1.proto o2.proto + let equal b1 b2 = compare b1 b2 = 0 + let of_bytes = Raw_operation_value.of_bytes + let to_bytes = Raw_operation_value.to_bytes + let hash op = Operation_hash.hash_bytes [to_bytes op] + let raw_get t k = Raw_operation_data.get t k +end + + +(*- Genesis and initialization -----------------------------------------------*) + +let genesis_encoding = + let open Data_encoding in + conv + (fun {time;block;protocol} -> (time,block,protocol)) + (fun (time,block,protocol) -> {time;block;protocol}) + (obj3 + (req "timestamp" Time.encoding) + (req "block" Block_hash.encoding) + (req "protocol" Protocol_hash.encoding)) + +let read_genesis, store_genesis = + let key = ["genesis"] in + let read t = + get t key >>= function + | None -> Lwt.return None + | Some v -> + match Data_encoding.Json.from_string (MBytes.to_string v) with + | Error _ -> + fatal_error + "Store.read_genesis: invalid json object." + | Ok json -> + try Lwt.return + (Some (Data_encoding.Json.destruct genesis_encoding json)) + with _ -> + fatal_error + "Store.read_genesis: cannot parse json object." in + let store t h = + set t key ( MBytes.of_string @@ + Data_encoding.Json.to_string @@ + Data_encoding.Json.construct genesis_encoding h ) in + (read, store) + +let read_expiration, store_expiration = + let key = ["expiration"] in + let read t = + get t key >>= function + | None -> Lwt.return None + | Some v -> Lwt.return (Time.of_notation (MBytes.to_string v)) in + let store t h = + set t key ( MBytes.of_string @@ Time.to_notation h ) in + (read, store) + +let current_store_version = MBytes.of_string "1" +let raw_init ~root () = + FS.init root >>= fun t -> + get t ["version"] >>= function + | None -> + set t ["version"] (MBytes.of_string "1") >>= fun () -> + Lwt.return t + | Some version -> + if MBytes.(version = current_store_version) then + Lwt.return t + else + fatal_error "Store.init: unknown database version" + +let net_read ~root (Net net_id) = + let root = root // "net" // Block_hash.to_hex net_id in + raw_init ~root () >>= fun t -> + read_genesis t >>= function + | None -> + failwith "Store.net_read: missing genesis information." + | Some net_genesis -> + if not (Block_hash.equal net_genesis.block net_id) then + failwith "Store.net_read: inconsistent genesis block." + else + read_expiration t >>= fun net_expiration -> + begin + match net_expiration with + | None -> return () + | Some expiration -> + fail_unless + Time.(expiration < now ()) + (Unclassified "Store.net_read expired network") + end >>=? fun () -> + + return { + net_genesis ; + net_expiration ; + net_store = Persist.share t ; + } + +let raw_net_init ~root ?expiration genesis = + raw_init ~root () >>= fun t -> + read_genesis t >>= function + | None -> + store_genesis t genesis >>= fun () -> + begin + match expiration with + | None -> Lwt.return_unit + | Some expiration -> store_expiration t expiration + end >>= fun () -> + Lwt.return t + | Some stored_genesis -> + if not (Block_hash.equal stored_genesis.block genesis.block) then + fatal_error "Store.net_init: inconsistent genesis block." + else if + not (Protocol_hash.equal stored_genesis.protocol genesis.protocol) + then + fatal_error "Store.net_init: inconsistent genesis protocol." + else if + not (Time.equal stored_genesis.time genesis.time) + then + fatal_error "Store.net_init: inconsistent genesis time." + else + read_expiration t >>= fun stored_expiration -> + match stored_expiration, expiration with + | None, None -> Lwt.return t + | Some t1, Some t2 when Time.equal t1 t2 -> Lwt.return t + | _ -> + fatal_error "Store.net_init: incoherent end of life." + +let net_init ~root ?expiration (net_genesis : genesis) = + let root = root // "net" // Block_hash.to_hex net_genesis.block in + raw_net_init ~root ?expiration net_genesis >|= fun t -> + { + net_genesis ; + net_expiration = expiration ; + net_store = Persist.share t ; + } + +let net_destroy ~root { net_genesis } = + let root = root // "net" // Block_hash.to_hex net_genesis.block in + IO.remove_rec root >>= fun () -> + Lwt.return_unit + +let init root = + raw_init ~root:(Filename.concat root "global") () >>= fun t -> + Lwt.return + { block = Persist.share t ; + blockchain = Persist.share t ; + operation = Persist.share t ; + global_store = Persist.share t ; + net_init = net_init ~root ; + net_read = net_read ~root ; + net_destroy = net_destroy ~root ; + } + +module Faked_functional_typed_store (S: TYPED_IMPERATIVE_STORE) + : Persist.TYPED_STORE with type key = S.key + and type value = S.value + and type t = S.t += struct + include S + let set s k v = S.set s k v >>= fun () -> Lwt.return s + let del s k = S.del s k >>= fun () -> Lwt.return s +end + +module Faked_functional_operation = Faked_functional_typed_store (Operation) +module Faked_functional_block = Faked_functional_typed_store (Block) + +module Faked_functional_store : Persist.STORE with type t = t += struct + include Data_store + let set s k v = Data_store.set s k v >>= fun () -> Lwt.return s + let del s k = Data_store.del s k >>= fun () -> Lwt.return s + let remove_rec s k = Data_store.remove_rec s k >>= fun () -> Lwt.return s +end diff --git a/src/node/db/store.mli b/src/node/db/store.mli new file mode 100644 index 000000000..e85d85a62 --- /dev/null +++ b/src/node/db/store.mli @@ -0,0 +1,201 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Simple imperative (key x value) store *) + +type key = string list +type value = MBytes.t + +module type TYPED_IMPERATIVE_STORE = sig + type t + type key + type value + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val get_exn: t -> key -> value Lwt.t + val set: t -> key -> value -> unit Lwt.t + val del: t -> key -> unit Lwt.t +end + +module type IMPERATIVE_STORE = sig + type t + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val get_exn: t -> key -> value Lwt.t + val set: t -> key -> value -> unit Lwt.t + val del: t -> key -> unit Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> unit Lwt.t +end + +(** A generic (key x value) store. *) +type generic_store +type block_store +type blockchain_store +type operation_store + +type store = private { + block: block_store Persist.shared_ref ; + blockchain: blockchain_store Persist.shared_ref ; + operation: operation_store Persist.shared_ref ; + global_store: generic_store Persist.shared_ref ; + net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ; + net_read: net_id -> net_store tzresult Lwt.t ; + net_destroy: net_store -> unit Lwt.t ; +} + +and net_store = private { + net_genesis: genesis ; + net_expiration: Time.t option ; + net_store: generic_store Persist.shared_ref ; +} + +and genesis = { + time: Time.t ; + block: Block_hash.t ; + protocol: Protocol_hash.t ; +} + +and net_id = Net of Block_hash.t + +val net_id_encoding: net_id Data_encoding.t +val pp_net_id: Format.formatter -> net_id -> unit + +(** Open or initialize a store at a given path. *) +val init: string -> store Lwt.t + +(** {2 Generic interface} ****************************************************) + +(** The generic primitives do work on the direct root, but in a + "data/" subdirectory and do not colide with following block and + operation specific functions. *) +include IMPERATIVE_STORE with type t = generic_store + +(** {2 Types} ****************************************************************) + +(** Raw operations in the database (partially parsed). + See [State.Operation.t] for detailled description. *) +type shell_operation = { + net_id: net_id ; +} +type operation = { + shell: shell_operation ; + proto: MBytes.t ; +} + +val shell_operation_encoding: shell_operation Data_encoding.t +val operation_encoding: operation Data_encoding.t + +(** Raw blocks in the database (partially parsed). *) +type shell_block_header = { + net_id: net_id ; + predecessor: Block_hash.t ; + timestamp: Time.t ; + fitness: MBytes.t list ; + operations: Operation_hash.t list ; +} +type block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} +val shell_block_header_encoding: shell_block_header Data_encoding.t +val block_header_encoding: block_header Data_encoding.t + +(** {2 Block and operations store} ********************************************) + +module Block : sig + + val of_bytes: MBytes.t -> block_header option + val to_bytes: block_header -> MBytes.t + val hash: block_header -> Block_hash.t + + include TYPED_IMPERATIVE_STORE + with type t = block_store + and type key = Block_hash.t + and type value = + Block_hash.t * block_header Time.timed_data option Lwt.t Lazy.t + + val compare: block_header -> block_header -> int + val equal: block_header -> block_header -> bool + + val raw_get: t -> Block_hash.t -> MBytes.t option Lwt.t + val full_get: t -> Block_hash.t -> block_header Time.timed_data option Lwt.t + + val full_set: t -> Block_hash.t -> block_header Time.timed_data -> unit Lwt.t + +end + +module Block_valid_succs : TYPED_IMPERATIVE_STORE + with type t = generic_store + and type key = Block_hash.t + and type value = Block_hash_set.t + +module Block_invalid_succs : TYPED_IMPERATIVE_STORE + with type t = generic_store + and type key = Block_hash.t + and type value = Block_hash_set.t + +module Blockchain : TYPED_IMPERATIVE_STORE + with type t = blockchain_store + and type key = Block_hash.t + and type value = Time.t + +module Blockchain_succ : TYPED_IMPERATIVE_STORE + with type t = blockchain_store + and type key = Block_hash.t + and type value = Block_hash.t + +module Blockchain_test_succ : TYPED_IMPERATIVE_STORE + with type t = blockchain_store + and type key = Block_hash.t + and type value = Block_hash.t + +module Operation : sig + + val of_bytes: MBytes.t -> operation option + val to_bytes: operation -> MBytes.t + + (** Computes the hash of a raw operation + (including both abstract and parsed parts) *) + val hash: operation -> Operation_hash.t + + include TYPED_IMPERATIVE_STORE + with type t = operation_store + and type key = Operation_hash.t + and type value = operation tzresult Time.timed_data + + val compare: operation -> operation -> int + val equal: operation -> operation -> bool + + val raw_get: t -> Operation_hash.t -> MBytes.t option Lwt.t + +end + +(**/**) (* For testing only *) + +(* module LwtUnixStore : sig *) + (* include Persist.STORE with type t = generic_store *) + (* val init : string -> t Lwt.t *) +(* end *) + +module IrminPath = Irmin.Path.String_list +module MBytesContent : Irmin.Contents.S with type t = MBytes.t + and module Path = IrminPath + +module Faked_functional_operation : + Persist.TYPED_STORE with type t = Operation.t + and type value = Operation.value + and type key = Operation.key + +module Faked_functional_block : + Persist.TYPED_STORE with type t = Block.t + and type value = Block.value + and type key = Block.key + +module Faked_functional_store : Persist.STORE with type t = t diff --git a/src/node/net/RPC.ml b/src/node/net/RPC.ml new file mode 100644 index 000000000..6352618f6 --- /dev/null +++ b/src/node/net/RPC.ml @@ -0,0 +1,179 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.RPC + +module Arg = Resto.Arg +module Path = Resto.Path +module Description = Resto.Description +let read_answer = Resto.read_answer +let forge_request = Resto.forge_request +let service ?description ~input ~output path = + Resto.service + ?description + ~input:(Data_encoding.Json.convert input) + ~output:(Data_encoding.Json.convert output) + path +type ('prefix, 'params, 'input, 'output) service = + ('prefix, 'params, 'input, 'output) Resto.service + +include RestoDirectory + +(* public types *) +type server = (* hidden *) + { shutdown : unit -> unit Lwt.t ; + mutable root : unit directory } + +module ConnectionMap = Map.Make(Cohttp.Connection) + +exception Invalid_method +exception Cannot_parse_body of string + +(* Promise a running RPC server. Takes the address and port. *) +let launch addr port root = + (* launch the worker *) + let cancelation, canceler, _ = Lwt_utils.canceler () in + let open Cohttp_lwt_unix in + let create_stream, shutdown_stream = + let streams = ref ConnectionMap.empty in + let create _io con (s: _ Answer.stream) = + let running = ref true in + let stream = + Lwt_stream.from + (fun () -> + if not !running then Lwt.return None else + s.next () >|= function + | None -> None + | Some x -> Some (Data_encoding.Json.to_string x)) in + let shutdown () = running := false ; s.shutdown () in + streams := ConnectionMap.add con shutdown !streams ; + stream + in + let shutdown con = + try ConnectionMap.find con !streams () + with Not_found -> () in + create, shutdown + in + let callback (io, con) req body = + (* FIXME: check inbound adress *) + let path = Utils.split_path (Uri.path (Cohttp.Request.uri req)) in + lwt_log_info "(%s) receive request to %s" + (Cohttp.Connection.to_string con) (Uri.path (Cohttp.Request.uri req)) >>= fun () -> + Lwt.catch + (fun () -> + lookup root () path >>= fun handler -> + begin + match req.meth with + | `POST -> begin + Cohttp_lwt_body.to_string body >>= fun body -> + match Data_encoding.Json.from_string body with + | Error msg -> Lwt.fail (Cannot_parse_body msg) + | Ok body -> Lwt.return (Some body) + end + | `GET -> Lwt.return None + | _ -> Lwt.fail Invalid_method + end >>= fun body -> + handler body >>= fun { Answer.code ; body } -> + let body = match body with + | Empty -> + Cohttp_lwt_body.empty + | Single json -> + Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json) + | Stream s -> + let stream = create_stream io con s in + Cohttp_lwt_body.of_stream stream in + lwt_log_info "(%s) RPC %s" + (Cohttp.Connection.to_string con) + (if Cohttp.Code.is_error code + then "failed" + else "success") >>= fun () -> + Lwt.return (Response.make ~flush:true ~status:(`Code code) (), body)) + (function + | Not_found | Cannot_parse _ -> + lwt_log_info "(%s) not found" + (Cohttp.Connection.to_string con) >>= fun () -> + Lwt.return (Response.make ~flush:true ~status:`Not_found (), + Cohttp_lwt_body.empty) + | Invalid_method -> + lwt_log_info "(%s) bad method" + (Cohttp.Connection.to_string con) >>= fun () -> + let headers = + Cohttp.Header.add_multi (Cohttp.Header.init ()) + "Allow" ["POST"] in + Lwt.return (Response.make + ~flush:true ~status:`Method_not_allowed + ~headers (), + Cohttp_lwt_body.empty) + | Cannot_parse_body msg -> + lwt_log_info "(%s) can't parse RPC body" + (Cohttp.Connection.to_string con) >>= fun () -> + Lwt.return (Response.make ~flush:true ~status:`Bad_request (), + Cohttp_lwt_body.of_string msg) + | e -> Lwt.fail e) + and conn_closed (_, con) = + log_info "connection close %s" (Cohttp.Connection.to_string con) ; + shutdown_stream con in + lwt_log_info "create server %s:%d" addr port >>= fun () -> + let ctx = Cohttp_lwt_unix_net.init () in + let mode = `TCP (`Port port) in + let stop = cancelation () in + let _server = + Server.create + ~stop ~ctx ~mode + (Server.make ~callback ~conn_closed ()) in + let shutdown () = + canceler () >>= fun () -> + lwt_log_info "server not really stopped (cohttp bug)" >>= fun () -> + Lwt.return () (* server *) (* FIXME: bug in cohttp *) in + Lwt.return { shutdown ; root } + +let root_service { root } = root + +let set_root_service server root = server.root <- root + +let shutdown server = + server.shutdown () + +module Error = struct + + let service = + service + ~description: "Schema for all the RPC errors from the shell" + ~input: Data_encoding.empty + ~output: Data_encoding.json_schema + Path.(root / "errors") + + let encoding = + let open Data_encoding in + let path, _ = forge_request service () () in + describe + ~description: + (Printf.sprintf + "The full list of error is available with \ + the global RPC `/%s`" (String.concat "/" path)) + (conv + ~schema:Json_schema.any + (fun exn -> `A (List.map json_of_error exn)) + (function `A exns -> List.map error_of_json exns | _ -> []) + json) + + let wrap param_encoding = + let open Data_encoding in + union [ + case + (obj1 (req "ok" param_encoding)) + (function Ok x -> Some x | _ -> None) + (fun x -> Ok x) ; + case + (obj1 (req "error" encoding)) + (function Error x -> Some x | _ -> None) + (fun x -> Error x) ; + ] + +end diff --git a/src/node/net/RPC.mli b/src/node/net/RPC.mli new file mode 100644 index 000000000..fa2ea2ddc --- /dev/null +++ b/src/node/net/RPC.mli @@ -0,0 +1,309 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** View over the RPC service, restricted to types. A protocol + implementation can define a set of remote procedures which are + registered when the protocol is activated via its [rpcs] + function. However, it cannot register new or update existing + procedures afterwards, neither can it see other procedures. *) + +(** Typed path argument. *) +module Arg : sig + + type 'a arg + val make: + ?descr:string -> + name:string -> + destruct:(string -> ('a, string) result) -> + construct:('a -> string) -> + 'a arg + + type descr = { + name: string ; + descr: string option ; + } + val descr: 'a arg -> descr + + val int: int arg + val int32: int32 arg + val int64: int64 arg + val float: float arg + +end + +(** Parametrized path to services. *) +module Path : sig + + type ('prefix, 'params) path + type 'prefix context = ('prefix, 'prefix) path + + val root: 'a context + + val add_suffix: + ('prefix, 'params) path -> string -> ('prefix, 'params) path + val (/): + ('prefix, 'params) path -> string -> ('prefix, 'params) path + + val add_arg: + ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path + val (/:): + ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path + + val prefix: + ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path + + val map: + ('a -> 'b) -> ('b -> 'a) -> ('prefix, 'a) path -> ('prefix, 'b) path + +end + +(** Services. *) +type ('prefix, 'params, 'input, 'output) service + +val service: + ?description: string -> + input: 'input Data_encoding.t -> + output: 'output Data_encoding.t -> + ('prefix, 'params) Path.path -> + ('prefix, 'params, 'input, 'output) service + +val prefix: + ('prefix, 'inner_prefix) Path.path -> + ('inner_prefix, 'params, 'input, 'output) service -> + ('prefix, 'params, 'input, 'output) service + +val forge_request: + (unit, 'params, 'input, 'output) service -> + 'params -> 'input -> string list * Data_encoding.json + +val read_answer: + (unit, 'params, 'input, 'output) service -> + Data_encoding.json -> ('output, string) result + +(** Service directory description *) +module Description : sig + + type service_descr = { + description: string option ; + input: Json_schema.schema ; + output: Json_schema.schema ; + } + + type directory_descr = + | Static of static_directory_descr + | Dynamic of string option + + and static_directory_descr = { + service: service_descr option ; + subdirs: static_subdirectories_descr option ; + } + + and static_subdirectories_descr = + | Suffixes of directory_descr Map.Make(String).t + | Arg of Arg.descr * directory_descr + + val service: + ?description:string -> + ('prefix, 'params) Path.path -> + ('prefix, 'params, bool option, directory_descr) service + + val pp_print_directory_descr: + Format.formatter -> directory_descr -> unit + +end + +module Answer : sig + + (** Return type for service handler *) + type 'a answer = + { code : int ; + body : 'a output ; + } + + and 'a output = + | Empty + | Single of 'a + | Stream of 'a stream + + and 'a stream = { + next: unit -> 'a option Lwt.t ; + shutdown: unit -> unit ; + } + + val ok: 'a -> 'a answer + val return: 'a -> 'a answer Lwt.t + val return_stream: 'a stream -> 'a answer Lwt.t + +end + +(** Dispatch tree *) +type 'prefix directory + +(** Empty tree *) +val empty: 'prefix directory + +val map: ('a -> 'b) -> 'b directory -> 'a directory + +val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory +val merge: 'a directory -> 'a directory -> 'a directory + +(** Possible error while registring services. *) +type step = + | Static of string + | Dynamic of Arg.descr +type conflict = + | CService | CDir | CBuilder | CCustom + | CTypes of Arg.descr * + Arg.descr + | CType of Arg.descr * string list +exception Conflict of step list * conflict + +(** Registring handler in service tree. *) +val register: + 'prefix directory -> + ('prefix, 'params, 'input, 'output) service -> + ('params -> 'input -> 'output Answer.answer Lwt.t) -> + 'prefix directory + +(** Registring handler in service tree. Curryfied variant. *) +val register0: + unit directory -> + (unit, unit, 'i, 'o) service -> + ('i -> 'o Answer.answer Lwt.t) -> + unit directory + +val register1: + 'prefix directory -> + ('prefix, unit * 'a, 'i, 'o) service -> + ('a -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register2: + 'prefix directory -> + ('prefix, (unit * 'a) * 'b, 'i, 'o) service -> + ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register3: + 'prefix directory -> + ('prefix, ((unit * 'a) * 'b) * 'c, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register4: + 'prefix directory -> + ('prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register5: + 'prefix directory -> + ('prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +(** Registring dynamic subtree. *) +val register_dynamic_directory: + ?descr:string -> + 'prefix directory -> + ('prefix, 'a) Path.path -> ('a -> 'a directory Lwt.t) -> + 'prefix directory + +(** Registring dynamic subtree. (Curryfied variant) *) +val register_dynamic_directory1: + ?descr:string -> + 'prefix directory -> + ('prefix, unit * 'a) Path.path -> + ('a -> (unit * 'a) directory Lwt.t) -> + 'prefix directory + +val register_dynamic_directory2: + ?descr:string -> + 'prefix directory -> + ('prefix, (unit * 'a) * 'b) Path.path -> + ('a -> 'b -> ((unit * 'a) * 'b) directory Lwt.t) -> + 'prefix directory + +val register_dynamic_directory3: + ?descr:string -> + 'prefix directory -> + ('prefix, ((unit * 'a) * 'b) * 'c) Path.path -> + ('a -> 'b -> 'c -> (((unit * 'a) * 'b) * 'c) directory Lwt.t) -> + 'prefix directory + +(** Registring custom directory lookup. *) +type custom_lookup = + | CustomService of Description.service_descr * + ( Data_encoding.json option -> + Data_encoding.json Answer.answer Lwt.t ) + | CustomDirectory of Description.directory_descr + +val register_custom_lookup: + ?descr:string -> + 'prefix directory -> + ('prefix, 'params) Path.path -> + ('params -> string list -> custom_lookup Lwt.t) -> + 'prefix directory + +val register_custom_lookup1: + ?descr:string -> + 'prefix directory -> + ('prefix, unit * 'a) Path.path -> + ('a -> string list -> custom_lookup Lwt.t) -> + 'prefix directory + +val register_custom_lookup2: + ?descr:string -> + 'prefix directory -> + ('prefix, (unit * 'a) * 'b) Path.path -> + ('a -> 'b -> string list -> custom_lookup Lwt.t) -> + 'prefix directory + +val register_custom_lookup3: + ?descr:string -> + 'prefix directory -> + ('prefix, ((unit * 'a) * 'b) * 'c) Path.path -> + ('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) -> + 'prefix directory + + +(** Registring a description service. *) +val register_describe_directory_service: + 'prefix directory -> + ('prefix, 'prefix, bool option, Description.directory_descr) service -> + 'prefix directory + +(** A handle on the server worker. *) +type server + +(** Promise a running RPC serve ; takes the address and port. To call + an RPX at /p/a/t/h/ in the provided service, one must call the URI + /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services + prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will + describe the input and output of the service, if it is + callable. Calling /pipe will read a sequence of services to call in + sequence from the request body, see {!pipe_encoding}. *) +val launch : string -> int -> unit directory -> server Lwt.t + +(** Kill an RPC server. *) +val shutdown : server -> unit Lwt.t + +(** Retrieve the root service of the server *) +val root_service : server -> unit directory + +(** Change the root service of the server *) +val set_root_service : server -> unit directory -> unit + +module Error : sig + val service: (unit, unit, unit, Json_schema.schema) service + val encoding: error list Data_encoding.t + val wrap: + 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding + +end diff --git a/src/node/net/netbits.ml b/src/node/net/netbits.ml new file mode 100644 index 000000000..839f7e65a --- /dev/null +++ b/src/node/net/netbits.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** The type of a single datum in a network frame. The encoding of a + datum is as follows: [[TYPE][CONTENTS]], where [[type]] is a + single byte whose value is [1] for [S], [2] for [I], [3] for [L], + [4] for B, [5] for [D], [6] for [F] and [7] for [C]. + For [S]. [I], [L] and [D]¸ the raw values are stored using big + endianness. For [B], [F] and [C], the size is prefixed as a 16-bit, + big endian, unsigned integer + ([[SIZE][BYTES]]). *) +type chunk = + | S of int (** A 16-bit integer *) + | I of int32 (** A 32-bit integer *) + | L of int64 (** A 64-bit integer *) + | B of MBytes.t (** A series of bytes *) + | D of float (** A 64-bits IEEE-754 floating point number *) + | F of frame (** An encapsulated subframe *) + | C of string (** A string *) + +(** A network frame is a list of simple data. Its encoding on the + network is as follows: [[SIZE][DATA]] where [[SIZE]] is the raw + length of [[DATA]] in bytes as a big endian, 32-bit, unsigned + integer. *) +and frame = + chunk list + +(** Pretty printing of frames for debugging *) +let rec print fmtr frame = + Format.fprintf fmtr "[@[" ; + let rec loop frame = + let sep = match frame with [ _ ] -> "" | _ -> " ;" in + match frame with + | [] -> () + | e :: tl -> + begin match e with + | S i -> Format.fprintf fmtr "@ S %i%s@," i sep + | I i -> Format.fprintf fmtr "@ I %li%s@," i sep + | L i -> Format.fprintf fmtr "@ L %Li%s@," i sep + | D i -> Format.fprintf fmtr "@ D %g%s@," i sep + | B i -> Format.fprintf fmtr "@ B %S%s@," (MBytes.to_string i) sep + | F f -> Format.fprintf fmtr "@ F %a%s@," print f sep + | C s -> Format.fprintf fmtr "@ C %s%s@," s sep + end ; + loop tl + in loop frame ; + Format.fprintf fmtr "@ @]]%!" + +(** Pretty prints of frames *) +let to_string frame = + let buf = Buffer.create 100 in + let fmtr = Format.formatter_of_buffer buf in + print fmtr frame ; + Buffer.contents buf + +module BE = EndianBigstring.BigEndian + +(** Encode a frame as raw bytes to send over the network *) +let to_raw frame = + let rec raw_size frame = + List.fold_left + (fun sz item -> sz + 1 + match item with + | S _ -> 2 + | I _ -> 4 + | L _ -> 8 + | D _ -> 8 + | F f -> raw_size f + 2 + | B str -> MBytes.length str + 2 + | C str -> String.length str + 2) + 0 frame + in + let sz = raw_size frame in + let buf = MBytes.create (sz + 4) in + let rec store items offset = match items with + | S n :: tl -> + BE.set_int8 buf offset 0x01 ; + BE.set_int16 buf (offset + 1) n ; + store tl (offset + 1 + 2) + | I n :: tl -> + BE.set_int8 buf offset 0x02 ; + BE.set_int32 buf (offset + 1) n ; + store tl (offset + 1 + 4) + | L n :: tl -> + BE.set_int8 buf offset 0x03 ; + BE.set_int64 buf (offset + 1) n ; + store tl (offset + 1 + 8) + | B n :: tl -> + BE.set_int8 buf offset 0x04 ; + let len = MBytes.length n in + BE.set_int16 buf (offset + 1) len ; + MBytes.blit n 0 buf (offset + 1 + 2) len ; + store tl (offset + 1 + 2 + len) + | D n :: tl -> + BE.set_int8 buf offset 0x05 ; + BE.set_int64 buf (offset + 1) (Int64.bits_of_float n) ; + store tl (offset + 1 + 8) + | F f :: tl -> + BE.set_int8 buf offset 0x06 ; + let len = raw_size f in + BE.set_int16 buf (offset + 1) len ; + let offset = store f (offset + 1 + 2) in + store tl offset + | C n :: tl -> + BE.set_int8 buf offset 0x07 ; + let len = String.length n in + BE.set_int16 buf (offset + 1) len ; + MBytes.blit_from_string n 0 buf (offset + 1 + 2) len ; + store tl (offset + 1 + 2 + len) + | [] -> offset + in + BE.set_int32 buf 0 (Int32.of_int sz) ; + ignore (store frame 4) ; + buf + +(** Decode a complete raw frame as read from the network *) +let of_raw buf = + let rec decode items offset stop = + let if_remains ofs sz cb = if ofs + sz <= stop then cb () else None in + if offset = stop then Some (List.rev items) + else if offset > stop then None + else + let tag = BE.get_int8 buf offset in + let offset = offset + 1 in + match tag with + | 0x01 -> + if_remains offset 2 @@ fun () -> + let items = S (BE.get_int16 buf offset) :: items in + decode items (offset + 2) stop + | 0x02 -> + if_remains offset 4 @@ fun () -> + let items = I (BE.get_int32 buf offset) :: items in + decode items (offset + 4) stop + | 0x03 -> + if_remains offset 8 @@ fun () -> + let items = L (BE.get_int64 buf offset) :: items in + decode items (offset + 8) stop + | 0x04 -> + if_remains offset 2 @@ fun () -> + let len = BE.get_int16 buf offset in + let offset = offset + 2 in + if_remains offset len @@ fun () -> + let items = B (MBytes.sub buf offset len) :: items in + decode items (offset + len) stop + | 0x05 -> + if_remains offset 8 @@ fun () -> + let items = D (Int64.float_of_bits (BE.get_int64 buf offset)) :: items in + decode items (offset + 8) stop + | 0x06 -> + if_remains offset 2 @@ fun () -> + let len = BE.get_int16 buf offset in + let offset = offset + 2 in + if_remains offset len @@ fun () -> + begin match decode [] offset (offset + len) with + | None -> None + | Some fitems -> decode ((F fitems) :: items) (offset + len) stop + end + | 0x07 -> + if_remains offset 2 @@ fun () -> + let len = BE.get_int16 buf offset in + let offset = offset + 2 in + if_remains offset len @@ fun () -> + let items = C (MBytes.substring buf offset len) :: items in + decode items (offset + len) stop + | _ -> None + in + decode [] 4 (MBytes.length buf) + +open Lwt + +(** Write a frame from to file descriptor. *) +let write descr frame = + let buf = to_raw frame in + catch + (fun () -> + Lwt_bytes.write descr buf 0 (MBytes.length buf) >>= fun _ -> + return true) + (function + | Unix.Unix_error _ -> return false + | e -> fail e) + +(** Read a frame from a file descriptor. *) +let read descr limit = + catch + (fun () -> + let szbuf = MBytes.create 4 in + Lwt_bytes.recv descr szbuf 0 4 [ Lwt_unix.MSG_PEEK ] >>= fun wsz -> + if wsz <> 4 then + return None + else + let len = Int32.to_int (BE.get_int32 szbuf 0) + 4 in + if len > limit then + return None + else + let buf = MBytes.create len in + Lwt_bytes.read descr buf 0 len >>= fun wsz -> + if wsz <> len then + return None + else + return (of_raw buf)) + (function + | Unix.Unix_error (_err, _, _) -> return None + | e -> fail e) diff --git a/src/node/net/netbits.mli b/src/node/net/netbits.mli new file mode 100644 index 000000000..b879b755a --- /dev/null +++ b/src/node/net/netbits.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** A simple, portable implementation of network frames. *) + +(** The type of a single datum in a network frame. The encoding of a + datum is as follows: [[TYPE][CONTENTS]], where [[type]] is a + single byte whose value is [1] for [S], [2] for [I], [3] for [L], + [4] for B, [5] for [D], [6] for [F] and [7] for [C]. + For [S]. [I], [L] and [D]¸ the raw values are stored using big + endianness. For [B], [F] and [C], the size is prefixed as a 16-bit, + big endian, unsigned integer + ([[SIZE][BYTES]]). *) +type chunk = + | S of int (** A 16-bit integer *) + | I of int32 (** A 32-bit integer *) + | L of int64 (** A 64-bit integer *) + | B of MBytes.t (** A series of bytes *) + | D of float (** A 64-bits IEEE-754 floating point number *) + | F of frame (** An encapsulated subframe *) + | C of string (** A string *) + +(** A network frame is a list of simple data. Its encoding on the + network is as follows: [[SIZE][DATA]] where [[SIZE]] is the raw + length of [[DATA]] in bytes as a big endian, 32-bit, unsigned + integer. *) +and frame = + chunk list + +(** Writes a frame from to file descriptor Returns [true] if + successful, [false] if an error happened, which means that the + descriptor cannot accept any more data and should be closed. *) +val write : Lwt_unix.file_descr -> frame -> bool Lwt.t + +(** Reads a frame from a file descriptor. Returns [Some frame] if + successful, [None] if an error happened, which means either that + that the descriptor cannot provide any more data or that corrupted + bytes have been received, and in any case says that the descriptor + should not be used anymore. The second parameter is the limit in + bytes of the underlying representation, including the size. [None] + is returned in case of overhead, and the bytes are not consumed + from the descriptor. *) +val read : Lwt_unix.file_descr -> int -> frame option Lwt.t + +(** Pretty printing of frames for debugging *) +val print : Format.formatter -> frame -> unit + +(** Pretty prints of frames *) +val to_string : frame -> string + +(** Encode a frame as raw bytes to send over the network *) +val to_raw : frame -> MBytes.t + +(** Decode a complete raw frame as read from the network *) +val of_raw : MBytes.t -> frame option diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml new file mode 100644 index 000000000..69c00f643 --- /dev/null +++ b/src/node/net/p2p.ml @@ -0,0 +1,1123 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module LU = Lwt_unix +module LC = Lwt_condition +open Lwt +open Lwt_utils +open Netbits +open Logging.Net + +let pp_gid ppf gid = + Format.pp_print_string ppf (Hex_encode.hex_encode gid) + +(* public types *) +type addr = Ipaddr.t +type port = int +type version = string * int * int +type limits = { + max_packet_size : int ; + peer_answer_timeout : float ; + expected_connections : int ; + min_connections : int ; + max_connections : int ; + blacklist_time : float ; +} +type config = { + incoming_port : port option ; + discovery_port : port option ; + supported_versions : version list ; + known_peers : (addr * port) list ; + peers_file : string ; + closed_network : bool ; +} + +(* the common version for a pair of peers, if any, is the maximum one, + in lexicographic order *) +let common_version la lb = + let la = List.sort (fun l r -> compare r l) la in + let lb = List.sort (fun l r -> compare r l) lb in + let rec find = function + | [], _ | _, [] -> None + | ((a :: ta) as la), ((b :: tb) as lb) -> + if a = b then Some a + else if a < b then find (ta, lb) + else find (la, tb) + in find (la, lb) + +(* The global net identificator. *) +type gid = string + +(* A net point (address x port). *) +type point = addr * port + +(* Low-level network protocol packets (internal). The protocol is + completely symmetrical and asynchronous. First both peers must + present their credentials with a [Connect] packet, then any + combination of the other packets can be received at any time. An + exception is the [Disconnect] message, which should mark the end of + transmission (and needs not being replied). The [Unkown] packet is + not a real kind of packet, it means that something indecypherable + was transmitted. *) +type packet = + | Connect of gid * int option * version list + | Disconnect + | Advertise of (addr * port) list + | Message of Netbits.frame + | Ping + | Pong + | Bootstrap + | Unknown of Netbits.frame + +(* read a packet from a TCP socket *) +let recv_packet + : LU.file_descr -> int -> packet Lwt.t + = fun socket limit -> + Netbits.read socket limit >>= function + | None -> + return Disconnect + | Some frame -> + let decode_versions msg frame cb = + let rec decode_versions acc = function + | F [ B name ; S maj ; S min ] :: rest -> + decode_versions ((MBytes.to_string name, maj, min) :: acc) rest + | [] -> cb (List.rev acc) + | _ -> return (Unknown msg) + in decode_versions [] frame + in + match frame with + | [ S 1 ] -> return Disconnect + | [ S 2 ] -> return Ping + | [ S 12 ] -> return Pong + | [ S 3 ] -> return Bootstrap + | [ S 4 ; B gid ; S port ; F rest ] as msg -> + decode_versions msg rest @@ fun versions -> + return (Connect (MBytes.to_string gid, Some port, versions)) + | [ S 4 ; B gid ; F rest ] as msg -> + decode_versions msg rest @@ fun versions -> + return (Connect (MBytes.to_string gid, None, versions)) + | [ S 5 ; F rest ] as msg -> + let rec decode_peers acc = function + | F [ B addr ; S port ] :: rest -> begin + match Ipaddr.of_string @@ MBytes.to_string addr with + | Some addr -> + decode_peers ((addr, port) :: acc) rest + | None -> + decode_peers acc rest + end + | [] -> Advertise (List.rev acc) + | _ -> Unknown msg + in return (decode_peers [] rest) + | [ S 6 ; F rest ] -> return (Message rest) + | msg -> return (Unknown msg) + +(* send a packet over a TCP socket *) +let send_packet + : LU.file_descr -> packet -> bool Lwt.t + = fun socket packet -> + let frame = match packet with + | Unknown _ -> assert false (* should never happen *) + | Disconnect -> [ S 1 ] + | Ping -> [ S 2 ] + | Pong -> [ S 12 ] + | Bootstrap -> [ S 3 ] + | Connect (gid, port, versions) -> + let rec encode = function + | (name, maj, min) :: tl -> + let rest = encode tl in + F [ B (MBytes.of_string name) ; S maj ; S min ] :: rest + | [] -> [] + in + [ S 4 ; B (MBytes.of_string gid) ] + @ (match port with | Some port -> [ S port ] | None -> []) + @ [ F (encode versions) ] + | Advertise peers -> + let rec encode = function + | (addr, port) :: tl -> + let rest = encode tl in + F [ B (MBytes.of_string @@ Ipaddr.to_string addr) ; S port ] :: rest + | [] -> [] + in [ S 5 ; F (encode peers) ] + | Message message -> [ S 6 ; F message ] in + Netbits.write socket frame + +(* A net handler, as a record-encoded object, abstract from the + outside world. Hidden Lwt workers are associated to a net at its + creation and can be killed using the shutdown callback. *) +type net = { + recv_from : unit -> (peer * Netbits.frame) Lwt.t ; + send_to : peer * Netbits.frame -> unit Lwt.t ; + push : peer * Netbits.frame -> unit ; + broadcast : Netbits.frame -> unit ; + blacklist : ?duration:float -> addr -> unit ; + whitelist : peer -> unit ; + maintain : unit -> unit Lwt.t ; + roll : unit -> unit Lwt.t ; + shutdown : unit -> unit Lwt.t ; + peers : unit -> peer list ; + peer_info : peer -> addr * port * version ; +} + +(* A peer handle, as a record-encoded object, abstract from the + outside world. A hidden Lwt worker is associated to a peer at its + creation and is killed using the disconnect callback by net + workers (on shutdown of during maintenance). *) +and peer = { + gid : gid ; + point : point ; + listening_port : port option ; + version : version ; + last_seen : unit -> float ; + disconnect : unit -> unit Lwt.t; + send : packet -> unit Lwt.t ; +} + +(* The (internal) type of network events, those dispatched from peer + workers to the net and others internal to net workers. *) +and event = + | Disconnected of peer + | Bootstrap of peer + | Recv of peer * Netbits.frame + | Peers of point list + | Contact of point * LU.file_descr + | Connected of peer + | Shutdown + +(* Run-time point-or-gid indexed storage, one point is bound to at + most one gid, which is the invariant we want to keep both for the + connected peers table and the known peers one *) +module GidMap = Map.Make (struct type t = gid let compare = compare end) +module GidSet = Set.Make (struct type t = gid let compare = compare end) +module PointMap = Map.Make (struct type t = point let compare = compare end) +module PointSet = Set.Make (struct type t = point let compare = compare end) +module PeerMap : sig + type 'a t + val empty : 'a t + val by_point : point -> 'a t -> 'a + val by_gid : gid -> 'a t -> 'a + val gid_by_point : point -> 'a t -> gid option + val point_by_gid : gid -> 'a t -> point + val mem_by_point : point -> 'a t -> bool + val mem_by_gid : gid -> 'a t -> bool + val remove_by_point : point -> 'a t -> 'a t + val remove_by_gid : gid -> 'a t -> 'a t + val update : point -> ?gid : gid -> 'a -> 'a t -> 'a t + val fold : (point -> gid option -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val iter : (point -> gid option -> 'a -> unit) -> 'a t -> unit + val bindings : 'a t -> (point * gid option * 'a) list + val cardinal : 'a t -> int +end = struct + type 'a t = + { by_point : (gid option * 'a) PointMap.t ; + by_gid : (point * 'a) GidMap.t } + + let empty = + { by_point = PointMap.empty ; + by_gid = GidMap.empty } + + let by_point point { by_point } = + let (_, v) = PointMap.find point by_point in v + + let by_gid gid { by_gid } = + let (_, v) = GidMap.find gid by_gid in v + + let gid_by_point point { by_point } = + let (gid, _) = PointMap.find point by_point in gid + + let point_by_gid gid { by_gid } = + let (point, _) = GidMap.find gid by_gid in point + + let mem_by_point point { by_point } = + PointMap.mem point by_point + + let mem_by_gid gid { by_gid } = + GidMap.mem gid by_gid + + let remove_by_point point ({ by_point ; by_gid } as map) = + try + let (gid, v) = PointMap.find point by_point in + { by_point = PointMap.remove point by_point ; + by_gid = match gid with + | None -> by_gid + | Some gid -> GidMap.remove gid by_gid } + with Not_found -> map + + let remove_by_gid gid ({ by_point ; by_gid } as map) = + try + let (point, _) = GidMap.find gid by_gid in + { by_point = PointMap.remove point by_point ; + by_gid = GidMap.remove gid by_gid } + with Not_found -> map + + let update point ?gid v map = + let { by_point ; by_gid } = + let map = remove_by_point point map in + match gid with Some gid -> remove_by_gid gid map | None -> map in + { by_point = PointMap.add point (gid, v) by_point ; + by_gid = match gid with Some gid -> GidMap.add gid (point, v) by_gid + | None -> by_gid } + + let fold f { by_point } init = + PointMap.fold + (fun point (gid, v) r -> f point gid v r) by_point init + + let iter f { by_point } = + PointMap.iter + (fun point (gid, v) -> f point gid v) by_point + + let cardinal { by_point } = + PointMap.cardinal by_point + + let bindings map = + fold (fun point gid v l -> (point, gid, v) :: l) map [] +end + +(* Builds a peer and launches its associated worker. Takes a push + function for communicating with the main worker using events + (including the one sent when the connection is alive). Returns a + canceler. *) +let connect_to_peer config limits my_gid socket (addr, port) push white_listed = + (* a non exception-based cancelation mechanism *) + let cancelation, cancel, on_cancel = canceler () in + (* a cancelable reception *) + let recv () = + pick [ recv_packet socket limits.max_packet_size ; + (cancelation () >>= fun () -> return Disconnect) ] in + (* First step: send and receive credentials, makes no difference + whether we're trying to connect to a peer or checking an incoming + connection, both parties must first present themselves. *) + let rec connect () = + send_packet socket (Connect (my_gid, + config.incoming_port, + config.supported_versions)) >>= fun _ -> + pick [ (LU.sleep limits.peer_answer_timeout >>= fun () -> return Disconnect) ; + recv () ] >>= function + | Connect (gid, listening_port, versions) -> + debug "(%a) connection requested from %a @ %a:%d" + pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; + begin match common_version config.supported_versions versions with + | None -> + debug "(%a) connection rejected (incompatible versions) from %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + cancel () + | Some version -> + if config.closed_network then + match listening_port with + | Some port when white_listed (addr, port) -> + connected version gid listening_port + | Some port -> + debug "(%a) connection rejected (out of the closed network) from %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + cancel () + | None -> + debug "(%a) connection rejected (out of the closed network) from %a:unknown" + pp_gid my_gid Ipaddr.pp_hum addr ; + cancel () + else + connected version gid listening_port + end + | Advertise peers -> + (* alternatively, one can refuse a connection but reply with + some peers, so we accept this info *) + debug "(%a) new peers received from %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + push (Peers peers) ; + cancel () + | Disconnect -> + debug "(%a) connection rejected (closed by peer or timeout) from %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + cancel () + | _ -> + debug "(%a) connection rejected (bad connection request) from %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + cancel () + (* Them we can build the net object and launch the worker. *) + and connected version gid listening_port = + (* net object state *) + let last = ref (Unix.gettimeofday ()) in + (* net object callbaks *) + let last_seen () = !last in + let disconnect () = cancel () in + let send p = send_packet socket p >>= fun _ -> return () in + (* net object construction *) + let peer = { gid ; point = (addr, port) ; listening_port ; + version ; last_seen ; disconnect ; send } in + (* The packet reception loop. *) + let rec receiver () = + recv () >>= fun packet -> + last := Unix.gettimeofday () ; + match packet with + | Connect _ + | Unknown _ -> + debug "(%a) disconnected (bad request) %a @ %a:%d" + pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; + cancel () + | Disconnect -> + debug "(%a) disconnected (by peer) %a @ %a:%d" + pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; + cancel () + | Bootstrap -> push (Bootstrap peer) ; receiver () + | Advertise peers -> push (Peers peers) ; receiver () + | Ping -> send_packet socket Pong >>= fun _ -> receiver () + | Pong -> receiver () + | Message msg -> + push (Recv (peer, msg)) ; receiver () + in + (* The polling loop *) + let rec pulse_monitor ping = + pick [ (cancelation () >>= fun () -> return false) ; + (LU.sleep limits.peer_answer_timeout >>= fun () -> return true)] + >>= fun continue -> + if continue then + match ping with + | Some tping -> + if !last -. tping < 0. then begin + debug "(%a) disconnected (timeout exceeded) %a @ %a:%d" + pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; + cancel () + end else + pulse_monitor None + | None -> + let now = Unix.gettimeofday () in + if now -. !last < limits.peer_answer_timeout then + pulse_monitor None + else + send_packet socket Ping >>= fun _ -> + pulse_monitor (Some (Unix.gettimeofday ())) + else return () + in + (* Events for the main worker *) + push (Connected peer) ; + on_cancel (fun () -> push (Disconnected peer) ; return ()) ; + (* Launch both workers *) + join [ pulse_monitor None ; receiver () ] + in + on_cancel (fun () -> + send_packet socket Disconnect >>= fun _ -> + LU.close socket >>= fun _ -> + return ()) ; + let worker_name = + Format.asprintf + "(%a) connection handler for %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port in + ignore (worker worker_name connect cancel) ; + (* return the canceler *) + cancel + + +(* JSON format for on-disk peers cache file *) +let addr_encoding = + let open Data_encoding in + splitted + ~json: + (conv Ipaddr.to_string (Data_encoding.Json.wrap_error Ipaddr.of_string_exn) string) + ~binary: + (union ~tag_size:`Int8 + [ case ~tag:4 + (Fixed.string 4) + (fun ip -> Utils.map_option Ipaddr.V4.to_bytes (Ipaddr.to_v4 ip) ) + (fun b -> Ipaddr.(V4 (V4.of_bytes_exn b))) ; + case ~tag:6 + (Fixed.string 32) + (fun ip -> Some (Ipaddr.V6.to_bytes (Ipaddr.to_v6 ip))) + (fun b -> Ipaddr.(V6 (V6.of_bytes_exn b))) ; + ]) + +let peers_file_encoding = + let open Data_encoding in + obj2 + (req "gid" string) + (req "peers" + (obj3 + (req "known" + (list (obj3 + (req "addr" addr_encoding) + (req "port" int31) + (opt "infos" + (obj3 + (req "connections" int31) + (req "lastSeen" float) + (req "gid" string)))))) + (req "blacklisted" + (list (obj2 + (req "addr" addr_encoding) + (req "until" float)))) + (req "whitelisted" + (list (obj2 + (req "addr" addr_encoding) + (req "port" int31)))))) + +(* Info on peers maintained between connections *) +type source = + { unreachable_since : float option; + connections : (int * float) option ; + white_listed : bool } + +(* Ad hoc comparison on sources such as good source < bad source *) +let compare_sources s1 s2 = + match s1.white_listed, s2.white_listed with + | true, false -> -1 | false, true -> 1 + | _, _ -> + match s1.unreachable_since, s2.unreachable_since with + | None, Some _ -> -1 | Some _, None -> 1 + | _, _ -> + match s1.connections, s2.connections with + | Some _, None -> -1 | None, Some _ -> 1 | None, None -> 0 + | Some (n1, t1), Some (n2, t2) -> + if n1 = n2 then compare t2 t1 + else compare n2 n1 + +(* A store for blacklisted addresses (we ban any peer on a blacklisted + address, which is the policy that seems to make the most sense) *) +module BlackList = Map.Make (struct type t = addr let compare = compare end) + +(* A good random string so it is probably unique on the network *) +let fresh_gid () = + Bytes.to_string @@ Sodium.Random.Bytes.generate 16 + + +(* The (fixed size) broadcast frame. *) +let discovery_message gid port = + Netbits.([ B (MBytes.of_string "DISCO") ; B (MBytes.of_string gid) ; S port ]) + +(* Broadcast frame verifier. *) +let answerable_discovery_message message my_gid when_ok when_not = + match message with + | Some [ B magic ; B gid ; S port ] -> + if MBytes.to_string magic = "DISCO" && MBytes.to_string gid <> my_gid then + when_ok gid port + else when_not () + | _ -> when_not () + +(* Launch an answer machine for the discovery mechanism, takes a + callback to fill the answers and returns a canceler function *) +let discovery_answerer config limits my_gid disco_port cancelation callback = + (* init a UDP listening socket on the broadcast canal *) + catch + (fun () -> + let main_socket = LU.(socket PF_INET SOCK_DGRAM 0) in + LU.(setsockopt main_socket SO_BROADCAST true) ; + LU.(setsockopt main_socket SO_REUSEADDR true) ; + LU.(bind main_socket (ADDR_INET (Unix.inet_addr_any, disco_port))) ; + return (Some main_socket)) + (fun exn -> return None) >>= function + | None -> + debug "(%a) will not listen to discovery requests (port taken or closed)" + pp_gid my_gid ; + return () + | Some main_socket -> + (* the answering function *) + let rec step () = + let buffer = Netbits.to_raw (discovery_message my_gid 0) in + let len = MBytes.length buffer in + pick [ (cancelation () >>= fun () -> return None) ; + (Lwt_bytes.recvfrom main_socket buffer 0 len [] >>= fun r -> + return (Some r)) ] >>= function + | Some (len, LU.ADDR_INET (addr, _)) -> + if len <> len then + step () (* drop bytes, better luck next time ! *) + else + answerable_discovery_message (Netbits.of_raw buffer) my_gid + (fun gid port -> + catch + (fun () -> + let socket = LU.(socket PF_INET SOCK_STREAM 0) in + LU.connect socket LU.(ADDR_INET (addr, port)) >>= fun () -> + let addr = Ipaddr_unix.of_inet_addr addr in + callback addr port socket >>= fun () -> + return ()) + (fun _ -> (* ignore errors *) return ()) >>= fun () -> + step ()) + step + | Some (_, _) -> + step () + | None -> return () + in step () + +(* Sends dicover messages into space in an exponentially delayed loop, + restartable using a condition *) +let discovery_sender config limits my_gid disco_port inco_port cancelation restart = + let message = discovery_message my_gid inco_port in + let rec loop delay n = + catch + (fun () -> + let socket = LU.(socket PF_INET SOCK_DGRAM 0) in + LU.setsockopt socket LU.SO_BROADCAST true ; + LU.connect socket LU.(ADDR_INET (Unix.inet_addr_any, disco_port)) >>= fun () -> + Netbits.(write socket message) >>= fun _ -> + LU.close socket) + (fun _ -> + debug "(%a) error broadcasting a discovery request" pp_gid my_gid ; + return ()) >>= fun () -> + pick [ (LU.sleep delay >>= fun () -> return (Some (delay, n + 1))) ; + (cancelation () >>= fun () -> return None) ; + (LC.wait restart >>= fun () -> return (Some (0.1, 0))) ] >>= function + | Some (delay, n) when n = 10 -> + loop delay 9 + | Some (delay, n) -> + loop (delay *. 2.) n + | None -> return () + in loop 0.2 1 + +(* Main network creation and initialisation function *) +let bootstrap config limits = + (* we need to ignore SIGPIPEs *) + Sys.(set_signal sigpipe Signal_ignore) ; + (* a non exception-based cancelation mechanism *) + let cancelation, cancel, on_cancel = canceler () in + (* create the internal event queue *) + let enqueue_event, dequeue_event = + let queue, enqueue = Lwt_stream.create () in + (fun msg -> enqueue (Some msg)), + (fun () -> Lwt_stream.next queue) + in + (* create the external message queue *) + let enqueue_msg, dequeue_msg, close_msg_queue = + let queue, enqueue = Lwt_stream.create () in + (fun msg -> enqueue (Some msg)), + (fun () -> Lwt_stream.next queue), + (fun () -> enqueue None) + in + on_cancel (fun () -> close_msg_queue () ; return ()) ; + (* fill the known peers pools from last time *) + Data_encoding.Json.read_file config.peers_file >>= fun res -> + let known_peers, black_list, my_gid = + let init_peers () = + let my_gid = + fresh_gid () in + let known_peers = + let source = + { unreachable_since = None ; + connections = None ; + white_listed = true } in + List.fold_left + (fun r point -> PeerMap.update point source r) + PeerMap.empty config.known_peers in + let black_list = + BlackList.empty in + known_peers, black_list, my_gid in + match res with + | None -> + let known_peers, black_list, my_gid = init_peers () in + debug "(%a) peer cache initiated" pp_gid my_gid ; + ref known_peers, ref black_list, my_gid + | Some json -> + match Data_encoding.Json.destruct peers_file_encoding json with + | exception _ -> + let known_peers, black_list, my_gid = init_peers () in + debug "(%a) peer cache reset" pp_gid my_gid ; + ref known_peers, ref black_list, my_gid + | (my_gid, (k, b, w)) -> + let white_list = + List.fold_right PointSet.add w PointSet.empty in + let known_peers = + List.fold_left + (fun r (addr, port, infos) -> + match infos with + | None -> + let source = + { unreachable_since = None ; + connections = None ; + white_listed = true } in + PeerMap.update (addr, port) source r + | Some (c, t, gid) -> + let source = + { unreachable_since = None ; + connections = Some (c, t) ; + white_listed = PointSet.mem (addr, port) white_list } in + PeerMap.update (addr, port) ~gid source r) + PeerMap.empty k in + let black_list = + List.fold_left + (fun r (a, d) -> BlackList.add a d r) + BlackList.empty b in + debug "(%a) peer cache loaded" pp_gid my_gid ; + ref known_peers, ref black_list, my_gid + in + (* some peer reachability predicates *) + let black_listed (addr, _) = + BlackList.mem addr !black_list in + let white_listed point = + try (PeerMap.by_point point !known_peers).white_listed + with Not_found -> false in + let grey_listed point = + try match (PeerMap.by_point point !known_peers).unreachable_since with + | None -> false | Some t -> Unix.gettimeofday () -. t > 5. + with Not_found -> false in + (* save the cache at exit *) + on_cancel (fun () -> + (* save the known peers cache *) + let json = + Data_encoding.Json.construct peers_file_encoding @@ + (my_gid, + PeerMap.fold + (fun (addr, port) gid source (k, b, w) -> + let infos = match gid, source.connections with + | Some gid, Some (n, t) -> Some (n, t, gid) + | _ -> None in + ((addr, port, infos) :: k, + b, + if source.white_listed then (addr, port) :: w else w)) + !known_peers ([], BlackList.bindings !black_list, [])) + in + Data_encoding.Json.write_file config.peers_file json >>= fun _ -> + debug "(%a) peer cache saved" pp_gid my_gid ; + return ()) ; + (* storage of active and not yet active peers *) + let incoming = ref PointMap.empty in + let connected = ref PeerMap.empty in + (* peer welcoming (accept) loop *) + let welcome () = + match config.incoming_port with + | None -> (* no input port => no welcome worker *) return () + | Some port -> + (* open port for incoming connexions *) + let addr = Unix.inet_addr_any in + catch + (fun () -> + let main_socket = LU.(socket PF_INET SOCK_STREAM 0) in + LU.(setsockopt main_socket SO_REUSEADDR true) ; + LU.(bind main_socket (ADDR_INET (addr, port))) ; + LU.listen main_socket limits.max_connections ; + return (Some main_socket)) + (fun exn -> + debug "(%a) cannot accept incoming peers (port taken or closed)" + pp_gid my_gid ; + return None)>>= function + | None -> + (* FIXME: run in degraded mode, better exit ? *) + return () + | Some main_socket -> + (* then loop *) + let rec step () = + pick [ (LU.accept main_socket >>= fun (s, a) -> return (Some (s, a))) ; + (cancelation () >>= fun _ -> return None) ] >>= function + | None -> + LU.close main_socket + | Some (socket, addr) -> + match addr with + | LU.ADDR_INET (addr, port) -> + let addr = Ipaddr_unix.of_inet_addr addr in + enqueue_event (Contact ((addr, port), socket)) ; + step () + | _ -> + Lwt.async (fun () -> LU.close socket) ; + step () + in step () + in + (* input maintenance events *) + let too_many_peers = LC.create () in + let too_few_peers = LC.create () in + let new_peer = LC.create () in + let new_contact = LC.create () in + let please_maintain = LC.create () in + let restart_discovery = LC.create () in + (* output maintenance events *) + let just_maintained = LC.create () in + (* maintenance worker, returns when [connections] peers are connected *) + let rec maintenance () = + pick [ (LU.sleep 120. >>= fun () -> return true) ; (* every two minutes *) + (LC.wait please_maintain >>= fun () -> return true) ; (* when asked *) + (LC.wait too_few_peers >>= fun () -> return true) ; (* limits *) + (LC.wait too_many_peers >>= fun () -> return true) ; + (cancelation () >>= fun () -> return false) ] >>= fun continue -> + let rec maintain () = + let n_connected = PeerMap.cardinal !connected in + if n_connected >= limits.expected_connections + && n_connected <= limits.max_connections then + (* end of maintenance when enough users have been reached *) + (LC.broadcast just_maintained () ; + debug "(%a) maintenance step ended" + pp_gid my_gid ; + maintenance ()) + else if n_connected < limits.expected_connections then + (* too few peers, try and contact many peers *) + let contact nb = + let contactable = + (* we sort sources by level (prefered first) *) + PeerMap.bindings !known_peers |> + List.sort (fun (_, _, s1) (_, _, s2) -> compare_sources s1 s2) |> + (* remove the ones we're connect(ed/ing) to and the blacklisted *) + List.filter (fun (point, gid, source) -> + (not (black_listed point) || source.white_listed) + && not (grey_listed point) + && not (gid = Some my_gid) + && not (PeerMap.mem_by_point point !connected) + && not (PointMap.mem point !incoming) + && match gid with | None -> true | Some gid -> + not (PeerMap.mem_by_gid gid !connected)) in + let rec do_contact_loop strec = + match strec with + | 0, _ -> return true + | _, [] -> return false (* we didn't manage to contact enough peers *) + | nb, ((addr, port), gid, source) :: tl -> + (* we try to open a connection *) + let socket = LU.(socket PF_INET SOCK_STREAM 0) in + let uaddr = Ipaddr_unix.to_inet_addr addr in + catch + (fun () -> + lwt_debug "Trying connection to %a:%d" + Ipaddr.pp_hum addr port >>= fun () -> + Lwt.pick + [ (Lwt_unix.sleep 2.0 >>= fun _ -> Lwt.fail Not_found) ; + LU.connect socket (LU.ADDR_INET (uaddr, port)) + ] >>= fun () -> + lwt_debug "Connected to %a:%d" + Ipaddr.pp_hum addr port >>= fun () -> + enqueue_event (Contact ((addr, port), socket)) ; + return (nb - 1)) + (fun e -> + lwt_debug "Connection failed to %a:%d" + Ipaddr.pp_hum addr port >>= fun () -> + (* if we didn't succes, we greylist it *) + let now = Unix.gettimeofday () in + known_peers := + PeerMap.update (addr, port) ?gid + { source with unreachable_since = Some now } + !known_peers ; + LU.close socket >>= fun () -> + return nb) >>= fun nrec -> + do_contact_loop (nrec, tl) + in do_contact_loop (nb, contactable) + in + let to_contact = limits.max_connections - n_connected in + debug "(%a) too few connections (%d)" pp_gid my_gid n_connected ; + contact to_contact >>= function + | true -> (* enough contacts, now wait for connections *) + pick [ (LC.wait new_peer >>= fun _ -> return true) ; + (LU.sleep 1.0 >>= fun () -> return true) ; + (cancelation () >>= fun () -> return false) ] >>= fun continue -> + if continue then maintain () else return () + | false -> (* not enough contacts, ask the pals of our pals, + discover the local network and then wait *) + LC.broadcast restart_discovery () ; + (PeerMap.iter + (fun _ _ peer -> Lwt.async (fun () -> peer.send Bootstrap)) + !connected ; + pick [ (LC.wait new_peer >>= fun _ -> return true) ; + (LC.wait new_contact >>= fun _ -> return true) ; + (LU.sleep 1.0 >>= fun () -> return true) ; + (cancelation () >>= fun () -> return false) ] >>= fun continue -> + if continue then maintain () else return ()) + else + (* too many peers, start the russian roulette *) + let to_kill = n_connected - limits.max_connections in + debug "(%a) too many connections, will kill %d" pp_gid my_gid to_kill ; + snd (PeerMap.fold + (fun lid _ peer (i, t) -> + if i = 0 then (0, t) + else (i - 1, t >>= fun () -> peer.disconnect ())) + !connected (to_kill, return ())) >>= fun () -> + (* and directly skip to the next maintenance request *) + LC.broadcast just_maintained () ; + debug "(%a) maintenance step ended" pp_gid my_gid ; + maintenance () + in + if continue then maintain () else return () + in + (* select the peers to send on a bootstrap request *) + let bootstrap_peers () = + (* we sort peers by desirability *) + PeerMap.bindings !known_peers |> + List.filter (fun ((ip,_),_,_) -> not (Ipaddr.is_private ip)) |> + List.sort (fun (_, _, s1) (_, _, s2) -> compare_sources s1 s2) |> + (* HERE *) + (* we simply send the first 50 (or less) known peers *) + List.fold_left + (fun (n, l) (point, _, _) -> if n = 0 then (n, l) else (n - 1, point :: l)) + (50, []) |> snd + in + (* main internal event handling worker *) + let rec main () = + pick [ dequeue_event () ; + cancelation () >>= fun () -> return Shutdown ] >>= fun event -> + match event with + | Disconnected peer -> + debug "(%a) disconnected peer %a" pp_gid my_gid pp_gid peer.gid ; + (* remove it from the tables *) + connected := PeerMap.remove_by_point peer.point !connected ; + if PeerMap.cardinal !connected < limits.min_connections then + LC.broadcast too_few_peers () ; + incoming := PointMap.remove peer.point !incoming ; + main () + | Connected peer -> + incoming := PointMap.remove peer.point !incoming ; + let update_infos () = + (* we update our knowledge table according to the + reachable address given by the peer *) + match peer.listening_port with + | None -> () + | Some port -> + let point = (fst peer.point, port) in + let update source = + (* delete previous infos about this address / gid *) + known_peers := PeerMap.remove_by_point point !known_peers ; + known_peers := PeerMap.remove_by_gid peer.gid !known_peers ; + (* then assign *) + known_peers := PeerMap.update point ~gid:peer.gid source !known_peers + in update @@ + try match PeerMap.by_gid peer.gid !known_peers with + | { connections = None ; white_listed } -> + { connections = Some (1, Unix.gettimeofday ()) ; + unreachable_since = None ; + white_listed } + | { connections = Some (n, _) ; white_listed } -> + { connections = Some (n + 1, Unix.gettimeofday ()) ; + unreachable_since = None ; + white_listed} + with Not_found -> + { connections = Some (1, Unix.gettimeofday ()) ; + unreachable_since = None ; + white_listed = white_listed point } + in + (* if it's me, it's probably not me *) + if my_gid = peer.gid then begin + debug "(%a) rejected myself from %a:%d" + pp_gid my_gid Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; + (* now that I know my address, I can save this info to + prevent future reconnections to myself *) + update_infos () ; + Lwt.async peer.disconnect + end + (* keep only one connection to each node by checking its gid *) + else if PeerMap.mem_by_gid peer.gid !connected then begin + debug "(%a) rejected already connected peer %a @ %a:%d" + pp_gid my_gid pp_gid peer.gid + Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; + update_infos () ; + Lwt.async peer.disconnect + end else begin + debug "(%a) connected peer %a @ %a:%d" + pp_gid my_gid pp_gid peer.gid + Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; + update_infos () ; + connected := + PeerMap.update peer.point ~gid:peer.gid peer !connected ; + if PeerMap.cardinal !connected > limits.max_connections then + LC.broadcast too_many_peers () ; + LC.broadcast new_peer peer + end ; + main () + | Contact ((addr, port), socket) -> + (* we do not check the credentials at this stage, since they + could change from one connection to the next *) + if PointMap.mem (addr, port) !incoming + || PeerMap.mem_by_point (addr, port) !connected + || BlackList.mem addr !black_list then + LU.close socket >>= fun () -> + main () + else + let canceler = + connect_to_peer config limits my_gid socket (addr, port) enqueue_event white_listed in + debug "(%a) incoming peer at %a:%d" + pp_gid my_gid Ipaddr.pp_hum addr port ; + incoming := PointMap.add (addr, port) canceler !incoming ; + main () + | Bootstrap peer -> + let sample = bootstrap_peers () in + Lwt.async (fun () -> peer.send (Advertise sample)) ; + main () + | Recv (peer, message) -> + enqueue_msg (peer, message) ; + main () + | Peers peers -> + List.iter + (fun point -> + if not (PeerMap.mem_by_point point !known_peers) then + let source = + { unreachable_since = None ; + connections = None ; + white_listed = false } in + known_peers := PeerMap.update point source !known_peers ; + LC.broadcast new_contact point) + peers ; + main () + | Shutdown -> + return () + in + (* blacklist filter *) + let rec unblock () = + pick [ (Lwt_unix.sleep 20. >>= fun _ -> return true) ; + (cancelation () >>= fun () -> return false) ] >>= fun continue -> + if continue then + let now = Unix.gettimeofday () in + black_list := BlackList.fold + (fun addr d map -> if d < now then map else BlackList.add addr d map) + !black_list BlackList.empty ; + known_peers := + PeerMap.fold (fun point gid source map -> + let source = + match source.unreachable_since with + | Some t when now -. t < 20. -> source + | _ -> { source with unreachable_since = None } in + PeerMap.update point ?gid source map) + !known_peers PeerMap.empty ; + unblock () + else return () + in + (* launch all workers *) + let welcome = worker (Format.asprintf "(%a) welcome" pp_gid my_gid) welcome cancel in + let maintenance = worker (Format.asprintf "(%a) maintenance" pp_gid my_gid) maintenance cancel in + let main = worker (Format.asprintf "(%a) reception" pp_gid my_gid) main cancel in + let unblock = worker (Format.asprintf "(%a) unblacklister" pp_gid my_gid) unblock cancel in + let discovery_answerer = + match config.discovery_port with + | Some disco_port -> + let answerer () = + discovery_answerer config limits my_gid disco_port cancelation @@ fun addr port socket -> + (* do not reply to ourselves or conncted peers *) + if not (PeerMap.mem_by_point (addr, port) !connected) + && (try match PeerMap.gid_by_point (addr, port) !known_peers with + | Some gid -> not (PeerMap.mem_by_gid gid !connected) + && not (my_gid = gid) + | None -> true with Not_found -> true) then + (* either reply by a list of peer or connect if we need peers *) + if PeerMap.cardinal !connected >= limits.expected_connections then begin + enqueue_event (Peers [ addr, port ]) ; + send_packet socket (Advertise (bootstrap_peers ())) >>= fun _ -> + LU.close socket + end else begin + enqueue_event (Contact ((addr, port), socket)) ; + return () + end + else LU.close socket in + worker (Format.asprintf "(%a) discovery answerer" pp_gid my_gid) answerer cancel + | _ -> return () in + let discovery_sender = + match config.incoming_port, config.discovery_port with + | Some inco_port, Some disco_port -> + let sender () = + discovery_sender config limits my_gid disco_port inco_port cancelation restart_discovery in + worker (Format.asprintf "(%a) discovery sender" pp_gid my_gid) sender cancel + | _ -> return () in + (* net manipulation callbacks *) + let rec shutdown () = + debug "(%a) starting network shutdown" pp_gid my_gid ; + (* stop accepting clients *) + cancel () >>= fun () -> + (* wait for both workers to end *) + join [ welcome ; main ; maintenance ; unblock ; + discovery_answerer ; discovery_sender ] >>= fun () -> + (* properly shutdown all peers *) + let cancelers = + PeerMap.fold + (fun point _ peer res -> + (peer.disconnect () >>= fun () -> + connected := PeerMap.remove_by_point point !connected ; + return ()) :: res) + !connected @@ + PointMap.fold + (fun point canceler res -> + (canceler () >>= fun () -> + incoming := PointMap.remove point !incoming ; + return ()) :: res) + !incoming @@ [] + in + join cancelers >>= fun () -> + debug "(%a) network shutdown complete" pp_gid my_gid ; + return () + and peers () = + PeerMap.fold (fun _ _ peer r -> peer :: r) !connected [] + and peer_info peer = + fst peer.point, snd peer.point, peer.version + and recv_from () = + dequeue_msg () + and send_to (peer, msg) = + peer.send (Message msg) >>= fun _ -> return () + and push (peer, msg) = + Lwt.async (fun () -> peer.send (Message msg)) + and broadcast msg = + PeerMap.iter + (fun _ _ peer -> + Lwt.async (fun () -> peer.send (Message msg))) + !connected + and blacklist ?(duration = limits.blacklist_time) addr = + let t = Unix.gettimeofday () +. duration in + black_list := BlackList.add addr t !black_list ; + debug "(%a) address %a blacklisted" pp_gid my_gid Ipaddr.pp_hum addr ; + (* we ban this peer, but also all the ones at this address, even + when whitelisted (the blacklist operation wins) *) + known_peers := + PeerMap.fold + (fun ((a, _) as point) gid p map -> + if a = addr then map else PeerMap.update point ?gid p map) + !known_peers PeerMap.empty ; + (* we disconnect all peers at this address sur-le-champ *) + PeerMap.iter + (fun (a, _) _ p -> if addr = a then + Lwt.async (fun () -> p.disconnect ())) + !connected ; + (* and prevent incoming connections *) + PointMap.iter + (fun (a, _) cancel -> if a = addr then Lwt.async cancel) + !incoming + + and whitelist_point point = + let source, gid = try + { (PeerMap.by_point point !known_peers) + with white_listed = true }, + PeerMap.gid_by_point point !known_peers + with Not_found -> + { unreachable_since = None ; + connections = None ; + white_listed = true }, + None in + known_peers := PeerMap.update point ?gid source !known_peers + and whitelist peer = + (* we promote this peer to the white list, if reachable *) + match peer.listening_port with + | Some port -> + let point = fst peer.point, port in + whitelist_point point + | None -> () + + and maintain () = + let waiter = LC.wait just_maintained in + LC.broadcast please_maintain () ; + waiter + and roll () = Pervasives.failwith "roll" + in + let net = { shutdown ; peers ; recv_from ; send_to ; push ; broadcast ; + blacklist ; whitelist ; maintain ; roll ; peer_info } in + (* main thread, returns after first successful maintenance *) + maintain () >>= fun () -> + debug "(%a) network succesfully bootstrapped" pp_gid my_gid ; + return net + +let faked_network = + let infinity, wakeup = Lwt.wait () in + let shutdown () = + Lwt.wakeup_exn wakeup Lwt_stream.Empty; + Lwt.return_unit in + let peers () = [] in + let recv_from () = infinity in + let send_to _ = Lwt.return_unit in + let push _ = () in + let broadcast _ = () in + let blacklist ?duration _ = () in + let whitelist _ = () in + let maintain () = Lwt.return_unit in + let roll () = Lwt.return_unit in + let peer_info _ = assert false in + { shutdown ; peers ; recv_from ; send_to ; push ; broadcast ; + blacklist ; whitelist ; maintain ; roll ; peer_info } + + +(* Plug toplevel functions to callback calls. *) +let shutdown net = net.shutdown () +let peers net = net.peers () +let peer_info peer net = net.peer_info peer +let recv net = net.recv_from () +let send (peer, msg) net = net.send_to (peer, msg) +let push peer net = net.push peer +let broadcast msg net = net.broadcast msg +let maintain net = net.maintain () +let roll net = net.roll () +let blacklist ?duration peer net = net.blacklist ?duration peer +let whitelist peer net = net.whitelist peer diff --git a/src/node/net/p2p.mli b/src/node/net/p2p.mli new file mode 100644 index 000000000..fcebfaafd --- /dev/null +++ b/src/node/net/p2p.mli @@ -0,0 +1,102 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** A P2P network *) +type net + +(** A faked p2p layer, which do not initiate any connection + nor open any listening socket. *) +val faked_network : net + +(** A peer connection address *) +type addr = Ipaddr.t + +(** A peer connection port *) +type port = int + +(** A protocol version tag: (name, major, minor) *) +type version = string * int * int + +(** Network configuration *) +type config = { + (** Tells if incoming connections accepted, precising the TCP port + on which the peer can be reached *) + incoming_port : port option ; + (** Tells if peers should be discovered automatically on the local + network, precising the UDP port to use *) + discovery_port : port option ; + (** High level protocol(s) talked by the peer. When two peers + initiate a connection, they exchange their list of supported + versions. The chosen one, if any, is the maximum common one (in + lexicographic order) *) + supported_versions : version list ; + (** List of hard-coded known peers to bootstrap the network from *) + known_peers : (addr * port) list ; + (** The path to the JSON file where the peer cache is loaded / stored *) + peers_file : string ; + (** If [true], the only accepted connections are from peers whose + addresses are in [known_peers] *) + closed_network : bool ; +} + +(** Network capacities *) +type limits = { + (** Maximum length in bytes of network frames *) + max_packet_size : int ; + (** Delay after which a non responding peer is considered dead *) + peer_answer_timeout : float ; + (** Minimum number of connections to reach when staring / maitening *) + expected_connections : int ; + (** Strict minimum number of connections (triggers an urgent maintenance) *) + min_connections : int ; + (** Maximum number of connections (exceeding peers are disconnected) *) + max_connections : int ; + (** How long peers can be blacklisted for maintenance *) + blacklist_time : float ; +} + +(** Main network initialisation function *) +val bootstrap : config -> limits -> net Lwt.t + +(** A maintenance operation : try and reach the ideal number of peers *) +val maintain : net -> unit Lwt.t + +(** Voluntarily drop some peers and replace them by new buddies *) +val roll : net -> unit Lwt.t + +(** Close all connections properly *) +val shutdown : net -> unit Lwt.t + +(** A connection to a peer *) +type peer + +(** Access the domain of active peers *) +val peers : net -> peer list + +(** Access the info of an active peer, if available *) +val peer_info : peer -> net -> addr * port * version + +(** Wait for a Netbits.frame from any peer in the network *) +val recv : net -> (peer * Netbits.frame) Lwt.t + +(** Send a Netbits.frame to a peer and wait for it to be in the tube *) +val send : peer * Netbits.frame -> net -> unit Lwt.t + +(** Send a Netbits.frame to a peer asynchronously *) +val push : peer * Netbits.frame -> net -> unit + +(** Send a Netbits.frame to all peers *) +val broadcast : Netbits.frame -> net -> unit + +(** Shutdown the connection to all peers at this address and stop the + communications with this machine for [duration] seconds *) +val blacklist : ?duration:float -> addr -> net -> unit + +(** Keep a connection to this pair as often as possible *) +val whitelist : peer -> net -> unit diff --git a/src/node/shell/discoverer.ml b/src/node/shell/discoverer.ml new file mode 100644 index 000000000..a210b6508 --- /dev/null +++ b/src/node/shell/discoverer.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type worker = { + shutdown: unit -> unit Lwt.t; +} + +let create_worker p2p state = + + let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in + + let broadcast m = P2p.broadcast (Messages.to_frame m) p2p in + + let discovery_worker = + let rec worker_loop () = + let nets = State.Net.active state in + Lwt_list.iter_p + (fun net -> + State.Net.Blockchain.head net >>= fun head -> + State.Valid_block.block_locator state 50 head >>= fun locator -> + broadcast Messages.(Discover_blocks (State.Net.id net, locator)) ; + broadcast Messages.(Current_operations (State.Net.id net)) ; + Lwt.return_unit) + nets >>= fun () -> + let timeout = 15. +. Random.float 15. in + Lwt.pick [(Lwt_unix.sleep timeout >|= fun () -> `Process); + (cancelation () >|= fun () -> `Cancel)] >>= function + | `Cancel -> Lwt.return_unit + | `Process -> + worker_loop () + in + Lwt_utils.worker "discoverer" ~run:worker_loop ~cancel in + + let shutdown () = + cancel () >>= fun () -> discovery_worker in + + { shutdown; + } + +let shutdown t = t.shutdown () diff --git a/src/node/shell/discoverer.mli b/src/node/shell/discoverer.mli new file mode 100644 index 000000000..fbb75e336 --- /dev/null +++ b/src/node/shell/discoverer.mli @@ -0,0 +1,14 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type worker + +val create_worker: P2p.net -> State.t -> worker + +val shutdown: worker -> unit Lwt.t diff --git a/src/node/shell/messages.ml b/src/node/shell/messages.ml new file mode 100644 index 000000000..a1942f2d7 --- /dev/null +++ b/src/node/shell/messages.ml @@ -0,0 +1,92 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Netbits + +type net_id = Store.net_id + +type message = + + | Discover_blocks of net_id * Block_hash.t list (* Block locator *) + | Block_inventory of net_id * Block_hash.t list + + | Get_block_headers of Block_hash.t list + | Block_header of MBytes.t + + | Current_operations of net_id + | Operation_inventory of net_id * Operation_hash.t list + + | Get_operations of Operation_hash.t list + | Operation of MBytes.t + + | Current_protocol of net_id + | Protocol_inventory of Protocol_hash.t + + +let to_frame msg = + + let bh h = B (Block_hash.to_bytes h) in + let oph h = B (Operation_hash.to_bytes h) in + let ph h = B (Protocol_hash.to_bytes h) in + match msg with + + | Discover_blocks (Net netid, blocks) -> + [ S 2100 ; bh netid ; F (List.map bh blocks) ] + | Block_inventory (Net netid, blocks) -> + [ S 2101 ; bh netid ; F (List.map bh blocks) ] + | Get_block_headers blocks -> + [ S 2102 ; F (List.map bh blocks) ] + | Block_header b -> + [ S 2103 ; B b ] + + | Current_operations (Net net_id) -> + [ S 2700 ; bh net_id ] + | Operation_inventory (Net net_id, ops) -> + [ S 2701 ; bh net_id ; F (List.map oph ops) ] + | Get_operations ops -> + [ S 2702 ; F (List.map oph ops) ] + | Operation b -> + [ S 2703 ; B b ] + + | Current_protocol (Net net_id) -> + [ S 2800 ; bh net_id ] + | Protocol_inventory p -> + [ S 2801 ; ph p ] + +let from_frame msg = + + let bh = function B s -> (Block_hash.of_bytes s) | _ -> invalid_arg "bh" in + let oph = function B s -> (Operation_hash.of_bytes s) | _ -> invalid_arg "oph" in + let ph = function B s -> (Protocol_hash.of_bytes s) | _ -> invalid_arg "ph" in + let net = function netid -> Store.Net (Block_hash.of_bytes netid) in + try match msg with + + | [ S 2100 ; B netid ; F blocks ] -> + Some (Discover_blocks (net netid, List.map bh blocks)) + | [ S 2101 ; B netid ; F blocks ] -> + Some (Block_inventory (net netid, List.map bh blocks)) + | [ S 2102 ; F blocks ] -> + Some (Get_block_headers (List.map bh blocks)) + | [ S 2103 ; B bh ] -> Some (Block_header bh) + | [ S 2700 ; B netid ] -> + Some (Current_operations (net netid)) + | [ S 2701 ; B netid ; F ops ] -> + Some (Operation_inventory (net netid, List.map oph ops)) + | [ S 2702 ; F ops ] -> + Some (Get_operations (List.map oph ops)) + | [ S 2703 ; B contents ] -> Some (Operation contents) + + | [ S 2800 ; B netid ] -> Some (Current_protocol (net netid)) + + | [ S 2801 ; p ] -> Some (Protocol_inventory (ph p)) + + | _ -> None + + with Invalid_argument _ -> None + diff --git a/src/node/shell/messages.mli b/src/node/shell/messages.mli new file mode 100644 index 000000000..ee4a96b20 --- /dev/null +++ b/src/node/shell/messages.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** High level messages *) +type message = + + | Discover_blocks of Store.net_id * Block_hash.t list (* Block locator *) + | Block_inventory of Store.net_id * Block_hash.t list + + | Get_block_headers of Block_hash.t list + | Block_header of MBytes.t + + | Current_operations of Store.net_id + | Operation_inventory of Store.net_id * Operation_hash.t list + + | Get_operations of Operation_hash.t list + | Operation of MBytes.t + + | Current_protocol of Store.net_id + | Protocol_inventory of Protocol_hash.t + +(** Converts a high level message to a network frame *) +val to_frame: message -> Netbits.frame + +(** Tries and convert a network frame to a high level message *) +val from_frame: Netbits.frame -> message option diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml new file mode 100644 index 000000000..0956192c8 --- /dev/null +++ b/src/node/shell/node.ml @@ -0,0 +1,547 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Node.Worker + +let (>|=) = Lwt.(>|=) + +let supported_versions = ["TEZOS", 0, 0] + +let inject_operation validator ?force bytes = + let t = + match Store.Operation.of_bytes bytes with + | None -> failwith "Can't parse the operation" + | Some operation -> + Validator.get validator operation.shell.net_id >>=? fun net_validator -> + let pv = Validator.prevalidator net_validator in + Prevalidator.inject_operation pv ?force operation in + let hash = Operation_hash.hash_bytes [bytes] in + Lwt.return (hash, t) + +let process_operation state validator bytes = + State.Operation.store state bytes >>= function + | Error _ | Ok None -> Lwt.return_unit + | Ok (Some (hash, op)) -> + lwt_log_info "process Operation %a (net: %a)" + Operation_hash.pp_short hash + Store.pp_net_id op.Store.shell.net_id >>= fun () -> + Validator.get validator op.shell.net_id >>= function + | Error _ -> Lwt.return_unit + | Ok net_validator -> + let prevalidator = Validator.prevalidator net_validator in + Prevalidator.register_operation prevalidator hash ; + Lwt.return_unit + +let process_block state validator bytes = + State.Block.store state bytes >>= function + | Error _ | Ok None -> Lwt.return_unit + | Ok (Some (hash, block)) -> + lwt_log_notice "process Block %a (net: %a)" + Block_hash.pp_short hash + Store.pp_net_id block.Store.shell.net_id >>= fun () -> + lwt_debug "process Block %a (predecessor %a)" + Block_hash.pp_short hash + Block_hash.pp_short block.shell.predecessor >>= fun () -> + lwt_debug "process Block %a (timestamp %a)" + Block_hash.pp_short hash + Time.pp_hum block.shell.timestamp >>= fun () -> + Validator.notify_block validator hash block >>= fun () -> + Lwt.return_unit + +let inject_block state validator ?(force = false) bytes = + let hash = Block_hash.hash_bytes [bytes] in + let validation = + State.Block.store state bytes >>=? function + | None -> failwith "Previously registred block." + | Some (hash, block) -> + lwt_log_notice "inject Block %a" + Block_hash.pp_short hash >>= fun () -> + Lwt.return (State.Net.get state block.Store.shell.net_id) >>=? fun net -> + State.Net.Blockchain.head net >>= fun head -> + if force + || Fitness.compare head.fitness block.shell.fitness <= 0 then + Validator.get validator block.shell.net_id >>=? fun net -> + Validator.fetch_block net hash >>=? fun _ -> + return () + else + failwith "Fitness is below the current one" in + Lwt.return (hash, validation) + +let process state validator msg = + let open Messages in + match msg with + + | Discover_blocks (net_id, blocks) -> + lwt_log_info "process Discover_blocks" >>= fun () -> + if not (State.Net.is_active state net_id) then + Lwt.return_nil + else begin + match State.Net.get state net_id with + | Error _ -> Lwt.return_nil + | Ok net -> + State.Block.prefetch state net_id blocks ; + State.Net.Blockchain.find_new net blocks 50 >>= function + | Ok new_block_hashes -> + Lwt.return [Block_inventory (net_id, new_block_hashes)] + | Error _ -> Lwt.return_nil + end + + | Block_inventory (net_id, blocks) -> + lwt_log_info "process Block_inventory" >>= fun () -> + if State.Net.is_active state net_id then + State.Block.prefetch state net_id blocks ; + Lwt.return_nil + + | Get_block_headers blocks -> + lwt_log_info "process Get_block_headers" >>= fun () -> + Lwt_list.map_p (State.Block.raw_read state) blocks >>= fun blocks -> + let cons_block acc = function + | Some b -> Block_header b :: acc + | None -> acc in + Lwt.return (List.fold_left cons_block [] blocks) + + | Block_header block -> + lwt_log_info "process Block_header" >>= fun () -> + process_block state validator block >>= fun _ -> + Lwt.return_nil + + | Current_operations net_id -> + lwt_log_info "process Current_operations" >>= fun () -> + if not (State.Net.is_active state net_id) then + Lwt.return_nil + else begin + Validator.get validator net_id >>= function + | Error _ -> + Lwt.return_nil + | Ok net_validator -> + let pv = Validator.prevalidator net_validator in + let mempool = (fst (Prevalidator.operations pv)).applied in + Lwt.return [Operation_inventory (net_id, mempool)] + end + + | Operation_inventory (net_id, ops) -> + lwt_log_info "process Operation_inventory" >>= fun () -> + if State.Net.is_active state net_id then + State.Operation.prefetch state net_id ops ; + Lwt.return_nil + + | Get_operations ops -> + lwt_log_info "process Get_operations" >>= fun () -> + Lwt_list.map_p (State.Operation.raw_read state) ops >>= fun ops -> + let cons_operation acc = function + | Some op -> Operation op :: acc + | None -> acc in + Lwt.return (List.fold_left cons_operation [] ops) + + | Operation content -> + lwt_log_info "process Operation" >>= fun () -> + process_operation state validator content >>= fun () -> + Lwt.return_nil + + | Current_protocol net_id -> + lwt_log_info "process Current_protocol" >>= fun () -> + if not (State.Net.is_active state net_id) then + Lwt.return_nil + else begin + match State.Net.get state net_id with + | Error _ -> Lwt.return_nil + | Ok net -> + State.Net.Blockchain.head net >>= fun head -> + Lwt.return [Protocol_inventory head.protocol_hash] + end + + | Protocol_inventory _ -> + lwt_log_info "process Protocol_inventory" >>= fun () -> + (* TODO... *) + Lwt.return_nil + +type t = { + state: State.t ; + validator: Validator.worker ; + global_net: State.Net.t ; + global_validator: Validator.t ; + inject_block: + ?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t ; + inject_operation: + ?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t ; + shutdown: unit -> unit Lwt.t ; +} + +let request_operations net _net_id operations = + (* TODO improve the lookup strategy. + For now simply broadcast the request to all our neighbours. *) + P2p.broadcast + (Messages.(to_frame (Get_operations operations))) net + +let request_blocks net _net_id blocks = + (* TODO improve the lookup strategy. + For now simply broadcast the request to all our neighbours. *) + P2p.broadcast (Messages.(to_frame (Get_block_headers blocks))) net + +let init_p2p net_params = + match net_params with + | None -> + lwt_log_notice "P2P layer is disabled" >>= fun () -> + Lwt.return P2p.faked_network + | Some (config, limits) -> + lwt_log_notice "bootstraping network..." >>= fun () -> + P2p.bootstrap config limits + +let create + ~genesis ~store_root ~context_root ?test_protocol ?patch_context net_params = + lwt_debug "-> Node.create" >>= fun () -> + init_p2p net_params >>= fun p2p -> + lwt_log_info "reading state..." >>= fun () -> + let request_operations = request_operations p2p in + let request_blocks = request_blocks p2p in + State.read + ~request_operations ~request_blocks + ~store_root ~context_root ~ttl:(48 * 3600) (* 2 days *) + ?patch_context () >>= fun state -> + let validator = Validator.create_worker p2p state in + let discoverer = Discoverer.create_worker p2p state in + begin + match State.Net.get state (Net genesis.Store.block) with + | Ok net -> return net + | Error _ -> State.Net.create state ?test_protocol genesis + end >>=? fun global_net -> + Validator.activate validator global_net >>= fun global_validator -> + let cleanup () = + Lwt.join [ Validator.shutdown validator ; + Discoverer.shutdown discoverer ] >>= fun () -> + State.store state + in + + lwt_log_info "starting worker..." >>= fun () -> + let worker = + let handle_msg peer frame = + lwt_log_info "received message" >>= fun () -> + match Messages.from_frame frame with + | None -> + lwt_warn "can't parse message" >>= fun () -> + (* FIXME 60 second ? parameter... and Log_notice *) + let addr, _, _ = P2p.peer_info peer p2p in + P2p.blacklist ~duration:60. addr p2p ; + Lwt.return_unit + | Some msg -> + process state validator msg >>= fun msgs -> + List.iter + (fun msg -> P2p.push (peer, Messages.to_frame msg) p2p) + msgs; + Lwt.return_unit + in + let rec worker_loop () = + P2p.recv p2p >>= fun (peer, msg) -> + handle_msg peer msg >>= fun () -> + worker_loop () in + Lwt.catch + worker_loop + (function + | Lwt_stream.Empty -> cleanup () + | exn -> + lwt_log_error "unexpected exception in worker\n%s" + (Printexc.to_string exn) >>= fun () -> + P2p.shutdown p2p >>= fun () -> + cleanup ()) + in + let shutdown () = + lwt_log_info "stopping worker..." >>= fun () -> + P2p.shutdown p2p >>= fun () -> + worker >>= fun () -> + lwt_log_info "stopped" + in + lwt_debug "<- Node.create" >>= fun () -> + return { + state ; + validator ; + global_net ; + global_validator ; + inject_block = inject_block state validator ; + inject_operation = inject_operation validator ; + shutdown ; + } + +let shutdown node = node.shutdown () + +module RPC = struct + + type block = Node_rpc_services.Blocks.block + type block_info = Node_rpc_services.Blocks.block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + operations: Operation_hash.t list option ; + net: Node_rpc_services.Blocks.net ; + test_protocol: Protocol_hash.t option ; + test_network: (Node_rpc_services.Blocks.net * Time.t) option ; + } + + let convert (block: State.Valid_block.t) = { + hash = block.hash ; + predecessor = block.pred ; + fitness = block.fitness ; + timestamp = block.timestamp ; + protocol = Some block.protocol_hash ; + operations = Some block.operations ; + net = block.net_id ; + test_protocol = Some block.test_protocol_hash ; + test_network = block.test_network ; + } + + let convert_block hash (block: State.Block.shell_header) = { + net = block.net_id ; + hash = hash ; + predecessor = block.predecessor ; + fitness = block.fitness ; + timestamp = block.timestamp ; + protocol = None ; + operations = Some block.operations ; + test_protocol = None ; + test_network = None ; + } + + let inject_block node = node.inject_block + let inject_operation node = node.inject_operation + + let raw_block_info node hash = + State.Valid_block.read_exn node.state hash >|= convert + + let prevalidation_hash = + Block_hash.of_b48check + "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + + let get_net node = function + | `Head _ | `Prevalidation -> node.global_validator, node.global_net + | `Test_head _ | `Test_prevalidation -> + match Validator.test_validator node.global_validator with + | None -> raise Not_found + | Some v -> v + + let get_pred node n (v: State.Valid_block.t) = + if n <= 0 then Lwt.return v else + let rec loop n h = + if n <= 0 then Lwt.return h else + State.Block.read_pred node.state h >>= function + | None -> raise Not_found + | Some pred -> loop (n-1) pred in + loop n v.hash >>= fun h -> + State.Valid_block.read node.state h >>= function + | None | Some (Error _) -> Lwt.fail Not_found (* error in the DB *) + | Some (Ok b) -> Lwt.return b + + let block_info node (block: block) = + match block with + | `Genesis -> State.Net.Blockchain.genesis node.global_net >|= convert + | ( `Head n | `Test_head n ) as block -> + let _, net = get_net node block in + State.Net.Blockchain.head net >>= get_pred node n >|= convert + | `Hash h -> State.Valid_block.read_exn node.state h >|= convert + | ( `Prevalidation | `Test_prevalidation ) as block -> + let validator, net = get_net node block in + let pv = Validator.prevalidator validator in + State.Net.Blockchain.head net >>= fun head -> + let ctxt = Prevalidator.context pv in + let (module Proto) = Prevalidator.protocol pv in + Proto.fitness ctxt >|= fun fitness -> + { (convert head) with + hash = prevalidation_hash ; + fitness ; + timestamp = Prevalidator.timestamp pv + } + + let get_context node block = + match block with + | `Genesis -> + State.Net.Blockchain.genesis node.global_net >>= fun { context } -> + Lwt.return (Some context) + | ( `Head n | `Test_head n ) as block-> + let _, net = get_net node block in + State.Net.Blockchain.head net >>= get_pred node n >>= fun { context } -> + Lwt.return (Some context) + | `Hash hash-> begin + State.Valid_block.read node.state hash >|= function + | None | Some (Error _) -> None + | Some (Ok { context }) -> Some context + end + | ( `Prevalidation | `Test_prevalidation ) as block -> + let validator, _net = get_net node block in + let pv = Validator.prevalidator validator in + Lwt.return (Some (Prevalidator.context pv)) + + let operations node block = + match block with + | `Genesis -> + State.Net.Blockchain.genesis node.global_net >>= fun { operations } -> + Lwt.return operations + | ( `Head n | `Test_head n ) as block -> + let _, net = get_net node block in + State.Net.Blockchain.head net >>= get_pred node n >>= fun { operations } -> + Lwt.return operations + | (`Prevalidation | `Test_prevalidation) as block -> + let validator, _net = get_net node block in + let pv = Validator.prevalidator validator in + let { Updater.applied }, _ = Prevalidator.operations pv in + Lwt.return applied + | `Hash hash-> + State.Block.read node.state hash >|= function + | None -> [] + | Some { Time.data = { shell = { operations }}} -> operations + + let operation_content node hash = + State.Operation.read node.state hash + + let pending_operations node block = + match block with + | ( `Head 0 | `Prevalidation + | `Test_head 0 | `Test_prevalidation ) as block -> + let validator, _net = get_net node block in + let pv = Validator.prevalidator validator in + Lwt.return (Prevalidator.operations pv) + | ( `Head n | `Test_head n ) as block -> + let _validator, net = get_net node block in + State.Net.Blockchain.head net >>= get_pred node n >>= fun b -> + State.Net.Mempool.for_block net b >|= fun ops -> + Updater.empty_result, ops + | `Genesis -> + let net = node.global_net in + State.Net.Blockchain.genesis net >>= fun b -> + State.Net.Mempool.for_block net b >|= fun ops -> + Updater.empty_result, ops + | `Hash h -> + begin + let nets = State.Net.active node.state in + Lwt_list.filter_map_p + (fun net -> + State.Net.Blockchain.head net >|= fun head -> + if Block_hash.equal h head.hash then Some (net, head) else None) + nets >>= function + | [] -> Lwt.return_none + | [net] -> Lwt.return (Some net) + | nets -> + Lwt_list.filter_p + (fun (net, (head: State.Valid_block.t)) -> + State.Net.Blockchain.genesis net >|= fun genesis -> + not (Block_hash.equal genesis.hash head.hash)) + nets >>= function + | [net] -> Lwt.return (Some net) + | _ -> Lwt.fail Not_found + end >>= function + | Some (net, _head) -> + Validator.get_exn + node.validator (State.Net.id net) >>= fun net_validator -> + let pv = Validator.prevalidator net_validator in + Lwt.return (Prevalidator.operations pv) + | None -> + State.Valid_block.read_exn node.state h >>= fun b -> + if not (State.Net.is_active node.state b.net_id) then + raise Not_found ; + match State.Net.get node.state b.net_id with + | Error _ -> raise Not_found + | Ok net -> + State.Net.Mempool.for_block net b >|= fun ops -> + Updater.empty_result, ops + + let preapply node block ~timestamp ~sort ops = + begin + match block with + | `Genesis -> + let net = node.global_net in + State.Net.Blockchain.genesis net >>= return + | ( `Head 0 | `Prevalidation + | `Test_head 0 | `Test_prevalidation ) as block -> + let _validator, net = get_net node block in + State.Net.Blockchain.head net >>= return + | `Head n | `Test_head n as block -> begin + let _validator, net = get_net node block in + State.Net.Blockchain.head net >>= get_pred node n >>= return + end + | `Hash hash -> begin + State.Valid_block.read node.state hash >>= function + | None -> Lwt.return (error_exn Not_found) + | Some data -> Lwt.return data + end + end >>=? fun { hash ; context ; protocol } -> + begin + match protocol with + | None -> failwith "Unknown protocol version" + | Some protocol -> return protocol + end >>=? function (module Proto) as protocol -> + Prevalidator.preapply + node.state context protocol hash timestamp sort ops >>=? fun (ctxt, r) -> + Proto.fitness ctxt >>= fun fitness -> + return (fitness, r) + + let context_dir node block = + get_context node block >>= function + | None -> Lwt.return None + | Some ctxt -> + Context.get_protocol ctxt >>= fun protocol_hash -> + let (module Proto) = Updater.get_exn protocol_hash in + let dir = RPC.map (fun () -> ctxt) Proto.rpc_services in + Lwt.return (Some (RPC.map (fun _ -> ()) dir)) + + let heads node = + State.Valid_block.known_heads node.state >|= Block_hash_map.map convert + + let predecessors state ignored len head = + try + let rec loop acc len hash = + State.Valid_block.read_exn state hash >>= fun block -> + let bi = convert block in + if Block_hash.equal bi.predecessor hash then + Lwt.return (List.rev (bi :: acc)) + else begin + if len = 0 + || Block_hash_set.mem hash ignored then + Lwt.return (List.rev acc) + else + loop (bi :: acc) (len-1) bi.predecessor + end in + loop [] len head + with Not_found -> Lwt.return_nil + + let list node len heads = + Lwt_list.fold_left_s + (fun (ignored, acc) head -> + predecessors node.state ignored len head >|= fun predecessors -> + let ignored = + List.fold_right + (fun x s -> Block_hash_set.add x.hash s) + predecessors ignored in + ignored, predecessors :: acc + ) + (Block_hash_set.empty, []) + heads >|= fun (_, blocks) -> + List.rev blocks + + let block_watcher node = + let stream, shutdown = State.Block.create_watcher node.state in + Lwt_stream.map + (fun (hash, block) -> convert_block hash block.Store.shell) + stream, + shutdown + + let valid_block_watcher node = + State.Valid_block.create_watcher node.state >|= fun (stream, shutdown) -> + Lwt_stream.map + (fun block -> convert block) + stream, + shutdown + + let operation_watcher node = + State.Operation.create_watcher node.state + + let validate node net_id block = + Validator.get node.validator net_id >>=? fun net_v -> + Validator.fetch_block net_v block >>=? fun _ -> + return () + +end diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli new file mode 100644 index 000000000..f1ffe52c6 --- /dev/null +++ b/src/node/shell/node.mli @@ -0,0 +1,70 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t + +val supported_versions: P2p.version list + +val create: + genesis:Store.genesis -> + store_root:string -> + context_root:string -> + ?test_protocol:Protocol_hash.t -> + ?patch_context:(Context.t -> Context.t Lwt.t) -> + (P2p.config * P2p.limits) option -> + t tzresult Lwt.t + +module RPC : sig + + type block = Node_rpc_services.Blocks.block + type block_info = Node_rpc_services.Blocks.block_info + + val inject_block: + t -> ?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t + val inject_operation: + t -> ?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t + + val raw_block_info: + t -> Block_hash.t -> block_info Lwt.t + val block_watcher: + t -> block_info Lwt_stream.t * (unit -> unit) + val valid_block_watcher: + t -> (block_info Lwt_stream.t * (unit -> unit)) Lwt.t + val heads: t -> block_info Block_hash_map.t Lwt.t + + val list: + t -> int -> Block_hash.t list -> block_info list list Lwt.t + + val block_info: + t -> block -> block_info Lwt.t + + val operations: + t -> block -> Operation_hash.t list Lwt.t + val operation_content: + t -> Operation_hash.t -> Store.operation tzresult Time.timed_data option Lwt.t + val operation_watcher: + t -> (Operation_hash.t * Store.operation) Lwt_stream.t * (unit -> unit) + + val pending_operations: + t -> block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t + + val context_dir: + t -> block -> 'a RPC.directory option Lwt.t + + val preapply: + t -> block -> + timestamp:Time.t -> sort:bool -> + Operation_hash.t list -> + (Protocol.fitness * error Updater.preapply_result) tzresult Lwt.t + + val validate: t -> State.net_id -> Block_hash.t -> unit tzresult Lwt.t + +end + +val shutdown: t -> unit Lwt.t diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml new file mode 100644 index 000000000..3cb41e0c2 --- /dev/null +++ b/src/node/shell/node_rpc.ml @@ -0,0 +1,376 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Utils +open Logging.RPC + +module Services = Node_rpc_services + +let filter_bi include_ops (bi: Services.Blocks.block_info) = + if include_ops then bi else { bi with operations = None } + +let register_bi_dir node dir = + let dir = + let implementation b include_ops = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return (filter_bi include_ops bi) in + RPC.register1 dir + Services.Blocks.info implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.hash in + RPC.register1 dir + Services.Blocks.hash + implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.net in + RPC.register1 dir + Services.Blocks.net implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.predecessor in + RPC.register1 dir + Services.Blocks.predecessor implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.fitness in + RPC.register1 dir + Services.Blocks.fitness implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.timestamp in + RPC.register1 dir + Services.Blocks.timestamp implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + match bi.protocol with + | None -> raise Not_found + | Some p -> RPC.Answer.return p in + RPC.register1 dir + Services.Blocks.protocol implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.test_protocol in + RPC.register1 dir + Services.Blocks.test_protocol implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.test_network in + RPC.register1 dir + Services.Blocks.test_network implementation in + let dir = + let implementation b () = + Node.RPC.operations node b >>= + RPC.Answer.return in + RPC.register1 dir + Services.Blocks.operations implementation in + let dir = + let implementation b () = + Node.RPC.pending_operations node b >>= fun res -> + RPC.Answer.return res in + RPC.register1 dir + Services.Blocks.pending_operations + implementation in + let dir = + let implementation + b { Services.Blocks.operations ; sort ; timestamp } = + let timestamp = + match timestamp with + | None -> Time.now () + | Some x -> x in + Node.RPC.preapply ~timestamp ~sort + node b operations >>= function + | Ok (fitness, operations) -> + RPC.Answer.return + (Ok { Services.Blocks.fitness ; operations ; timestamp }) + | Error _ as err -> RPC.Answer.return err in + RPC.register1 dir + Services.Blocks.preapply implementation in + dir + +let ops_dir _node = + let ops_dir = RPC.empty in + ops_dir + +let rec insert_future_block (bi: Services.Blocks.block_info) = function + | [] -> [bi] + | ({timestamp} as head: Services.Blocks.block_info) :: tail as all -> + if Time.compare bi.timestamp timestamp < 0 then + bi :: all + else + head :: insert_future_block bi tail + +let create_delayed_stream + ~filtering ~include_ops requested_heads bi_stream delay = + let stream, push = Lwt_stream.create () in + let current_blocks = + ref (List.fold_left + (fun acc h -> Block_hash_set.add h acc) + Block_hash_set.empty requested_heads) in + let next_future_block, is_futur_block, + insert_future_block, pop_future_block = + let future_blocks = ref [] in (* FIXME *) + let future_blocks_set = ref Block_hash_set.empty in + let next () = + match !future_blocks with + | [] -> None + | bi :: _ -> Some bi + and mem hash = Block_hash_set.mem hash !future_blocks_set + and insert bi = + future_blocks := insert_future_block bi !future_blocks ; + future_blocks_set := + Block_hash_set.add bi.hash !future_blocks_set + and pop time = + match !future_blocks with + | {timestamp} as bi :: rest when Time.(timestamp <= time) -> + future_blocks := rest ; + future_blocks_set := + Block_hash_set.remove bi.hash !future_blocks_set ; + Some bi + | _ -> None in + next, mem, insert, pop in + let _block_watcher_worker = + let never_ending = fst (Lwt.wait ()) in + let rec worker_loop () = + lwt_debug "WWW worker_loop" >>= fun () -> + let time = Time.(add (now ()) (Int64.of_int ~-delay)) in + let migration_delay = + match next_future_block () with + | None -> never_ending + | Some bi -> + let delay = Time.diff bi.timestamp time in + if delay <= 0L then + Lwt.return_unit + else + Lwt_unix.sleep (Int64.to_float delay) in + Lwt.choose [(migration_delay >|= fun () -> `Migrate) ; + (Lwt_stream.get bi_stream >|= fun x -> `Block x) ] + >>= function + | `Block None -> + lwt_debug "WWW worker_loop None" >>= fun () -> + Lwt.return_unit + | `Block (Some (bi : Services.Blocks.block_info)) -> + lwt_debug "WWW worker_loop Some" >>= fun () -> + begin + if not filtering + || Block_hash_set.mem bi.predecessor !current_blocks + || is_futur_block bi.predecessor + then begin + let time = Time.(add (now ()) (Int64.of_int ~-delay)) in + if Time.(time < bi.timestamp) then begin + insert_future_block bi ; + Lwt.return_unit + end else begin + current_blocks := + Block_hash_set.remove bi.predecessor !current_blocks + |> Block_hash_set.add bi.hash ; + push (Some [[filter_bi include_ops bi]]) ; + Lwt.return_unit + end + end else begin + Lwt.return_unit + end + end >>= fun () -> + worker_loop () + | `Migrate -> + lwt_debug "WWW worker_loop Migrate" >>= fun () -> + let time = Time.(add (now ()) (Int64.of_int ~-delay)) in + let rec migrate_future_blocks () = + match pop_future_block time with + | Some bi -> + push (Some [[filter_bi include_ops bi]]) ; + migrate_future_blocks () + | None -> Lwt.return_unit in + migrate_future_blocks () >>= fun () -> + worker_loop () + in + Lwt_utils.worker "block_watcher" + ~run:worker_loop ~cancel:(fun () -> Lwt.return_unit) in + stream + +let list_blocks + node + { Services.Blocks.operations ; length ; heads ; monitor ; delay } = + let include_ops = match operations with None -> false | Some x -> x in + let len = match length with None -> 1 | Some x -> x in + let monitor = match monitor with None -> false | Some x -> x in + let time = + match delay with + | None -> None + | Some delay -> Some (Time.(add (now ()) (Int64.of_int ~-delay))) in + begin + match heads with + | None -> + Node.RPC.heads node >>= fun heads -> + let heads = List.map snd (Block_hash_map.bindings heads) in + begin + match time with + | None -> Lwt.return heads + | Some time -> + let rec current_predecessor (bi: Node.RPC.block_info) = + if Time.compare bi.timestamp time <= 0 + || bi.hash = bi.predecessor then + Lwt.return bi + else + Node.RPC.raw_block_info node bi.predecessor >>= + current_predecessor in + Lwt_list.map_p current_predecessor heads + end >|= fun heads_info -> + let sorted_infos = + List.sort + (fun + (bi1: Services.Blocks.block_info) + (bi2: Services.Blocks.block_info) -> + ~- (Fitness.compare bi1.fitness bi2.fitness)) + heads_info in + List.map + (fun ({ hash } : Services.Blocks.block_info) -> hash) + sorted_infos + | Some heads -> + let known_block h = + try ignore (Node.RPC.raw_block_info node h) ; true + with Not_found -> false in + Lwt.return (List.filter known_block heads) + end >>= fun requested_heads -> + Node.RPC.list node len requested_heads >>= fun requested_blocks -> + if not monitor then + let infos = + List.map + (List.map (filter_bi include_ops)) + requested_blocks in + RPC.Answer.return infos + else begin + Node.RPC.valid_block_watcher node >>= fun (bi_stream, shutdown) -> + let stream, shutdown = + match delay with + | None -> + Lwt_stream.map (fun bi -> [[filter_bi include_ops bi]]) bi_stream, + shutdown + | Some delay -> + let filtering = heads <> None in + create_delayed_stream + ~filtering ~include_ops requested_heads bi_stream delay, + shutdown + in + let first_request = ref true in + let next () = + if not !first_request then begin + Lwt_stream.get stream + end else begin + first_request := false ; + let infos = + List.map (List.map (filter_bi include_ops)) requested_blocks in + Lwt.return (Some infos) + end in + RPC.Answer.return_stream { next ; shutdown } + end + +let list_operations node {Services.Operations.monitor; contents} = + let monitor = match monitor with None -> false | Some x -> x in + let include_ops = match contents with None -> false | Some x -> x in + Node.RPC.operations node `Prevalidation >>= fun operations -> + Lwt_list.map_p + (fun hash -> + if include_ops then + Node.RPC.operation_content node hash >>= function + | None | Some { Time.data = Error _ } -> Lwt.return (hash, None) + | Some { Time.data = Ok bytes }-> + Lwt.return (hash, Some bytes) + else + Lwt.return (hash, None)) + operations >>= fun operations -> + if not monitor then + RPC.Answer.return operations + else + let stream, shutdown = Node.RPC.operation_watcher node in + let first_request = ref true in + let next () = + if not !first_request then + Lwt_stream.get stream >>= function + | None -> Lwt.return_none + | Some (h, op) when include_ops -> Lwt.return (Some [h, Some op]) + | Some (h, _) -> Lwt.return (Some [h, None]) + else begin + first_request := false ; + Lwt.return (Some operations) + end in + RPC.Answer.return_stream { next ; shutdown } + +let get_operations node hash () = + Node.RPC.operation_content node hash >>= function + | Some bytes -> RPC.Answer.return bytes + | None -> raise Not_found + +let build_rpc_directory node = + let dir = RPC.empty in + let dir = RPC.register0 dir Services.Blocks.list (list_blocks node) in + let dir = register_bi_dir node dir in + let dir = + let implementation block = + Lwt.catch (fun () -> + Node.RPC.context_dir node block >>= function + | None -> Lwt.fail Not_found + | Some context_dir -> Lwt.return context_dir) + (fun _ -> Lwt.return RPC.empty) in + RPC.register_dynamic_directory1 + ~descr: + "All the RPCs which are specific to the protocol version." + dir Services.Blocks.proto_path implementation in + let dir = + RPC.register0 dir Services.Operations.list (list_operations node) in + let dir = + RPC.register1 dir Services.Operations.bytes (get_operations node) in + let dir = + let implementation (net_id, pred, time, fitness, operations, header) = + Node.RPC.block_info node (`Head 0) >>= fun bi -> + let timestamp = Utils.unopt (Time.now ()) time in + let net_id = Utils.unopt bi.net net_id in + let predecessor = Utils.unopt bi.hash pred in + let res = + Store.Block.to_bytes { + shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ; + proto = header ; + } in + RPC.Answer.return res in + RPC.register0 dir Services.forge_block implementation in + let dir = + let implementation (net_id, block_hash) = + Node.RPC.validate node net_id block_hash >>= fun res -> + RPC.Answer.return res in + RPC.register0 dir Services.validate_block implementation in + let dir = + let implementation (block, blocking, force) = + Node.RPC.inject_block node ?force block >>= fun (hash, wait) -> + begin + (if blocking then wait else return ()) >>=? fun () -> return hash + end >>= RPC.Answer.return in + RPC.register0 dir Services.inject_block implementation in + let dir = + let implementation (contents, blocking, force) = + Node.RPC.inject_operation node ?force contents >>= fun (hash, wait) -> + begin + (if blocking then wait else return ()) >>=? fun () -> return hash + end >>= RPC.Answer.return in + RPC.register0 dir Services.inject_operation implementation in + let dir = + let implementation () = + RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in + RPC.register0 dir RPC.Error.service implementation in + let dir = + RPC.register_describe_directory_service dir Services.describe in + dir diff --git a/src/node/shell/node_rpc.mli b/src/node/shell/node_rpc.mli new file mode 100644 index 000000000..249844260 --- /dev/null +++ b/src/node/shell/node_rpc.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val build_rpc_directory: Node.t -> unit RPC.directory diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml new file mode 100644 index 000000000..20f453509 --- /dev/null +++ b/src/node/shell/node_rpc_services.ml @@ -0,0 +1,471 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Data_encoding + +module Blocks = struct + + type block = [ + | `Genesis + | `Head of int | `Prevalidation + | `Test_head of int | `Test_prevalidation + | `Hash of Block_hash.t + ] + + type net = Store.net_id = Net of Block_hash.t + + let net_encoding = + conv (fun (Net id) -> id) (fun id -> Net id) Block_hash.encoding + + type block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + operations: Operation_hash.t list option ; + net: net ; + test_protocol: Protocol_hash.t option ; + test_network: (net * Time.t) option ; + } + + let block_info_encoding = + conv + (fun { hash ; predecessor ; fitness ; timestamp ; protocol ; operations ; + net ; test_protocol ; test_network } -> + (hash, predecessor, fitness, timestamp, protocol, operations, + net, test_protocol, test_network)) + (fun (hash, predecessor, fitness, timestamp, protocol, operations, + net, test_protocol, test_network) -> + { hash ; predecessor ; fitness ; timestamp ; protocol ; operations ; + net ; test_protocol ; test_network }) + (obj9 + (req "hash" Block_hash.encoding) + (req "predecessor" Block_hash.encoding) + (req "fitness" Fitness.encoding) + (req "timestamp" Time.encoding) + (opt "protocol" Protocol_hash.encoding) + (opt "operations" (list Operation_hash.encoding)) + (req "net" net_encoding) + (opt "test_protocol" Protocol_hash.encoding) + (opt "test_network" (tup2 net_encoding Time.encoding))) + + let parse_block s = + try + match Utils.split '~' s with + | ["genesis"] -> Ok `Genesis + | ["head"] -> Ok (`Head 0) + | ["prevalidation"] -> Ok `Prevalidation + | ["test_head"] -> Ok (`Test_head 0) + | ["test_prevalidation"] -> Ok `Test_prevalidation + | ["head"; n] -> Ok (`Head (int_of_string n)) + | ["test_head"; n] -> Ok (`Test_head (int_of_string n)) + | [h] -> Ok (`Hash (Block_hash.of_b48check h)) + | _ -> raise Exit + with _ -> Error "Cannot parse block identifier." + + + let blocks_arg = + let name = "block_id" in + let descr = + "A block identifier. This is either a block hash in hexadecimal \ + notation or a one the predefined aliases: \ + 'genesis', 'head', 'prevalidation', \ + 'test_head' or 'test_prevalidation'. One might alse use 'head~N' + to 'test_head~N', where N is an integer to denotes the Nth predecessors + of 'head' or 'test_head'." in + let construct = function + | `Genesis -> "genesis" + | `Head 0 -> "head" + | `Head n -> Printf.sprintf "head~%d" n + | `Prevalidation -> "prevalidation" + | `Test_head 0 -> "test_head" + | `Test_head n -> Printf.sprintf "test_head~%d" n + | `Test_prevalidation -> "test_prevalidation" + | `Hash h -> Block_hash.to_b48check h in + let destruct = parse_block in + RPC.Arg.make ~name ~descr ~construct ~destruct + + type preapply_param = { + operations: Operation_hash.t list ; + sort: bool ; + timestamp: Time.t option ; + } + + let preapply_param_encoding = + (conv + (fun { operations ; sort ; timestamp } -> + (operations, Some sort, timestamp)) + (fun (operations, sort, timestamp) -> + let sort = + match sort with + | None -> true + | Some x -> x in + { operations ; sort ; timestamp }) + (obj3 + (req "operations" (list Operation_hash.encoding)) + (opt "sort" bool) + (opt "timestamp" Time.encoding))) + + type preapply_result = { + operations: error Updater.preapply_result ; + fitness: MBytes.t list ; + timestamp: Time.t ; + } + + let preapply_result_encoding = + (conv + (fun { operations ; timestamp ; fitness } -> + (timestamp, fitness, operations)) + (fun (timestamp, fitness, operations) -> + { operations ; timestamp ; fitness }) + (obj3 + (req "timestamp" Time.encoding) + (req "fitness" Fitness.encoding) + (req "operations" (Updater.preapply_result_encoding RPC.Error.encoding)))) + + let block_path : (unit, unit * block) RPC.Path.path = + RPC.Path.(root / "blocks" /: blocks_arg ) + + let info = + RPC.service + ~description:"All the block informations." + ~input: + (conv + (fun x -> Some x) + (function None -> false | Some x -> x) + (obj1 (opt "operations" bool))) + ~output: block_info_encoding + block_path + + let net = + RPC.service + ~description:"Returns the net of the chain in which the block belongs." + ~input: empty + ~output: (obj1 (req "net" net_encoding)) + RPC.Path.(block_path / "net") + + let predecessor = + RPC.service + ~description:"Returns the previous block's id." + ~input: empty + ~output: (obj1 (req "predecessor" Block_hash.encoding)) + RPC.Path.(block_path / "predecessor") + + let hash = + RPC.service + ~description:"Returns the block's id." + ~input: empty + ~output: (obj1 (req "hash" Block_hash.encoding)) + RPC.Path.(block_path / "hash") + + let fitness = + RPC.service + ~description:"Returns the block's fitness." + ~input: empty + ~output: (obj1 (req "fitness" Fitness.encoding)) + RPC.Path.(block_path / "fitness") + + let timestamp = + RPC.service + ~description:"Returns the block's timestamp." + ~input: empty + ~output: (obj1 (req "timestamp" Time.encoding)) + RPC.Path.(block_path / "timestamp") + + let operations = + RPC.service + ~description:"List the block operations." + ~input: empty + ~output: (obj1 (req "operations" (list Operation_hash.encoding))) + RPC.Path.(block_path / "operations") + + let protocol = + RPC.service + ~description:"List the block protocol." + ~input: empty + ~output: (obj1 (req "protocol" Protocol_hash.encoding)) + RPC.Path.(block_path / "protocol") + + let test_protocol = + RPC.service + ~description:"List the block test protocol." + ~input: empty + ~output: (obj1 (opt "protocol" Protocol_hash.encoding)) + RPC.Path.(block_path / "test_protocol") + + let test_network = + RPC.service + ~description:"Returns the associated test network." + ~input: empty + ~output: (obj1 (opt "net" (tup2 net_encoding Time.encoding))) + RPC.Path.(block_path / "test_network") + + let pending_operations = + (* TODO: branch_delayed/... *) + RPC.service + ~description: + "List the not-yet-prevalidated operations." + ~input: empty + ~output: + (conv + (fun ({ Updater.applied; branch_delayed ; branch_refused }, + unprocessed) -> + (applied, + Operation_hash_map.bindings branch_delayed, + Operation_hash_map.bindings branch_refused, + Operation_hash_set.elements unprocessed)) + (fun (applied, branch_delayed, branch_refused, unprocessed) -> + ({ Updater.applied ; refused = Operation_hash_map.empty ; + branch_refused = + List.fold_right + (fun (k, o) -> Operation_hash_map.add k o) + branch_refused Operation_hash_map.empty ; + branch_delayed = + List.fold_right + (fun (k, o) -> Operation_hash_map.add k o) + branch_delayed Operation_hash_map.empty ; + }, + List.fold_right Operation_hash_set.add + unprocessed Operation_hash_set.empty)) + (obj4 + (req "applied" (list Operation_hash.encoding)) + (req "branch_delayed" + (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (req "branch_refused" + (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (req "unprocessed" (list Operation_hash.encoding)))) + RPC.Path.(block_path / "pending_operations") + + let proto_path = + RPC.Path.(block_path / "proto") + + let preapply = + RPC.service + ~description: + "Simulate the validation of a block that would contain \ + the given operations and return the resulting fitness." + ~input: preapply_param_encoding + ~output: (RPC.Error.wrap preapply_result_encoding) + RPC.Path.(block_path / "preapply") + + type list_param = { + operations: bool option ; + length: int option ; + heads: Block_hash.t list option ; + monitor: bool option ; + delay: int option ; + } + let list_param_encoding = + conv + (fun {operations;length;heads;monitor;delay} -> + (operations,length,heads,monitor,delay)) + (fun (operations,length,heads,monitor,delay) -> + {operations;length;heads;monitor;delay}) + (obj5 + (opt "operations" + (Data_encoding.describe + ~description: + "Whether the resulting block informations should include the \ + list of operations' hashes. Default false." + bool)) + (opt "length" + (Data_encoding.describe + ~description: + "The requested number of predecessors to returns (per \ + requested head)." + int31)) + (opt "heads" + (Data_encoding.describe + ~description: + "An empty argument requests blocks from the current heads. \ + A non empty list allow to request specific fragment \ + of the chain." + (list Block_hash.encoding))) + (opt "monitor" + (Data_encoding.describe + ~description: + "When true, the socket is \"kept alive\" after the first \ + answer and new heads are streamed when discovered." + bool)) + (opt "delay" + (Data_encoding.describe + ~description: + "By default only the blocks that were validated by the node \ + are considered. \ + When this optional argument is 0, only blocks with a \ + timestamp in the past are considered. Other values allows to \ + adjust the current time." + int31))) + + let list = + RPC.service + ~description: + "Lists known heads of the blockchain sorted with decreasing fitness. \ + Optional arguments allows to returns the list of predecessors for \ + known heads or the list of predecessors for a given list of blocks." + ~input: list_param_encoding + ~output: (obj1 (req "blocks" (list (list block_info_encoding)))) + RPC.Path.(root / "blocks") + +end + +module Operations = struct + + let operations_arg = + let name = "operation_id" in + let descr = + "A operation identifier in hexadecimal." in + let construct = Operation_hash.to_b48check in + let destruct h = + try Ok (Operation_hash.of_b48check h) + with _ -> Error "Can't parse hash" in + RPC.Arg.make ~name ~descr ~construct ~destruct + + let bytes = + RPC.service + ~input: empty + ~output: + (obj1 (req "data" + (describe ~title: "Tezos signed operation (hex encoded)" + (Time.timed_encoding @@ + RPC.Error.wrap @@ + Updater.raw_operation_encoding)))) + RPC.Path.(root / "operations" /: operations_arg) + + type list_param = { + contents: bool option ; + monitor: bool option ; + } + + let list_param_encoding = + conv + (fun {contents; monitor} -> (contents, monitor)) + (fun (contents, monitor) -> {contents; monitor}) + (obj2 + (opt "contents" bool) + (opt "monitor" bool)) + + let list = + RPC.service + ~input: list_param_encoding + ~output: + (obj1 + (req "operations" + (list + (obj2 + (req "hash" Operation_hash.encoding) + (opt "contents" + (dynamic_size Updater.raw_operation_encoding))) + ))) + RPC.Path.(root / "operations") + +end + +let forge_block = + RPC.service + ~description: "Forge a block header" + ~input: + (obj6 + (opt "net_id" Updater.net_id_encoding) + (opt "predecessor" Block_hash.encoding) + (opt "timestamp" Time.encoding) + (req "fitness" Fitness.encoding) + (req "operations" (list Operation_hash.encoding)) + (req "header" bytes)) + ~output: (obj1 (req "block" bytes)) + RPC.Path.(root / "forge_block") + +let validate_block = + RPC.service + ~description: + "Force the node to fetch and validate the given block hash." + ~input: + (obj2 + (req "net" Blocks.net_encoding) + (req "hash" Block_hash.encoding)) + ~output: + (RPC.Error.wrap @@ empty) + RPC.Path.(root / "validate_block") + +let inject_block = + RPC.service + ~description: + "Inject a block in the node and broadcast it. The `operations` \ + embedded in `blockHeader` might pre-validated using a \ + contextual RPCs from the latest block \ + (e.g. '/blocks/head/context/preapply'). Returns the ID of the \ + block. By default, the RPC will wait for the block to be \ + validated before to answer." + ~input: + (conv + (fun (block, blocking, force) -> + (block, Some blocking, force)) + (fun (block, blocking, force) -> + (block, Utils.unopt true blocking, force)) + (obj3 + (req "data" bytes) + (opt "blocking" + (describe + ~description: + "Should the RPC wait for the block to be \ + validated before to answer. (default: true)" + bool)) + (opt "force" + (describe + ~description: + "Should we inject the block when its fitness is below \ + the current head. (default: false)" + bool)))) + ~output: + (RPC.Error.wrap @@ + (obj1 (req "block_hash" Block_hash.encoding))) + RPC.Path.(root / "inject_block") + +let inject_operation = + RPC.service + ~description: + "Inject an operation in node and broadcast it. Returns the \ + ID of the operation. The `signedOperationContents` should be \ + constructed using a contextual RPCs from the latest block \ + and signed by the client. By default, the RPC will wait for \ + the operation to be (pre-)validated before to answer. See \ + RPCs ubder /blocks/prevalidation for more details on the \ + prevalidation context." + ~input: + (conv + (fun (block, blocking, force) -> (block, Some blocking, force)) + (fun (block, blocking, force) -> (block, unopt true blocking, force)) + (obj3 + (req "signedOperationContents" + (describe ~title: "Tezos signed operation (hex encoded)" + bytes)) + (opt "blocking" + (describe + ~description: + "Should the RPC wait for the operation to be \ + (pre-)validated before to answer. (default: true)" + bool)) + (opt "force" + (describe + ~description: + "Should we inject operation that are \"branch_refused\" \ + or \"branch_delayed\". (default: false)" + bool)))) + ~output: + (RPC.Error.wrap @@ + describe + ~title: "Hash of the injected operation" @@ + (obj1 (req "injectedOperation" Operation_hash.encoding))) + RPC.Path.(root / "inject_operation") + +let describe = + RPC.Description.service + ~description: "RPCs documentation and input/output schema" + RPC.Path.(root / "describe") diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli new file mode 100644 index 000000000..a3206b402 --- /dev/null +++ b/src/node/shell/node_rpc_services.mli @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Blocks : sig + + type block = [ + | `Genesis + | `Head of int | `Prevalidation + | `Test_head of int | `Test_prevalidation + | `Hash of Block_hash.t + ] + + val parse_block: string -> (block, string) result + type net = Store.net_id = Net of Block_hash.t + + type block_info = { + hash: Block_hash.t ; + predecessor: Block_hash.t ; + fitness: MBytes.t list ; + timestamp: Time.t ; + protocol: Protocol_hash.t option ; + operations: Operation_hash.t list option ; + net: net ; + test_protocol: Protocol_hash.t option ; + test_network: (net * Time.t) option ; + } + + val info: + (unit, unit * block, bool, block_info) RPC.service + val net: + (unit, unit * block, unit, net) RPC.service + val predecessor: + (unit, unit * block, unit, Block_hash.t) RPC.service + val hash: + (unit, unit * block, unit, Block_hash.t) RPC.service + val timestamp: + (unit, unit * block, unit, Time.t) RPC.service + val fitness: + (unit, unit * block, unit, MBytes.t list) RPC.service + val operations: + (unit, unit * block, unit, Operation_hash.t list) RPC.service + val protocol: + (unit, unit * block, unit, Protocol_hash.t) RPC.service + val test_protocol: + (unit, unit * block, unit, Protocol_hash.t option) RPC.service + val test_network: + (unit, unit * block, unit, (net * Time.t) option) RPC.service + val pending_operations: + (unit, unit * block, unit, + error Updater.preapply_result * Hash.Operation_hash_set.t) RPC.service + + type list_param = { + operations: bool option ; + length: int option ; + heads: Block_hash.t list option ; + monitor: bool option ; + delay: int option ; + } + val list: + (unit, unit, list_param, block_info list list) RPC.service + + type preapply_param = { + operations: Operation_hash.t list ; + sort: bool ; + timestamp: Time.t option ; + } + type preapply_result = { + operations: error Updater.preapply_result ; + fitness: MBytes.t list ; + timestamp: Time.t ; + } + val preapply: + (unit, unit * block, preapply_param, preapply_result tzresult) RPC.service + + val proto_path: (unit, unit * block) RPC.Path.path + +end + +module Operations : sig + val bytes: + (unit, unit * Operation_hash.t, unit, + Store.operation tzresult Time.timed_data) RPC.service + type list_param = { + contents: bool option ; + monitor: bool option ; + } + val list: + (unit, unit, + list_param, (Operation_hash.t * Store.operation option) list) RPC.service +end + +val forge_block: + (unit, unit, + Updater.net_id option * Block_hash.t option * Time.t option * + Fitness.fitness * Operation_hash.t list * MBytes.t, + MBytes.t) RPC.service + +val validate_block: + (unit, unit, Blocks.net * Block_hash.t, unit tzresult) RPC.service + +val inject_block: + (unit, unit, + (MBytes.t * bool * bool option), + Block_hash.t tzresult) RPC.service + +val inject_operation: + (unit, unit, + (MBytes.t * bool * bool option), Operation_hash.t tzresult) RPC.service + +val describe: + (unit, unit, bool option, RPC.Description.directory_descr) RPC.service diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml new file mode 100644 index 000000000..25a3b1734 --- /dev/null +++ b/src/node/shell/prevalidator.ml @@ -0,0 +1,365 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Node.Prevalidator + +let preapply + st ctxt (module Proto : Updater.REGISTRED_PROTOCOL) block timestamp sort ops = + lwt_debug "-> prevalidate (%d)" (List.length ops) >>= fun () -> + (* The operations list length is bounded by the size of the mempool, + where eventually an operation should not stay more than one hours. *) + Lwt_list.map_p + (fun h -> + State.Operation.read st h >>= function + | None | Some { data = Error _ } -> + Lwt.return_none + | Some { data = Ok op } -> + match Proto.parse_operation h op with + | Error _ -> + (* the operation will never be validated in the + current context, it is silently ignored. It may be + reintroduced in the loop by the next `flush`. *) + Lwt.return_none + | Ok p -> Lwt.return (Some p)) + ops >>= fun ops -> + Proto.preapply ctxt block timestamp sort (Utils.unopt_list ops) >>= function + | Ok (ctxt, r) -> + lwt_debug "<- prevalidate (%d/%d/%d/%d)" + (List.length r.Updater.applied) + (Operation_hash_map.cardinal r.Updater.refused) + (Operation_hash_map.cardinal r.Updater.branch_refused) + (Operation_hash_map.cardinal r.Updater.branch_delayed) >>= fun () -> + Lwt.return (Ok (ctxt, r)) + | Error errors -> + (* FIXME report internal error *) + lwt_debug "<- prevalidate (internal error)" >>= fun () -> + Lwt.return (Error errors) + + +(** Worker *) + +exception Invalid_operation of Operation_hash.t + +type t = { + net: State.Net.t ; + flush: unit -> unit; + register_operation: Operation_hash.t -> unit ; + prevalidate_operations: + bool -> Store.operation list -> + (Operation_hash.t list * error Updater.preapply_result) tzresult Lwt.t ; + operations: unit -> error Updater.preapply_result * Operation_hash_set.t ; + timestamp: unit -> Time.t ; + context: unit -> Context.t ; + protocol: unit -> (module Updater.REGISTRED_PROTOCOL) ; + shutdown: unit -> unit Lwt.t ; +} + +let merge _key a b = + match a, b with + | None, None -> None + | Some x, None -> Some x + | _, Some y -> Some y + +let create p2p net = + + let st = State.Net.state net in + + let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in + let push_to_worker, worker_waiter = Lwt_utils.queue () in + + State.Net.Blockchain.head net >>= fun head -> + State.Net.Blockchain.protocol net >>= fun protocol -> + State.Net.Mempool.get net >>= fun mempool -> + let timestamp = ref (Time.now ()) in + begin + let (module Proto) = protocol in + Proto.preapply head.context head.hash !timestamp false [] >|= function + | Error _ -> ref head.context + | Ok (ctxt, _) -> ref ctxt + end >>= fun context -> + let protocol = ref protocol in + let head = ref head.hash in + let operations = ref Updater.empty_result in + let running_validation = ref Lwt.return_unit in + let unprocessed = ref mempool in + let broadcast_unprocessed = ref false in + + let set_context ctxt = + context := ctxt; + Lwt.return_unit in + + let broadcast_operation ops = + P2p.broadcast + Messages.(to_frame @@ Operation_inventory (State.Net.id net, ops)) + p2p in + + let handle_unprocessed () = + if Operation_hash_set.is_empty !unprocessed then + Lwt.return () + else + (* We assume that `!unprocessed` does not contain any operations + from `!operations`. *) + let ops = !unprocessed in + let broadcast = !broadcast_unprocessed in + unprocessed := Operation_hash_set.empty ; + broadcast_unprocessed := false ; + running_validation := begin + begin + preapply + st !context !protocol !head !timestamp true + (Operation_hash_set.elements ops) >>= function + | Ok (ctxt, r) -> Lwt.return (ctxt, r) + | Error err -> + let r = + { Updater.empty_result with + branch_delayed = + Operation_hash_set.fold + (fun op m -> Operation_hash_map.add op err m) + ops Operation_hash_map.empty ; } in + Lwt.return (!context, r) + end >>= fun (ctxt, r) -> + let filter_out s m = + List.fold_right Operation_hash_map.remove s m in + operations := { + Updater.applied = List.rev_append r.applied !operations.applied ; + refused = Operation_hash_map.empty ; + branch_refused = + Operation_hash_map.merge merge + (* filter_out should not be required here, TODO warn ? *) + (filter_out r.applied !operations.branch_refused) + r.branch_refused ; + branch_delayed = + Operation_hash_map.merge merge + (filter_out r.applied !operations.branch_delayed) + r.branch_delayed ; + } ; + (* Update the Mempool *) + Lwt_list.iter_s + (fun op -> + State.Net.Mempool.add net op >>= fun _ -> + Lwt.return_unit) + r.Updater.applied >>= fun () -> + if broadcast then broadcast_operation r.Updater.applied ; + Lwt_list.iter_s + (fun (op, _exns) -> + State.Net.Mempool.add net op >>= fun _ -> + Lwt.return_unit) + (Operation_hash_map.bindings r.Updater.branch_delayed) >>= fun () -> + Lwt_list.iter_s + (fun (op, _exns) -> + State.Net.Mempool.add net op >>= fun _ -> + Lwt.return_unit) + (Operation_hash_map.bindings r.Updater.branch_refused) >>= fun () -> + Lwt_list.iter_s + (fun (op, exns) -> + State.Net.Mempool.remove net op >>= fun _ -> + State.Operation.mark_invalid st op exns >>= fun _ -> + Lwt.return_unit) + (Operation_hash_map.bindings r.Updater.refused) >>= fun () -> + (* TODO. Keep a bounded set of 'refused' operations. *) + (* TODO. Log the error in some statistics associated to + the peers that informed us of the operations. And + eventually blacklist bad peers. *) + (* TODO. Keep a bounded set of 'branch_refused' operations + into the 'state'. It should be associated to the + current block, and updated on 'set_current_head'. *) + set_context ctxt + end; + Lwt.catch + (fun () -> !running_validation) + (fun _ -> lwt_debug "<- prevalidate (cancel)") + in + + let prevalidation_worker = + + let rec worker_loop () = + (* TODO cleanup the mempool from outdated operation (1h like + Bitcoin ?). And log the removal in some statistic associated + to then peers that informed us of the operation. *) + (* TODO lookup in `!pending` for 'outdated' ops and re-add them + in `unprocessed` (e.g. if the previous tentative was + more 5 seconds ago) *) + handle_unprocessed () >>= fun () -> + Lwt.pick [(worker_waiter () >|= fun q -> `Process q); + (cancelation () >|= fun () -> `Cancel)] >>= function + | `Cancel -> Lwt.return_unit + | `Process q -> + Lwt_list.iter_s + (function + | `Prevalidate (ops, w, force) -> begin + let (module Proto) = !protocol in + let result = + map_s (fun (h, b) -> + State.Operation.known st h >>= function + | true -> + failwith + "Previously injected operation %a" + Operation_hash.pp_short h + | false -> + Lwt.return + (Proto.parse_operation h b + |> record_trace_exn (Invalid_operation h))) + (Operation_hash_map.bindings ops) >>=? fun parsed_ops -> + Proto.preapply + !context !head (Time.now ()) + true parsed_ops >>=? fun (ctxt, res) -> + let register h = + let b = + Store.Operation.to_bytes @@ + Operation_hash_map.find h ops in + State.Operation.(store st b) >>= fun _ -> + State.Net.Mempool.add net h >>= fun _ -> + Lwt.return_unit in + Lwt_list.iter_s + (fun h -> + register h >>= fun () -> + operations := + { !operations with + applied = h :: !operations.applied }; + Lwt.return_unit ) + res.Updater.applied >>= fun () -> + broadcast_operation res.Updater.applied ; + begin + if force then + Lwt_list.iter_p + (fun (h, _exns) -> register h) + (Operation_hash_map.bindings + res.Updater.branch_delayed) >>= fun () -> + Lwt_list.iter_p + (fun (h, _exns) -> register h) + (Operation_hash_map.bindings + res.Updater.branch_refused) >>= fun () -> + operations := + { !operations with + branch_delayed = + Operation_hash_map.merge merge + !operations.branch_delayed res.branch_delayed ; + branch_refused = + Operation_hash_map.merge merge + !operations.branch_refused res.branch_refused ; + } ; + Lwt.return_unit + else + Lwt.return_unit + end >>= fun () -> + set_context ctxt >>= fun () -> + return res + in + result >>= fun result -> + Lwt.wakeup w result ; + Lwt.return_unit + end + | `Register op -> + lwt_debug "register %a" Operation_hash.pp_short op >>= fun () -> + broadcast_unprocessed := true ; + unprocessed := Operation_hash_set.singleton op ; + Lwt.return_unit + | `Flush -> + State.Net.Blockchain.head net >>= fun new_head -> + State.Net.Blockchain.protocol net >>= fun new_protocol -> + State.Net.Mempool.get net >>= fun new_mempool -> + lwt_debug "flush %a (mempool: %d)" + Block_hash.pp_short new_head.hash + (Operation_hash_set.cardinal new_mempool) >>= fun () -> + (* Reset the pre-validation context *) + head := new_head.hash ; + protocol := new_protocol ; + operations := Updater.empty_result; + broadcast_unprocessed := false ; + unprocessed := new_mempool; + timestamp := Time.now (); + (* Tag the context as a prevalidation context. *) + let (module Proto) = new_protocol in + Proto.preapply new_head.context + new_head.hash !timestamp false [] >>= function + | Error _ -> set_context new_head.context + | Ok (ctxt, _) -> set_context ctxt) + q >>= fun () -> + worker_loop () + in + Lwt_utils.worker "prevalidator" ~run:worker_loop ~cancel in + + let flush () = + push_to_worker `Flush; + if not (Lwt.is_sleeping !running_validation) then + Lwt.cancel !running_validation + in + let register_operation op = push_to_worker (`Register op) in + let prevalidate_operations force raw_ops = + let ops = List.map Store.Operation.hash raw_ops in + let ops_map = + List.fold_left + (fun map op -> + Operation_hash_map.add (Store.Operation.hash op) op map) + Operation_hash_map.empty raw_ops in + let wait, waker = Lwt.wait () in + push_to_worker (`Prevalidate (ops_map, waker, force)); + wait >>=? fun result -> + return (ops, result) in + let shutdown () = + lwt_debug "shutdown" >>= fun () -> + if not (Lwt.is_sleeping !running_validation) then + Lwt.cancel !running_validation; + cancel () >>= fun () -> + prevalidation_worker in + + Lwt.return { + net ; + flush ; + register_operation ; + prevalidate_operations ; + operations = + (fun () -> + { !operations with applied = List.rev !operations.applied }, + !unprocessed) ; + timestamp = (fun () -> !timestamp) ; + context = (fun () -> !context) ; + protocol = (fun () -> !protocol) ; + shutdown ; + } + +let flush pv = pv.flush () +let register_operation pv = pv.register_operation +let prevalidate_operations pv = pv.prevalidate_operations +let operations pv = pv.operations () +let timestamp pv = pv.timestamp () +let context pv = pv.context () +let protocol pv = pv.protocol () +let shutdown pv = pv.shutdown () + +let inject_operation pv ?(force = false) (op: Store.operation) = + let State.Net net_id = op.shell.net_id + and State.Net net_id' = State.Net.id pv.net in + let wrap_error h map = + begin + try return (Operation_hash_map.find h map) + with Not_found -> + failwith "unexpected protocol result" + end >>=? fun errors -> + Lwt.return (Error errors) in + fail_unless (Block_hash.equal net_id net_id') + (Unclassified + "Prevalidator.inject_operation: invalid network") >>=? fun () -> + pv.prevalidate_operations force [op] >>=? function + | ([h], { Updater.applied = [h'] }) when Operation_hash.equal h h' -> + return () + | ([h], { Updater.refused }) + when Operation_hash_map.cardinal refused = 1 -> + wrap_error h refused + | ([h], { Updater.branch_refused }) + when Operation_hash_map.cardinal branch_refused = 1 && not force -> + wrap_error h branch_refused + | ([h], { Updater.branch_delayed }) + when Operation_hash_map.cardinal branch_delayed = 1 && not force -> + wrap_error h branch_delayed + | _ -> + if force then + return () + else + failwith "Unexpected result for prevalidation." diff --git a/src/node/shell/prevalidator.mli b/src/node/shell/prevalidator.mli new file mode 100644 index 000000000..7b5b3d78f --- /dev/null +++ b/src/node/shell/prevalidator.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** The prevalidation worker is in charge of the "mempool" (a.k.a. the + set of known not-invalid-for-sure operations that are not yet + included in the blockchain). + + The worker also maintains a sorted subset of the mempool that + might correspond to a valid block on top of the current head. The + "in-progress" context produced by the application of those + operations is called the (pre)validation context. + + Before to include an operation into the mempool, the prevalidation + worker tries to append the operation the prevalidation context. If + the operation is (strongly) refused, it will not be added into the + mempool and then it will be ignored by the node and never + broadcasted. If the operation is only "branch_refused" or + "branch_delayed", the operation won't be appended in the + prevalidation context, but still broadcasted. + +*) + +type t + +(** Creation and destruction of a "prevalidation" worker. *) +val create: P2p.net -> State.Net.t -> t Lwt.t +val shutdown: t -> unit Lwt.t + +(** Notify the prevalidator of a new operation. This is the + entry-point used by the P2P layer. The operation content has been + previously stored on disk. *) +val register_operation: t -> Operation_hash.t -> unit + +(** Conditionnaly inject a new operation in the node: the operation will + be ignored when it is (strongly) refused This is the + entry-point used by the P2P layer. The operation content has been + previously stored on disk. *) +val inject_operation: + t -> ?force:bool -> Store.operation -> unit tzresult Lwt.t + +val flush: t -> unit +val timestamp: t -> Time.t +val operations: t -> error Updater.preapply_result * Operation_hash_set.t +val context: t -> Context.t +val protocol: t -> (module Updater.REGISTRED_PROTOCOL) + +val preapply: + State.state -> Context.t -> (module Updater.REGISTRED_PROTOCOL) -> + Block_hash.t -> Time.t -> bool -> Operation_hash.t list -> + (Context.t * error Updater.preapply_result) tzresult Lwt.t diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml new file mode 100644 index 000000000..95179d8c1 --- /dev/null +++ b/src/node/shell/state.ml @@ -0,0 +1,1157 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Node.State + +type error += + | Invalid_fitness of Fitness.fitness * Fitness.fitness + | Unknown_protocol of Protocol_hash.t + | Inactive_network of Store.net_id + | Unknown_network of Store.net_id + | Cannot_parse + +let () = + Error_monad.register_error_kind + `Temporary + ~id:"state.invalid_fitness" + ~title:"Invalid fitness" + ~description:"The computed fitness differs from the fitness found \ + \ in the block header." + ~pp:(fun ppf (expected, found) -> + Format.fprintf ppf + "@[Invalid fitness@ \ + \ expected %a@ \ + \ found %a" + Fitness.pp expected + Fitness.pp found) + Data_encoding.(obj2 + (req "expected" Fitness.encoding) + (req "found" Fitness.encoding)) + (function Invalid_fitness (e, f) -> Some (e, f) | _ -> None) + (fun (e, f) -> Invalid_fitness (e, f)) ; + Error_monad.register_error_kind + `Temporary + ~id:"state.unknown_network" + ~title:"Unknown network" + ~description:"TODO" + ~pp:(fun ppf (Store.Net id) -> + Format.fprintf ppf "Unknown network %a" Block_hash.pp_short id) + Data_encoding.(obj1 (req "net" Updater.net_id_encoding)) + (function Unknown_network x -> Some x | _ -> None) + (fun x -> Unknown_network x) ; + +module Watcher = struct + + type 'a t = { + id: int ; + push: ('a option -> unit) ; + } + + let notify watchers info = + List.iter (fun w -> w.push (Some info)) watchers + + let create_stream watchers = + let cpt = ref 0 in + fun () -> + let id = incr cpt ; !cpt in + let stream, push = Lwt_stream.create () in + watchers := { id ; push } :: !watchers ; + let unregister () = + push None ; + watchers := List.filter (fun w -> w.id <> id) !watchers in + stream, unregister + +end + +(** *) + +type net_id = Store.net_id = Net of Block_hash.t + +type t = { + mutable active_net: net list ; + nets: net Block_hash_table.t ; + store: Store.store ; + block_db: Db_proxy.Block.t ; + block_watchers: (Block_hash.t * Store.block_header) Watcher.t list ref ; + operation_db: Db_proxy.Operation.t ; + operation_watchers: + (Operation_hash.t * Store.operation) Watcher.t list ref ; + valid_block_state: valid_block_state Persist.shared_ref ; +} + +and state = t + +and net = { + state: state ; + net_store: Store.net_store ; + blockchain_state: blockchain_state Persist.shared_ref ; +} + +and valid_block_state = { + global_store: Store.generic_store Persist.shared_ref ; + ttl: Int64.t ; + index: Context.index ; + block_db: Db_proxy.Block.t ; + watchers: valid_block Watcher.t list ref ; +} + +and blockchain_state = { + genesis_block: valid_block ; + current_head: valid_block ; + current_protocol: (module Updater.REGISTRED_PROTOCOL) ; + mempool: Operation_hash_set.t ; + blockchain_store: Store.blockchain_store Persist.shared_ref ; +} + +and valid_block = { + net_id: net_id ; + hash: Block_hash.t ; + pred: Block_hash.t ; + timestamp: Time.t ; + fitness: Protocol.fitness ; + operations: Operation_hash.t list ; + discovery_time: Time.t ; + protocol_hash: Protocol_hash.t ; + protocol: (module Updater.REGISTRED_PROTOCOL) option ; + test_protocol_hash: Protocol_hash.t ; + test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; + test_network: (net_id * Time.t) option ; + context: Context.t ; + successors: Block_hash_set.t ; + invalid_successors: Block_hash_set.t ; +} + +module KnownHeads_key = struct + include Block_hash + let prefix = ["state"; "known_heads"] + let length = path_len +end +module KnownHeads = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (KnownHeads_key) (Block_hash_set) + +module KnownNets_key = struct + include Block_hash + let prefix = ["state"; "known_nets"] + let length = path_len +end +module KnownNets = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (KnownNets_key) (Block_hash_set) + +module InvalidOperations_key = struct + include Operation_hash + let prefix = ["state"; "invalid_operations"] + let length = path_len +end +module InvalidOperations = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (InvalidOperations_key) (Operation_hash_set) + +module InvalidBlocks_key = struct + include Block_hash + let prefix = ["state"; "invalid_blocks"] + let length = path_len +end +module InvalidBlocks = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (InvalidBlocks_key) (Block_hash_set) + +module PostponedBlocks_key = struct + include Block_hash + let prefix = ["state"; "postponed_blocks"] + let length = path_len +end +module PostponedBlocks = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (PostponedBlocks_key) (Block_hash_set) + +let net_is_active { active_net } net_id = + let same_id (Net id) { net_store = { net_genesis = { block } } } = + Block_hash.equal id block in + List.exists (same_id net_id) active_net + +module Operation = struct + type key = Store.Operation.key + type shell_header = Store.shell_operation = { + net_id: net_id ; + } + type t = Store.operation = { + shell: shell_header ; + proto: MBytes.t ; + } + type operation = t + exception Invalid of key * error list + let of_bytes = Store.Operation.of_bytes + let to_bytes = Store.Operation.to_bytes + let known t k = Db_proxy.Operation.known t.operation_db k + let read t k = Db_proxy.Operation.read t.operation_db k + let read_exn t k = + Db_proxy.Operation.read t.operation_db k >>= function + | None -> Lwt.fail Not_found + | Some { data = Error e } -> Lwt.fail (Invalid (k, e)) + | Some { data = Ok data ; time } -> Lwt.return { Time.data ; time } + let hash = Store.Operation.hash + let raw_read t k = + Persist.use t.store.Store.operation + (fun store -> Store.Operation.raw_get store k) + let prefetch t net_id ks = + List.iter (Db_proxy.Operation.prefetch t.operation_db net_id) ks + let fetch t net_id k = Db_proxy.Operation.fetch t.operation_db net_id k + let store t bytes = + match of_bytes bytes with + | None -> fail Cannot_parse + | Some op -> + if not (net_is_active t op.shell.net_id) then + fail (Inactive_network op.shell.net_id) + else + let h = hash op in + Db_proxy.Operation.store t.operation_db h (Time.make_timed (Ok op)) + >>= function + | true -> + Watcher.notify !(t.operation_watchers) (h, op) ; + return (Some (h, op)) + | false -> + return None + let mark_invalid t k e = + Db_proxy.Operation.update t.operation_db k (Time.make_timed (Error e)) + >>= function + | true -> + Persist.update t.store.global_store (fun store -> + InvalidOperations.set store k >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + Lwt.return true + | false -> Lwt.return false + + let invalid state = + Persist.use state.store.global_store InvalidOperations.read + + let create_watcher t = Watcher.create_stream t.operation_watchers () + +end + +module Block = struct + + type shell_header = Store.shell_block_header = { + net_id: net_id ; + predecessor: Block_hash.t ; + timestamp: Time.t ; + fitness: MBytes.t list ; + operations: Operation_hash.t list ; + } + type t = Store.block_header = { + shell: shell_header ; + proto: MBytes.t ; + } + type block = t + let of_bytes = Store.Block.of_bytes + let to_bytes = Store.Block.to_bytes + + let known t k = Db_proxy.Block.known t.block_db k + let db_read db k = + Db_proxy.Block.read db k >>= function + | None -> Lwt.return_none + | Some (_, lazy block) -> block + let read t k = db_read t.block_db k + let read_exn t k = + read t k >>= function + | None -> Lwt.fail Not_found + | Some { data = data ; time } -> Lwt.return { Time.data ; time } + let hash = Store.Block.hash + let raw_read t k = + Persist.use t.store.Store.block + (fun store -> Store.Block.raw_get store k) + let read_pred t k = + Db_proxy.Block.read t.block_db k >>= function + | None -> Lwt.return_none + | Some (pred, _) -> Lwt.return (Some pred) + let read_pred_exn t k = + read_pred t k >>= function + | None -> Lwt.fail Not_found + | Some pred -> Lwt.return pred + let prefetch t net_id ks = + List.iter (Db_proxy.Block.prefetch t.block_db net_id) ks + let fetch t net_id k = + Db_proxy.Block.fetch t.block_db net_id k >>= fun (_, lazy block) -> + block >>= function + | None -> assert false + | Some block -> Lwt.return block + let db_store db k (v: Store.block_header) = + Db_proxy.Block.store db k + (v.shell.predecessor, lazy (Lwt.return (Some (Time.make_timed v)))) + let store t bytes = + match of_bytes bytes with + | None -> fail Cannot_parse + | Some b -> + if not (net_is_active t b.shell.net_id) then + fail (Inactive_network b.shell.net_id) + else + let h = hash b in + db_store t.block_db h b >>= function + | true -> + Persist.update t.store.global_store (fun store -> + PostponedBlocks.set store h >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + Watcher.notify !(t.block_watchers) (h, b) ; + return (Some (h, b)) + | false -> return None + let create_watcher t = Watcher.create_stream t.block_watchers () + + let check_block state h = + known state h >>= function + | true -> return () + | false -> failwith "Unknown block" + + let path state h1 h2 = + trace_exn (Failure "State.path") begin + check_block state h1 >>=? fun () -> + check_block state h2 >>=? fun () -> + let rec loop acc h = + if Block_hash.equal h h1 then + return acc + else + read_pred state h >>= function + | None -> failwith "not an ancestor" + | Some pred -> + loop (h :: acc) pred in + loop [] h2 + end + + let common_ancestor state h1 h2 = + trace_exn (Failure "State.common_ancestor") begin + check_block state h1 >>=? fun () -> + check_block state h2 >>=? fun () -> + let queue = Queue.create () in + let rec visit seen = + let h = Queue.pop queue in + if Block_hash_set.mem h seen then + return h + else + let seen = Block_hash_set.add h seen in + read_pred state h >>= function + | None -> failwith ".." + | Some pred -> + if not (Block_hash.equal pred h) then + Queue.push pred queue; + visit seen + in + Queue.push h1 queue; + Queue.push h2 queue; + Lwt.catch + (fun () -> visit Block_hash_set.empty) + (function exn -> Lwt.return (error_exn exn)) + end + + let rec block_locator_loop state acc sz step cpt h = + if sz = 0 then Lwt.return (List.rev acc) else + read_pred state h >>= function + | None -> Lwt.return (List.rev (h :: acc)) + | Some pred -> + if cpt = 0 then + block_locator_loop state + (h :: acc) (sz - 1) (step * 2) (step * 20 - 1) pred + else if cpt mod step = 0 then + block_locator_loop state (h :: acc) (sz - 1) step (cpt - 1) pred + else + block_locator_loop state acc sz step (cpt - 1) pred + + let block_locator state sz h = + trace_exn (Failure "State.block_locator") begin + check_block state h >>=? fun () -> + block_locator_loop state [] sz 1 9 h >>= fun locator -> + return locator + end + +end + +module Valid_block = struct + + type t = valid_block = { + net_id: net_id ; + hash: Block_hash.t ; + pred: Block_hash.t ; + timestamp: Time.t ; + fitness: Protocol.fitness ; + operations: Operation_hash.t list ; + discovery_time: Time.t ; + protocol_hash: Protocol_hash.t ; + protocol: (module Updater.REGISTRED_PROTOCOL) option ; + test_protocol_hash: Protocol_hash.t ; + test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; + test_network: (net_id * Time.t) option ; + context: Context.t ; + successors: Block_hash_set.t ; + invalid_successors: Block_hash_set.t ; + } + type valid_block = t + + let use state f = Persist.use state.valid_block_state f + let update state f = Persist.update state.valid_block_state f + let update_with_res state f = Persist.update_with_res state.valid_block_state f + + let raw_read' { Time.data = { Store.shell = block } ; + time = discovery_time } successors invalid_successors index hash = + Context.checkout index hash >>= function + | (None | Some (Error _)) as e -> Lwt.return e + | Some (Ok context) -> + Context.get_protocol context >>= fun protocol_hash -> + Context.get_test_protocol context >>= fun test_protocol_hash -> + Context.get_test_network context >>= fun test_network -> + Context.get_test_network_expiration + context >>= fun test_network_expiration -> + let test_network = + match test_network, test_network_expiration with + | None, _ | _, None -> None + | Some net_id, Some time -> Some (net_id, time) in + let protocol = Updater.get protocol_hash in + let test_protocol = Updater.get test_protocol_hash in + let valid_block = { + net_id = block.net_id ; + hash ; + pred = block.predecessor ; + timestamp = block.timestamp ; + discovery_time ; + operations = block.operations ; + fitness = block.fitness ; + protocol_hash ; + protocol ; + test_protocol_hash ; + test_protocol ; + test_network ; + context ; + successors ; + invalid_successors ; + } in + Lwt.return (Some (Ok valid_block)) + + let raw_read store block_db index hash = + Block.db_read block_db hash >>= function + | None -> + (* TODO handle internal error... *) + Lwt.return_none + | Some block -> + Persist.use store (fun store -> + Store.Block_valid_succs.get store hash >|= function + | None -> Block_hash_set.empty + | Some set -> set) >>= fun valid_successors -> + Persist.use store (fun store -> + Store.Block_invalid_succs.get store hash >|= function + | None -> Block_hash_set.empty + | Some set -> set) >>= fun invalid_successors -> + raw_read' block valid_successors invalid_successors index hash + + let create ?patch_context ~context_root store block_db ttl = + Context.init ?patch_context ~root:context_root >>= fun index -> + let ttl = Int64.of_int ttl in + Lwt.return + (Persist.share { global_store = store ; + block_db ; index ; + ttl ; watchers = ref [] }) + + let locked_valid vstate h = + Context.checkout vstate.index h >>= function + | None | Some (Error _) -> Lwt.return_false + | Some (Ok _) -> Lwt.return true + + let locked_known vstate h = Context.exists vstate.index h + + exception Invalid of Block_hash.t * error list + + let locked_read (vstate: valid_block_state) hash = + raw_read vstate.global_store vstate.block_db vstate.index hash + + let locked_read_exn vstate hash = + locked_read vstate hash >>= function + | None -> Lwt.fail Not_found + | Some (Error e) -> Lwt.fail (Invalid (hash, e)) + | Some (Ok data) -> Lwt.return data + + let locked_store vstate hash context = + Context.exists vstate.index hash >>= function + | true -> Lwt.return (Error []) (* TODO fail ?? *) + | false -> + Block.db_read vstate.block_db hash >>= function + | None -> assert false + | Some { data = block } -> + Context.get_protocol context >>= fun protocol_hash -> + match Updater.get protocol_hash with + | None -> + lwt_log_error + "State.Validated_block: unknown protocol (%a)" + Protocol_hash.pp_short protocol_hash >>= fun () -> + Lwt.return (Error [Unknown_protocol protocol_hash]) + | Some (module Proto) -> + Proto.fitness context >>= fun fitness -> + if Fitness.compare fitness block.Store.shell.fitness <> 0 + then begin + let err = Invalid_fitness (block.Store.shell.fitness, fitness) in + Context.commit_invalid + vstate.index block hash [err] >>= fun () -> + Lwt.return (Error [err]) + end else begin + Context.read_and_reset_fork_test_network + context >>= fun (fork, context) -> + begin + if fork then begin + let eol = Time.(add block.shell.timestamp vstate.ttl) in + Context.set_test_network + context (Net hash) >>= fun context -> + Context.set_test_network_expiration context + eol >>= fun context -> + lwt_log_notice "Fork test network for %a (eol: %a)" + Block_hash.pp_short hash Time.pp_hum eol >>= fun () -> + Lwt.return context + end else begin + Context.get_test_network_expiration context >>= function + | Some eol when Time.(eol <= now ()) -> + lwt_log_notice + "Stop test network for %a (eol: %a, now: %a)" + Block_hash.pp_short hash + Time.pp_hum eol Time.pp_hum (Time.now ()) + >>= fun () -> + Context.del_test_network context >>= fun context -> + Context.del_test_network_expiration context + | None | Some _ -> Lwt.return context + end + end >>= fun context -> + Context.commit vstate.index block hash context >>= fun () -> + locked_read_exn vstate hash >>= fun valid_block -> + Persist.update vstate.global_store (fun store -> + KnownHeads.del store block.shell.predecessor >>= fun store -> + KnownHeads.set store hash >>= fun store -> + PostponedBlocks.del store hash >>= fun store -> + begin + Store.Block_valid_succs.get + store block.shell.predecessor >|= function + | None -> Block_hash_set.singleton hash + | Some set -> Block_hash_set.add hash set + end >>= fun successors -> + Store.Block_valid_succs.set + store block.shell.predecessor successors >>= fun () -> + Lwt.return (Some store)) >>= fun _ -> + Watcher.notify !(vstate.watchers) valid_block ; + Lwt.return (Ok valid_block) + end + + let create_genesis_block state (genesis: Store.genesis) test_protocol = + use state (fun vstate -> + locked_read vstate genesis.block >>= function + | Some res -> + (* TODO check coherency: test_protocol. *) + Lwt.return res + | None -> + let test_protocol = Utils.unopt genesis.protocol test_protocol in + Context.create_genesis_context + vstate.index genesis test_protocol >>= fun _context -> + Block.db_store vstate.block_db genesis.block { + shell = { + net_id = Net genesis.block ; + predecessor = genesis.block ; + timestamp = genesis.time ; + fitness = [] ; + operations = [] ; + } ; + proto = MBytes.create 0 ; + } >>= fun _ -> + locked_read vstate genesis.block >>= function + | None -> failwith "" + | Some (Error _ as err) -> Lwt.return err + | Some (Ok valid_block) -> + Persist.update vstate.global_store (fun store -> + KnownHeads.set store valid_block.hash >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + return valid_block) + + let locked_store_invalid vstate hash exns = + Context.exists vstate.index hash >>= function + | true -> Lwt.return false (* TODO fail ?? *) + | false -> + Block.db_read vstate.block_db hash >>= function + | None -> assert false + | Some { data = block } -> + Context.commit_invalid vstate.index block hash exns >>= fun () -> + Persist.update vstate.global_store (fun store -> + InvalidBlocks.set store hash >>= fun store -> + begin + Store.Block_invalid_succs.get + store block.shell.predecessor >|= function + | None -> Block_hash_set.singleton hash + | Some set -> Block_hash_set.add hash set + end >>= fun successors -> + Store.Block_invalid_succs.set + store block.shell.predecessor successors >>= fun () -> + Lwt.return (Some store)) >>= fun _ -> + Lwt.return true + + let get_store { valid_block_state } = valid_block_state + + let valid state h = + use state (fun vstate -> locked_valid vstate h) + let known state h = + use state (fun vstate -> locked_known vstate h) + let read state hash = + use state (fun vstate -> locked_read vstate hash) + let read_exn state hash = + use state (fun vstate -> locked_read_exn vstate hash) + let store state hash context = + use state + (fun vstate -> locked_store vstate hash context) >>= fun block -> + Lwt.return block + let store_invalid state hash exns = + use state (fun vstate -> locked_store_invalid vstate hash exns) + + let known_heads state = + use state (fun vstate -> + Persist.use vstate.global_store KnownHeads.read >>= fun heads -> + let elements = Block_hash_set.elements heads in + Lwt_list.fold_left_s + (fun set hash -> + Block.db_read vstate.block_db hash >>= function + | None -> Lwt.return set + | Some block -> + Persist.use vstate.global_store (fun store -> + begin + Store.Block_invalid_succs.get + store block.data.shell.predecessor >|= function + | None -> Block_hash_set.singleton hash + | Some set -> set + end) >>= fun invalid_successors -> + raw_read' block Block_hash_set.empty + invalid_successors vstate.index hash >>= function + | Some (Ok bl) -> Lwt.return (Block_hash_map.add hash bl set) + | None | Some (Error _) -> + lwt_log_error + "Error while reading \"known_heads\". Ignoring %a." + Block_hash.pp_short hash >>= fun () -> + Lwt.return set) + Block_hash_map.empty + elements) + + let postponed state = + use state (fun vstate -> + Persist.use vstate.global_store PostponedBlocks.read) + + let invalid state = + use state (fun vstate -> + Persist.use vstate.global_store InvalidBlocks.read) + + let path state b1 b2 = + let rec loop acc b = + if Block_hash.equal b.hash b1.hash then + Lwt.return (Some acc) + else + read state b.pred >>= function + | None -> Lwt.return None + | Some (Error _) -> assert false + | Some (Ok pred) -> loop (b :: acc) pred in + loop [] b2 + + let common_ancestor state b1 b2 = + let queue = Queue.create () in + let rec visit seen = + let b = Queue.pop queue in + if Block_hash_set.mem b.hash seen then + Lwt.return b + else + let seen = Block_hash_set.add b.hash seen in + read state b.pred >>= function + | None -> visit seen + | Some (Error _) -> assert false + | Some (Ok pred) -> + if not (Block_hash.equal pred.hash b.hash) then + Queue.push pred queue; + visit seen + in + Queue.push b1 queue; + Queue.push b2 queue; + visit Block_hash_set.empty + + let block_locator state sz b = + Block.block_locator_loop state [] sz 1 9 b.hash + + let new_blocks state cur_block new_block = + common_ancestor state cur_block new_block >>= fun ancestor -> + path state ancestor new_block >>= function + | None -> assert false + | Some path -> Lwt.return (ancestor, path) + + let create_watcher state = + use state (fun vstate -> + Lwt.return (Watcher.create_stream vstate.watchers ())) + + module Store = struct + type t = valid_block_state + type key = Block_hash.t + type value = Context.t tzresult + let mem vstate h = locked_known vstate h + let del _ _ = assert false (* unused *) + let get vstate hash = + locked_read vstate hash >>= function + | None -> Lwt.return None + | Some (Ok { context }) -> Lwt.return (Some (Ok context)) + | Some (Error exns) -> Lwt.return (Some (Error exns)) + let set vstate hash = function + | Ok context -> begin + locked_store vstate hash context >>= fun _ -> + Lwt.return vstate + end + | Error exns -> + locked_store_invalid vstate hash exns >>= fun _changed -> + Lwt.return vstate + end + +end + +module Blockchain = struct + + let use state f = Persist.use state.blockchain_state f + let update state f = Persist.update state.blockchain_state f + + let read_state, store_state = + let current_block_key = ["current_block"] in + let module Mempool_key = struct + include Operation_hash + let prefix = ["mempool"] + let length = path_len + end in + let module Mempool = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (Mempool_key) (Operation_hash_set) in + let read genesis gstore sstore (vstate: valid_block_state) = + begin + Valid_block.locked_read vstate genesis.Store.block >>= function + | None | Some (Error _) -> fatal_error "" + | Some (Ok genesis_block) -> + match genesis_block.test_network with + | None -> Lwt.return genesis_block + | Some _ -> + let context = genesis_block.context in + Context.del_test_network context >>= fun context -> + Context.set_protocol + context genesis_block.test_protocol_hash >>= fun context -> + Lwt.return + { genesis_block with + net_id = Net genesis_block.hash ; + context ; + protocol = genesis_block.test_protocol ; + protocol_hash = genesis_block.test_protocol_hash ; + test_network = None ; + } + end >>= fun genesis_block -> + begin + Persist.use gstore (fun store -> + Store.get store current_block_key) >>= function + | None -> Lwt.return genesis.Store.block + | Some current_block -> Lwt.return (Block_hash.of_bytes current_block) + end >>= fun current_head_hash -> + begin + if Block_hash.equal current_head_hash genesis_block.hash then + Lwt.return genesis_block + else + Valid_block.locked_read vstate current_head_hash >>= function + | None -> fatal_error "Internal error while loading the current block." + | Some (Error exn) -> + fatal_error + "@[Internal error while loading the current block:@ %a@]" + (fun ppf -> Error_monad.pp_print_error ppf) exn + | Some (Ok current_head) -> + Lwt.return current_head + end >>= fun current_head -> + Persist.use gstore Mempool.read >>= fun mempool -> + let current_protocol = + match current_head.protocol with + | None -> fatal_error "Protocol version for the current head is unknown" + | Some protocol -> protocol in + Lwt.return + (Persist.share { current_head ; current_protocol ; genesis_block ; + mempool ; blockchain_store = sstore }) + in + let store net { current_head ; mempool } = + Persist.update net.net_store.net_store (fun store -> + Store.set store current_block_key + (Block_hash.to_bytes current_head.hash) >>= fun () -> + Mempool.write store mempool >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + Lwt.return_unit + in + (read, store) + + let locked_head bstate = Lwt.return bstate.current_head + + let locked_protocol bstate = Lwt.return bstate.current_protocol + + let locked_mem (bstate : blockchain_state) store h = + let genesis = bstate.genesis_block.hash in + if Block_hash.equal genesis h then + Lwt.return true + else + Store.Blockchain.mem store h + + let genesis net = + use net (fun vstate -> Lwt.return vstate.genesis_block) + + let head net = use net locked_head + let protocol net = use net locked_protocol + let mem net h = + use net (fun bstate -> + Persist.use bstate.blockchain_store (fun store -> + locked_mem bstate store h)) + + let find_new net hist sz = + let rec path net_id store sz acc h = + if sz <= 0 then return (List.rev acc) + else + Store.Blockchain_succ.get store h >>= function + | None -> return (List.rev acc) + | Some s -> path net_id store (sz-1) (s :: acc) s + in + let rec common_ancestor (bstate: blockchain_state) store hist = + match hist with + | [] -> + Lwt.return bstate.genesis_block.hash + | h :: hist -> + locked_mem bstate store h >>= function + | false -> common_ancestor bstate store hist + | true -> Lwt.return h in + use net (fun bstate -> + Persist.use bstate.blockchain_store + (fun store -> + common_ancestor bstate store hist >>= fun ancestor -> + let net_id = Net bstate.genesis_block.hash in + if Block_hash.equal ancestor bstate.genesis_block.hash then + Store.Blockchain_test_succ.get store ancestor >>= function + | None -> + if Block_hash.equal ancestor bstate.current_head.hash then + return [] + else + return [ancestor] + | Some s -> path net_id store (sz-1) [ancestor] s + else + path net_id store sz [] ancestor + )) + + let pop_block state bstate = + lwt_debug "pop_block %a" + Block_hash.pp_short bstate.current_head.hash >>= fun () -> + Valid_block.read_exn state bstate.current_head.pred >>= fun pred_block -> + Persist.use bstate.blockchain_store (fun sstore -> + Store.Blockchain.del sstore bstate.current_head.hash >>= fun () -> + if Block_hash.equal pred_block.hash bstate.genesis_block.hash then + Store.Blockchain_test_succ.del sstore pred_block.hash + else + Store.Blockchain_succ.del sstore pred_block.hash) >>= fun () -> + let mempool = + List.fold_left + (fun mempool h -> Operation_hash_set.add h mempool) + bstate.mempool bstate.current_head.operations in + Lwt.return { bstate with current_head = pred_block ; mempool } + + let rec pop_blocks state bstate ancestor = + if not (Block_hash.equal bstate.current_head.hash ancestor) then begin + pop_block state bstate >>= fun bstate -> + pop_blocks state bstate ancestor + end else + Lwt.return bstate + + let push_block time (bstate: blockchain_state) (block: valid_block) = + lwt_debug "push_block %a" Block_hash.pp_short block.hash >>= fun () -> + Persist.use bstate.blockchain_store (fun sstore -> + Store.Blockchain.set sstore block.hash time >>= fun () -> + if Block_hash.equal block.pred bstate.genesis_block.hash then + Store.Blockchain_test_succ.set sstore block.pred block.hash + else + Store.Blockchain_succ.set sstore block.pred block.hash) >>= fun () -> + let mempool = + List.fold_left + (fun mempool h -> Operation_hash_set.remove h mempool) + bstate.mempool block.operations in + Lwt.return { bstate with current_head = block ; mempool } + + let locked_set_head net bstate block = + let Net net_id = block.net_id in + if not (Block_hash.equal net_id net.net_store.net_genesis.block) then + invalid_arg "State.Blockchain.set_head" ; + lwt_debug "set_head %a" Block_hash.pp_short block.hash >>= fun () -> + let current_protocol = + match block.protocol with + | None -> + fatal_error "Protocol version for the new head is unknown" + | Some protocol -> protocol in + Valid_block.new_blocks + net.state bstate.current_head block >>= fun (ancestor, path) -> + pop_blocks net.state bstate ancestor.hash >>= fun bstate -> + let time = Time.now () in + Lwt_list.fold_left_s + (push_block time) bstate path >>= fun bstate -> + let bstate = { bstate with current_protocol } in + store_state net bstate >>= fun () -> + Lwt.return (Some bstate) + + let set_head net block = + update net (fun bstate -> locked_set_head net bstate block) >>= fun _ -> + Lwt.return_unit + + let test_and_set_head net ~old block = + update net (fun bstate -> + if not (Block_hash.equal bstate.current_head.hash old.hash) then + Lwt.return None + else + locked_set_head net bstate block) + +end + +module Mempool = struct + + let use = Blockchain.use + let update = Blockchain.update + + let get net = + use net (fun bstate -> Lwt.return bstate.mempool) + + let add net h = + update net (fun bstate -> + if Operation_hash_set.mem h bstate.mempool then + Lwt.return_none + else begin + let bstate = + { bstate with + mempool = Operation_hash_set.add h bstate.mempool } in + Lwt.return (Some bstate) + end) + + let remove net h = + update net (fun bstate -> + if Operation_hash_set.mem h bstate.mempool then begin + let bstate = + { bstate with + mempool = Operation_hash_set.remove h bstate.mempool } in + Lwt.return (Some bstate) + end else + Lwt.return_none) + + let for_block net block = + let rec pop acc ancestor block = + if Block_hash.equal ancestor.hash block.hash then + Lwt.return acc + else begin + let acc = + let add acc x = Operation_hash_set.add x acc in + List.fold_left add acc block.operations in + Valid_block.read_exn net.state block.pred >>= fun pred -> + pop acc ancestor pred + end in + use net (fun bstate -> + Valid_block.new_blocks + net.state bstate.current_head block >>= fun (ancestor, path) -> + pop bstate.mempool ancestor bstate.current_head >|= fun ops -> + List.fold_left + (fun ops (b: valid_block) -> + let del acc x = Operation_hash_set.remove x acc in + List.fold_left del ops b.operations) + ops + path) + +end + +module Net = struct + + type t = net + type net = t + + module Blockchain = Blockchain + module Mempool = Mempool + + let raw_create state (net_store : Store.net_store) = + Persist.use state.valid_block_state (fun vstate -> + Blockchain.read_state + net_store.net_genesis + net_store.net_store + state.store.blockchain vstate) + >|= fun blockchain_state -> + { state ; net_store ; blockchain_state } + + let read_state, store_state = + let read state store = + Persist.use store.Store.global_store KnownNets.read >>= fun nets -> + let elements = Block_hash_set.elements nets in + Lwt_list.iter_p + (fun hash -> + store.net_read (Net hash) >>= function + | Error err -> + lwt_log_error "@[Error while loading net:@ %a@]" + Error_monad.pp_print_error err + | Ok net_store -> + raw_create state net_store >>= fun net -> + Block_hash_table.add state.nets hash net ; + Lwt.return () + ) + elements + in + let store { store = { global_store }; nets } = + Persist.update global_store + (fun store -> + let nets = + Block_hash_table.fold + (fun h _ s -> Block_hash_set.add h s) + nets Block_hash_set.empty in + KnownNets.write store nets >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + Lwt.return_unit in + (read, store) + + let state { state } = state + let active { active_net } = active_net + let get { nets } (Net b) = + try ok (Block_hash_table.find nets b) + with Not_found -> error (Unknown_network (Net b)) + let all { nets } = + Block_hash_table.fold (fun _ net acc -> net :: acc) nets [] + let id { net_store = { net_genesis = { block } } } = Net block + let expiration { net_store = { net_expiration } } = net_expiration + let same_id (Net id') net = + let Net id = id net in + Block_hash.equal id id' + let is_active { active_net } net_id = + List.exists (same_id net_id) active_net + let activate net = + let s = net.state in + let net_id = id net in + if not (List.exists (same_id net_id) s.active_net) then + s.active_net <- net :: s.active_net + let deactivate net = + let s = net.state in + let net_id = id net in + s.active_net <- + List.filter (fun net -> not (same_id net_id net)) s.active_net + + let create state ?expiration ?test_protocol net_genesis = + Valid_block.create_genesis_block + state net_genesis test_protocol >>=? fun _ -> + state.store.net_init ?expiration net_genesis >>= fun net_store -> + raw_create state net_store >>= fun net -> + store_state state >>= fun () -> + Block_hash_table.add state.nets net_genesis.block net ; + return net + + let cleanup_blocks_and_operations net = + let Net net_id = id net in + let same_id (Net id) = Block_hash.equal net_id id in + let cleanup_operation h = + ignore @@ + Persist.use net.state.store.operation (fun store -> + Store.Operation.del store h) in + let rec cleanup_block h = + Block.read net.state h >>= function + | Some b when same_id b.data.shell.net_id -> + Persist.use net.state.store.block (fun store -> + Store.Block.del store h) >>= fun () -> + List.iter cleanup_operation b.data.shell.operations ; + cleanup_block b.data.shell.predecessor ; + | None | Some _ -> Lwt.return_unit in + Mempool.get net >>= fun ops -> + Operation_hash_set.iter cleanup_operation ops ; + Valid_block.postponed net.state >>= fun postponed -> + Block_hash_set.iter (fun h -> ignore (cleanup_block h)) postponed ; + Valid_block.known_heads net.state >>= fun known_heads -> + Block_hash_map.iter + (fun _ v -> + if same_id v.net_id then + ignore @@ begin + Persist.use net.state.store.block (fun store -> + Store.Block.del store v.hash) >>= fun () -> + cleanup_block v.pred + end) + known_heads ; + Lwt.return_unit + + let destroy net = + lwt_debug "destroy %a" Store.pp_net_id (id net) >>= fun () -> + let Net net_genesis as net_id = id net in + Block_hash_table.remove net.state.nets net_genesis ; + net.state.active_net <- + List.filter (fun net -> id net <> net_id) net.state.active_net ; + store_state net.state >>= fun () -> + net.state.store.net_destroy net.net_store >>= fun () -> + Lwt.async (fun () -> cleanup_blocks_and_operations net); + Lwt.return_unit + +end + + +let () = + let open Data_encoding in + register_error_kind `Permanent + ~id:"refusedOperation" + ~title: "Refused operation" + ~description: + "An operation that will never be accepted (by any protocol version)." + ~pp:(fun ppf hash -> + Format.fprintf ppf "Refused operation %a" + Operation_hash.pp_short hash) + (obj1 (req "operation_hash" Operation_hash.encoding)) + (function Exn (Operation.Invalid (hash, _)) -> Some hash | _ -> None) + (fun hash -> Exn (Operation.Invalid (hash, [(* TODO *)]))) + +let () = + let open Data_encoding in + register_error_kind `Permanent + ~id: "invalidBlock" + ~title: "Invalid block" + ~description: + "The economical protocol refused to validate the block." + ~pp:(fun ppf block_hash -> + Format.fprintf ppf "Cannot validate the block %a" + Block_hash.pp_short block_hash) + (obj1 (req "block_hash" Block_hash.encoding)) + (function Exn (Valid_block.Invalid (block_hash, _)) -> Some block_hash + | _ -> None) + (fun block_hash -> Exn (Valid_block.Invalid (block_hash, [(* TODO *)]))) + +(** Whole protocol state : read and store. *) + +let read + ~request_operations ~request_blocks + ~store_root ~context_root ~ttl ?patch_context () = + Store.init store_root >>= fun store -> + lwt_log_info "Initialising the distributed database..." >>= fun () -> + let operation_db = + Db_proxy.Operation.create { request_operations } store.operation in + let block_db = + Db_proxy.Block.create { request_blocks } store.block in + Valid_block.create + ?patch_context ~context_root + store.global_store block_db ttl >>= fun valid_block_state -> + let rec state = { + store ; + active_net = [] ; + nets = Block_hash_table.create 7 ; + operation_db ; + operation_watchers = ref [] ; + block_db ; block_watchers = ref [] ; + valid_block_state ; + } + in + Net.read_state state store >>= fun _nets -> + Lwt.return state + +let store state = + let nets = + Block_hash_table.fold (fun _ net acc -> net :: acc) state.nets [] in + Net.store_state state >>= fun () -> + Lwt_list.iter_s + (fun net -> + Blockchain.use net + (fun bstate -> Blockchain.store_state net bstate)) + nets + +let shutdown state = + Lwt.join [ Db_proxy.Operation.shutdown state.operation_db ; + Db_proxy.Block.shutdown state.block_db ; + ] >>= fun () -> + store state diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli new file mode 100644 index 000000000..77fe642d6 --- /dev/null +++ b/src/node/shell/state.mli @@ -0,0 +1,417 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** An abstraction over all the disk storage used by the node. + + It encapsulates access to: + + - the (distributed) database of raw blocks and operations; + - the index of validation contexts; and + - the persistent state of the node: + - active "networks"; + - the blockchain and its alternate heads of a "network"; + - the pool of pending operations of a "network". + + *) +type t +type state = t + +(** A "network" identifier. Here, a "network" denotes an independant + blockchain, or a "fork" of another blockchain. Such a "network" + is identified by the hash of its genesis block. *) +type net_id = Store.net_id = Net of Block_hash.t + +type error += + | Invalid_fitness of Fitness.fitness * Fitness.fitness + | Unknown_protocol of Protocol_hash.t + | Inactive_network of Store.net_id + | Unknown_network of Store.net_id + | Cannot_parse + +(** Read the internal state of the node and initialize + the blocks/operations/contexts databases. *) +val read: + request_operations: (net_id -> Operation_hash.t list -> unit) -> + request_blocks: (net_id -> Block_hash.t list -> unit) -> + store_root:string -> + context_root:string -> + ttl:int -> + ?patch_context:(Context.t -> Context.t Lwt.t) -> + unit -> + state Lwt.t + +(** Store the internal state of the node on disk. *) +val store: state -> unit Lwt.t + +(** Shutdown the various databases worker and store the + internal state of the node on disk. *) +val shutdown: state -> unit Lwt.t + + +(** {2 Operation database} ****************************************************) + +(** The local and distributed database of operations. *) +module Operation : sig + + type key = Operation_hash.t + + (** Raw operations in the database (partially parsed). *) + type shell_header = Store.shell_operation = { + net_id: net_id ; + (** The genesis of the chain this operation belongs to. *) + } + type t = Store.operation = { + shell: shell_header ; + proto: MBytes.t ; + (** The raw part of the operation, as understood only by the protocol. *) + } + type operation = t + + (** Is an operation stored in the local database ? *) + val known: state -> key -> bool Lwt.t + + (** Read an operation in the local database. This returns [None] + when the operation does not exist in the local database; this returns + [Some (Error _)] when [mark_invalid] was used. This also returns + the time when the operation was stored on the local database. *) + val read: + state -> key -> operation tzresult Time.timed_data option Lwt.t + + (** Read an operation in the local database. This throws [Not_found] + when the operation does not exist in the local database or when + [mark_invalid] was used. *) + val read_exn: + state -> key -> operation Time.timed_data Lwt.t + exception Invalid of key * error list + + (** Read an operation in the local database (without parsing). *) + val raw_read: state -> key -> MBytes.t option Lwt.t + + (** Read an operation from the distributed database. This may block + while the block is fetched from the P2P network. *) + val fetch: + state -> Store.net_id -> key -> operation tzresult Time.timed_data Lwt.t + + (** Request operations on the P2P network without waiting for answers. *) + val prefetch: state -> Store.net_id -> key list -> unit + + (** Add an operation to the local database. This returns [Ok None] + if the operation was already stored in the database, or returns + the parsed operation if not. It may also fails when the shell + part of the operation cannot be parsed or when the operation + does not belong to an active "network". For a given sequence of + bytes, it is guaranted that at most one call to [store] returns + [Some _]. *) + val store: + state -> MBytes.t -> (Operation_hash.t * operation) option tzresult Lwt.t + + (** Mark an operation as invalid in the local database. This returns + [false] if then operation was previously stores in the local + database. The operation is not removed from the local database, + but its content is replaced by the an list of errors. *) + val mark_invalid: state -> key -> error list -> bool Lwt.t + + (** Returns the list known-invalid operations. *) + val invalid: state -> Operation_hash_set.t Lwt.t + + (** Create a stream of all the newly locally-stored operations. + The returned function allows to terminate the stream. *) + val create_watcher: + state -> (key * operation) Lwt_stream.t * (unit -> unit) + +end + +(** {2 Block database} ********************************************************) + +(** The local and distributed database of blocks. *) +module Block : sig + + type shell_header = Store.shell_block_header = { + net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + predecessor: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: MBytes.t list ; + (** The announced score of the block. As a sequence of sequences + of unsigned bytes. Ordered by length and then by contents + lexicographically. *) + operations: Operation_hash.t list ; + (** The raw part of the block header, as understood only by the protocol. *) + } + type t = Store.block_header = { + shell: shell_header ; + proto: MBytes.t ; + } + type block = t + + (** Is a block stored in the local database ? *) + val known: state -> Block_hash.t -> bool Lwt.t + + (** Read a block in the local database. *) + val read: state -> Block_hash.t -> block Time.timed_data option Lwt.t + + (** Read a block in the local database. This throws [Not_found] + when the block does not exist in the local database. *) + val read_exn: state -> Block_hash.t -> block Time.timed_data Lwt.t + + (** Read the predecessor of a block in the local database. *) + val read_pred: state -> Block_hash.t -> Block_hash.t option Lwt.t + + (** Read a block in the local database (without parsing). *) + val raw_read: state -> Block_hash.t -> MBytes.t option Lwt.t + + (** Read a block from the distributed database. This may block + while the block is fetched from the P2P network. *) + val fetch: state -> Store.net_id -> Block_hash.t -> block Time.timed_data Lwt.t + + (** Request blocks on the P2P network without waiting for answers. *) + val prefetch: state -> Store.net_id -> Block_hash.t list -> unit + + (** Add a block to the local database. This returns [Ok None] if the + block was already stored in the database, or returns the + (partially) parsed block if not. It may also fails when the + shell part of the block cannot be parsed or when the block does + not belong to an active "network". For a given sequence of + bytes, it is guaranted that at most one call to [store] returns + [Some _]. *) + val store: + state -> MBytes.t -> (Block_hash.t * block) option tzresult Lwt.t + + (** Create a stream of all the newly locally-stored blocks. + The returned function allows to terminate the stream. *) + val create_watcher: + state -> (Block_hash.t * block) Lwt_stream.t * (unit -> unit) + + (** If [h1] is an ancestor of [h2] in the current [state], + then [path state h1 h2] returns the chain of block from + [h1] (excluded) to [h2] (included). *) + val path: + state -> Block_hash.t -> Block_hash.t -> Block_hash.t list tzresult Lwt.t + + (** [common_ancestor state h1 h2] returns the first common ancestors + in the history of blocks [h1] and [h2]. *) + val common_ancestor: + state -> Block_hash.t -> Block_hash.t -> Block_hash.t tzresult Lwt.t + + (** [block_locator state max_length h] compute the sparse block locator + (/à la/ Bitcoin) for the block [h]. *) + val block_locator: + state -> int -> Block_hash.t -> Block_hash.t list tzresult Lwt.t + +end + +(** {2 Valid block} ***********************************************************) + +(** The local database of known-valid blocks. *) +module Valid_block : sig + + (** A previously validated block. *) + type t = private { + net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + hash: Block_hash.t ; + (** The block hash. *) + pred: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: Protocol.fitness ; + (** The (validated) score of the block. *) + operations: Operation_hash.t list ; + (** The sequence of operations. *) + discovery_time: Time.t ; + (** The data at which the block was discorevered on the P2P network. *) + protocol_hash: Protocol_hash.t ; + (** The protocol to be used for validating the following blocks. *) + protocol: (module Updater.REGISTRED_PROTOCOL) option ; + (** The actual implementation of the protocol to be used for + validating the following blocks. *) + test_protocol_hash: Protocol_hash.t ; + (** The protocol to be used for the next test network. *) + test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; + (** The actual implementatino of the protocol to be used for the + next test network. *) + test_network: (net_id * Time.t) option ; + (** The current test network associated to the block, and the date + of its expiration date. *) + context: Context.t ; + (** The validation context that was produced by the block validation. *) + successors: Block_hash_set.t ; + (** The set of valid successors (including forked networks). *) + invalid_successors: Block_hash_set.t ; + (** The set of invalid successors (including forked networks). *) + } + type valid_block = t + + (** Is the block known as a valid block in the database ? *) + val valid: state -> Block_hash.t -> bool Lwt.t + + (** Is the block known in the database (valid or invalid) ? *) + val known: state -> Block_hash.t -> bool Lwt.t + + (** Read a block in the database. This returns [None] when + the block did not get trough the validation process yet. This + returns [Error] if the block is known invalid or [Ok] otherwise. *) + val read: state -> Block_hash.t -> valid_block tzresult option Lwt.t + + (** Read a block in the database. This throws [Not_found] when + the block did not get trough the validation process yet. This + throws [Invalid] if the block is known invalid. *) + val read_exn: state -> Block_hash.t -> valid_block Lwt.t + exception Invalid of Block_hash.t * error list + + (** Returns all the known (validated) heads of all the known block chain. + (This includes the main blockchain and the non-expired test networks. *) + val known_heads: state -> valid_block Block_hash_map.t Lwt.t + + (** Returns all the known blocks that not did get through the validator yet. *) + val postponed: state -> Block_hash_set.t Lwt.t + + (** Returns all the known blocks whose validation failed. *) + val invalid: state -> Block_hash_set.t Lwt.t + + (** Create a stream of all the newly validated blocks. + The returned function allows to terminate the stream. *) + val create_watcher: state -> (valid_block Lwt_stream.t * (unit -> unit)) Lwt.t + + (** If [h1] is an ancestor of [h2] in the current [state], + then [path state h1 h2] returns the chain of block from + [h1] (excluded) to [h2] (included). Returns [None] otherwise. *) + val path: + state -> valid_block -> valid_block -> valid_block list option Lwt.t + + (** [common_ancestor state h1 h2] returns the first common ancestors + in the history of blocks [h1] and [h2]. *) + val common_ancestor: + state -> valid_block -> valid_block -> valid_block Lwt.t + + (** [block_locator state max_length h] compute the sparse block locator + (/à la/ Bitcoin) for the block [h]. *) + val block_locator: state -> int -> valid_block -> Block_hash.t list Lwt.t + + (**/**) + + (* Store function to be used by the validator. *) + module Store : Persist.TYPED_STORE with type key = Block_hash.t + and type value = Context.t tzresult + val get_store: state -> Store.t Persist.shared_ref + + (* Private interface for testing. *) + val store: state -> Block_hash.t -> Context.t -> valid_block tzresult Lwt.t + val store_invalid: state -> Block_hash.t -> error list -> bool Lwt.t + +end + +(** {2 Network} ****************************************************************) + +(** Data specific to a given network. *) +module Net : sig + + type t + type net = t + + (** Initialize a network for a given [genesis]. It may fails if the + genesis block is a known invalid block. By default the network + never expirate and the test_protocol is the genesis protocol. + When the genesis block correspond to a valid block where + the "test_network" is set to be this genesis block, the test protocol + will be promoted as validation protocol(in this forked network only). *) + val create: + state -> ?expiration:Time.t -> ?test_protocol:Protocol_hash.t -> + Store.genesis -> net tzresult Lwt.t + + (** Look up for a network by the hash of its genesis block. *) + val get: state -> net_id -> net tzresult + + (** Returns all the known networks. *) + val all: state -> net list + + (** Destroy a network: this completly removes from the local storage all + the data associated to the network (this includes blocks and + operations). *) + val destroy: net -> unit Lwt.t + + (** Accessors. Respectively access to; + - the network id (the hash of its genesis block) + - its optional expiration time + - the associated global state. *) + val id: net -> net_id + val expiration: net -> Time.t option + val state: net -> state + + (** Mark a network as active or inactive. Newly discovered blocks and + operations on inactive networks are ignored. *) + val activate: net -> unit + val deactivate: net -> unit + + (** Return the list of active network. *) + val active: state -> net list + + (** Test whether a network is active or not. *) + val is_active: state -> net_id -> bool + + (** {3 Blockchain} ************************************************************) + + module Blockchain : sig + + (** The genesis block of the network's blockchain. On a test network, + the test protocol has been promoted as "main" protocol. *) + val genesis: net -> Valid_block.t Lwt.t + + (** The current head of the network's blockchain. *) + val head: net -> Valid_block.t Lwt.t + + (** The current protocol of the network's blockchain. *) + val protocol: net -> (module Updater.REGISTRED_PROTOCOL) Lwt.t + + (** Record a block as the current head of the network's blockchain. *) + val set_head: net -> Valid_block.t -> unit Lwt.t + + (** Atomically change the current head of the network's blockchain. + This returns [true] whenever the change succeeded, or [false] + when the current head os not equal to the [old] argument. *) + val test_and_set_head: + net -> old:Valid_block.t -> Valid_block.t -> bool Lwt.t + + (** Test whether a block belongs to the current branch of the network's + blockchain. *) + val mem: net -> Block_hash.t -> bool Lwt.t + + (** [find_new net locator max_length], where [locator] is a sparse block + locator (/à la/ Bitcoin), returns the missing block when compared + with the current branch of [net]. *) + val find_new: + net -> Block_hash.t list -> int -> Block_hash.t list tzresult Lwt.t + + end + + (** {3 Mempool} *************************************************************) + + (** The mempool contains the known not-trivially-invalid operations + that are not yet included in the blockchain. *) + module Mempool : sig + + (** Returns the current mempool of the network. *) + val get: net -> Operation_hash_set.t Lwt.t + + (** Add an operation to the mempool. *) + val add: net -> Operation_hash.t -> bool Lwt.t + + (** Remove an operation from the mempool. *) + val remove: net -> Operation_hash.t -> bool Lwt.t + + (** Returns a sur-approximation to the mempool for an alternative + head in the blockchain. *) + val for_block: net -> Valid_block.t -> Operation_hash_set.t Lwt.t + + end + +end diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml new file mode 100644 index 000000000..cc09e47c2 --- /dev/null +++ b/src/node/shell/validator.ml @@ -0,0 +1,444 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Node.Validator + +type worker = { + p2p: P2p.net ; + activate: ?parent:t -> State.Net.t -> t Lwt.t ; + get: State.net_id -> t tzresult Lwt.t ; + get_exn: State.net_id -> t Lwt.t ; + deactivate: t -> unit Lwt.t ; + notify_block: Block_hash.t -> Store.block_header -> unit Lwt.t ; + shutdown: unit -> unit Lwt.t ; +} + +and t = { + net: State.Net.t ; + worker: worker ; + parent: t option ; + mutable child: t option ; + prevalidator: Prevalidator.t ; + notify_block: Block_hash.t -> Store.block_header -> unit Lwt.t ; + fetch_block: Block_hash.t -> State.Valid_block.t tzresult Lwt.t ; + create_child: State.Valid_block.t -> unit tzresult Lwt.t ; + test_validator: unit -> (t * State.Net.t) option ; + shutdown: unit -> unit Lwt.t ; +} + +let activate w net = w.activate net +let deactivate t = t.worker.deactivate t +let get w = w.get +let get_exn w = w.get_exn +let notify_block w = w.notify_block +let shutdown w = w.shutdown () +let test_validator w = w.test_validator () + +let fetch_block v = v.fetch_block +let prevalidator v = v.prevalidator + +let broadcast w m = P2p.broadcast (Messages.to_frame m) w.p2p + +(** Current block computation *) + +let may_change_test_network v (block: State.Valid_block.t) = + let change = + match block.test_network, v.child with + | None, None -> false + | Some _, None + | None, Some _ -> true + | Some (Net net_id, _), Some { net } -> + let Store.Net net_id' = State.Net.id net in + not (Block_hash.equal net_id net_id') in + if change then begin + v.create_child block >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "@[Error while switch test network:@ %a@]" + Error_monad.pp_print_error err + end else + Lwt.return_unit + +let rec may_set_head v (block: State.Valid_block.t) = + State.Net.Blockchain.head v.net >>= fun head -> + if Fitness.compare head.fitness block.fitness >= 0 then + Lwt.return_unit + else + State.Net.Blockchain.test_and_set_head v.net ~old:head block >>= function + | false -> may_set_head v block + | true -> + broadcast v.worker Messages.(Block_inventory (State.Net.id v.net, [])) ; + Prevalidator.flush v.prevalidator ; + may_change_test_network v block >>= fun () -> + lwt_log_notice "update current head %a %a %a(%t)" + Block_hash.pp_short block.hash + Fitness.pp block.fitness + Time.pp_hum block.timestamp + (fun ppf -> + if Block_hash.equal head.hash block.pred then + Format.fprintf ppf "same branch" + else + Format.fprintf ppf "changing branch") >>= fun () -> + Lwt.return_unit + + +(** Block validation *) + +type error += Invalid_operation of Operation_hash.t + +let apply_block net (pred: State.Valid_block.t) hash (block: State.Block.t) = + let state = State.Net.state net in + let State.Net id = State.Net.id net in + lwt_log_notice "validate block %a (after %a), net %a" + Block_hash.pp_short hash + Block_hash.pp_short block.shell.predecessor + Block_hash.pp_short id + >>= fun () -> + lwt_log_info "validation of %a: looking for dependencies..." + Block_hash.pp_short hash >>= fun () -> + map_p + (fun op -> + State.Operation.fetch state (State.Net.id net) op >>= function + | { data = Error _ as e} -> Lwt.return e + | { data = Ok data } -> Lwt.return (Ok data)) + block.shell.operations >>=? fun operations -> + lwt_debug "validation of %a: found operations" + Block_hash.pp_short hash >>= fun () -> + begin (* Are we validating a block in an expired test network ? *) + match State.Net.expiration net with + | Some eol when Time.(eol <= block.shell.timestamp) -> + failwith "This test network expired..." + | None | Some _ -> return () + end >>=? fun () -> + begin + match pred.protocol with + | None -> fail (State.Unknown_protocol pred.protocol_hash) + | Some p -> return (p, pred.context) + end >>=? fun ((module Proto), patched_context) -> + lwt_debug "validation of %a: Proto %a" + Block_hash.pp_short hash + Protocol_hash.pp_short Proto.hash >>= fun () -> + lwt_debug "validation of %a: parsing header..." + Block_hash.pp_short hash >>= fun () -> + Lwt.return (Proto.parse_block_header block) >>=? fun parsed_header -> + lwt_debug "validation of %a: parsing operations..." + Block_hash.pp_short hash >>= fun () -> + map2_s + (fun op_hash raw -> + Lwt.return (Proto.parse_operation op_hash raw) + |> trace (Invalid_operation op_hash)) + block.Store.shell.operations operations >>=? fun parsed_operations -> + lwt_debug "validation of %a: applying block..." + Block_hash.pp_short hash >>= fun () -> + Proto.apply + patched_context parsed_header parsed_operations >>=? fun new_context -> + lwt_log_info "validation of %a: success" + Block_hash.pp_short hash >>= fun () -> + return new_context + +(** *) + +module Validation_scheduler = struct + let name = "validator" + type state = State.Net.t * Block_hash_set.t ref + type rdata = t + type data = Store.block_header Time.timed_data + let init_request (net, _) hash = + State.Block.fetch (State.Net.state net) (State.Net.id net) hash + + let process + net v ~get:get_context ~set:set_context hash block = + match block with + | { Time.data = block } -> + get_context block.Store.shell.predecessor >>= function + | Error _ -> + set_context hash (Error [(* TODO *)]) + | Ok _context -> + lwt_debug "process %a" Block_hash.pp_short hash >>= fun () -> + begin + State.Net.Blockchain.genesis net >>= fun genesis -> + if Block_hash.equal genesis.hash block.shell.predecessor then + Lwt.return genesis + else + State.Valid_block.read_exn + (State.Net.state net) block.shell.predecessor + end >>= fun pred -> + apply_block net pred hash block >>= function + | Error ([State.Unknown_protocol _] as err) -> + lwt_log_error + "@[Ignoring block %a@ %a@]" + Block_hash.pp_short hash + Error_monad.pp_print_error err + | Error exns as error -> + set_context hash error >>= fun () -> + lwt_warn "Failed to validate block %a." + Block_hash.pp_short hash >>= fun () -> + lwt_debug "%a" Error_monad.pp_print_error exns + | Ok new_context -> + (* The sanity check `set_context` detects differences + between the computed fitness and the fitness announced + in the block header. When distinct `Valid_block.read` + will return an error. *) + set_context hash (Ok new_context) >>= fun () -> + State.Valid_block.read + (State.Net.state net) hash >>= function + | None -> + lwt_log_error + "Unexpected error while saving context for block %a." + Block_hash.pp_short hash + | Some (Error err) -> + lwt_log_error + "@[Ignoring block %a@ %a@]" + Block_hash.pp_short hash + Error_monad.pp_print_error err + | Some (Ok block) -> + lwt_debug + "validation of %a: reevaluate current block" + Block_hash.pp_short hash >>= fun () -> + may_set_head v block + + let request (net, running) ~get ~set pendings = + let time = Time.now () in + let min_block b pb = + match pb with + | None -> Some b + | Some pb when b.Store.shell.timestamp < pb.Store.shell.timestamp -> Some b + | Some _ as pb -> pb in + let next = + List.fold_left + (fun acc (hash, block, v) -> + match block with + | { Time.data = block } + when Time.(block.Store.shell.timestamp > time) -> + min_block block acc + | { Time.data = _ } as block -> + if not (Block_hash_set.mem hash !running) then begin + running := Block_hash_set.add hash !running ; + Lwt.async (fun () -> + process net v + ~get:(get v) ~set:set hash block >>= fun () -> + running := Block_hash_set.remove hash !running ; + Lwt.return_unit + ) + end ; + acc) + None + pendings in + match next with + | None -> 0. + | Some b -> Int64.to_float (Time.diff b.Store.shell.timestamp time) + +end + +module Context_db = + Persist.MakeImperativeProxy + (State.Valid_block.Store)(Block_hash_table)(Validation_scheduler) + +let rec create_validator ?parent worker net = + + Prevalidator.create worker.p2p net >>= fun prevalidator -> + let state = State.Net.state net in + let proxy = + Context_db.create + (net, ref Block_hash_set.empty) + (State.Valid_block.get_store state) in + State.Net.activate net ; + + let shutdown () = + lwt_log_notice "shutdown %a" + Store.pp_net_id (State.Net.id net) >>= fun () -> + State.Net.deactivate net ; + Lwt.join [ + Context_db.shutdown proxy ; + Prevalidator.shutdown prevalidator ; + ] + in + + let rec v = { + net ; + worker ; + parent ; + child = None ; + prevalidator ; + shutdown ; + notify_block ; + fetch_block ; + create_child ; + test_validator ; + } + + and notify_block hash block = + lwt_debug "-> Validator.notify_block %a" + Block_hash.pp_short hash >>= fun () -> + State.Net.Blockchain.head net >>= fun head -> + if Fitness.compare head.fitness block.shell.fitness <= 0 then + Context_db.prefetch proxy v hash; + Lwt.return_unit + + and fetch_block hash = + Context_db.fetch proxy v hash >>=? fun _context -> + State.Valid_block.read_exn (State.Net.state net) hash >>= fun block -> + return block + + and create_child block = + begin + match v.child with + | None -> Lwt.return_unit + | Some child -> + v.child <- None ; + deactivate child + end >>= fun () -> + match block.test_network with + | None -> return () + | Some (Net block as net_id, expiration) -> + begin + match State.Net.get state net_id with + | Ok net_store -> return net_store + | Error _ -> + State.Valid_block.read_exn state block >>= fun block -> + let genesis = { + Store.block = block.hash ; + time = block.timestamp ; + protocol = block.test_protocol_hash ; + } in + State.Net.create state ~expiration genesis + end >>=? fun net_store -> + worker.activate ~parent:v net_store >>= fun child -> + v.child <- Some child ; + return () + + and test_validator () = + match v.child with + | None -> None + | Some child -> Some (child, child.net) + + in + + Lwt.return v + +type error += Unknown_network of State.net_id + +let create_worker p2p state = + + let validators : t Lwt.t Block_hash_table.t = Block_hash_table.create 7 in + + let get_exn (State.Net net) = Block_hash_table.find validators net in + let get net = + try get_exn net >>= fun v -> return v + with Not_found -> fail (State.Unknown_network net) in + let remove (State.Net net) = Block_hash_table.remove validators net in + + let deactivate { net } = + let id = State.Net.id net in + get id >>= function + | Error _ -> Lwt.return_unit + | Ok v -> + lwt_log_notice "deactivate network %a" Store.pp_net_id id >>= fun () -> + remove id ; + v.shutdown () + in + + let notify_block hash (block : Store.block_header) = + match get_exn block.shell.net_id with + | exception Not_found -> Lwt.return_unit + | net -> + net >>= fun net -> + net.notify_block hash block in + + let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in + + let maintenance_worker = + let next_net_maintenance = ref (Time.now ()) in + let net_maintenance () = + lwt_log_info "net maintenance" >>= fun () -> + let time = Time.now () in + Block_hash_table.fold + (fun _ v acc -> + v >>= fun v -> + acc >>= fun () -> + match State.Net.expiration v.net with + | Some eol when Time.(eol <= time) -> deactivate v + | Some _ | None -> Lwt.return_unit) + validators Lwt.return_unit >>= fun () -> + Lwt_list.iter_p + (fun net -> + match State.Net.expiration net with + | Some eol when Time.(eol <= time) -> + lwt_log_notice "destroy network %a" + Store.pp_net_id (State.Net.id net) >>= fun () -> + State.Net.destroy net + | Some _ | None -> Lwt.return_unit) + (State.Net.all state) >>= fun () -> + next_net_maintenance := Time.add (Time.now ()) (Int64.of_int 55) ; + Lwt.return_unit in + let next_head_maintenance = ref (Time.now ()) in + let head_maintenance () = + lwt_log_info "head maintenance" >>= fun () -> + (* TODO *) + next_head_maintenance := Time.add (Time.now ()) (Int64.of_int 55) ; + Lwt.return_unit in + let rec worker_loop () = + let timeout = + let next = min !next_head_maintenance !next_net_maintenance in + let delay = Time.(diff next (now ())) in + if delay <= 0L then + Lwt.return_unit + else + Lwt_unix.sleep (Int64.to_float delay) in + Lwt.pick [(timeout >|= fun () -> `Process); + (cancelation () >|= fun () -> `Cancel)] >>= function + | `Cancel -> Lwt.return_unit + | `Process -> + begin + if !next_net_maintenance < Time.now () then + net_maintenance () + else + Lwt.return () + end >>= fun () -> + begin + if !next_head_maintenance < Time.now () then + head_maintenance () + else + Lwt.return () + end >>= fun () -> + worker_loop () + in + Lwt_utils.worker "validator_maintenance" ~run:worker_loop ~cancel in + + let shutdown () = + cancel () >>= fun () -> + let validators = + Block_hash_table.fold + (fun _ (v: t Lwt.t) acc -> (v >>= fun v -> v.shutdown ()) :: acc) + validators [] in + Lwt.join (maintenance_worker :: validators) in + + let rec activate ?parent net = + lwt_log_notice "activate network %a" + Store.pp_net_id (State.Net.id net) >>= fun () -> + State.Net.Blockchain.genesis net >>= fun genesis -> + get (Net genesis.hash) >>= function + | Error _ -> + let v = create_validator ?parent worker net in + Block_hash_table.add validators genesis.hash v ; + v + | Ok v -> Lwt.return v + + and worker = { + p2p ; + get ; get_exn ; + activate ; deactivate ; + notify_block ; + shutdown ; + } + + in + + worker + diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli new file mode 100644 index 000000000..d7826dbe8 --- /dev/null +++ b/src/node/shell/validator.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type worker + +val create_worker: P2p.net -> State.t -> worker +val shutdown: worker -> unit Lwt.t + +val notify_block: worker -> Block_hash.t -> Store.block_header -> unit Lwt.t + +type t + +val activate: worker -> State.Net.t -> t Lwt.t +val get: worker -> State.net_id -> t tzresult Lwt.t +val get_exn: worker -> State.net_id -> t Lwt.t +val deactivate: t -> unit Lwt.t + +val fetch_block: + t -> Block_hash.t -> State.Valid_block.t tzresult Lwt.t +val prevalidator: t -> Prevalidator.t +val test_validator: t -> (t * State.Net.t) option diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml new file mode 100644 index 000000000..351a7bec3 --- /dev/null +++ b/src/node/updater/environment.ml @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Pervasives +module Pervasives = Pervasives +module Compare = Compare +module Array = Array +module List = List +module Bytes = Bytes +module String = String +module Set = Set +module Map = Map +module Int32 = Int32 +module Int64 = Int64 +module Nativeint = Nativeint +module Buffer = Buffer +module Format = Format +module Hex_encode = Hex_encode +module Lwt_sequence = Lwt_sequence +module Lwt = Lwt +module Lwt_list = Lwt_list +module MBytes = MBytes +module Uri = Uri +module Data_encoding = Data_encoding +module Time = Time +module Base48 = Base48 +module Hash = Hash +module Ed25519 = Ed25519 +module Persist = Persist +module Context = Context +module RPC = RPC +module Fitness = Fitness +module Updater = Updater + +(* Internal usage *) + +module Error_monad_sig = Error_monad_sig +module Error_monad = Error_monad +module Logging = Logging + +module type PACKED_PROTOCOL = sig + val hash : Protocol_hash.t + include Updater.PROTOCOL + val error_encoding : error Data_encoding.t + val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] + val pp : Format.formatter -> error -> unit +end diff --git a/src/node/updater/environment_gen.ml b/src/node/updater/environment_gen.ml new file mode 100644 index 000000000..d40b093cd --- /dev/null +++ b/src/node/updater/environment_gen.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let mli = open_out Sys.argv.(1) + +let dump_file oc file = + let ic = open_in file in + let buf = Bytes.create 256 in + let rec loop () = + let len = input ic buf 0 (Bytes.length buf) in + if len <> 0 then (output oc buf 0 len; loop ()) + in + loop (); + close_in ic + +let included = ["Pervasives"] + +let () = + for i = 2 to Array.length Sys.argv - 1 do + let file = Sys.argv.(i) in + let unit = + String.capitalize_ascii + (Filename.chop_extension (Filename.basename file)) in + if List.mem unit included then begin + Printf.fprintf mli "# 1 %S\n" file ; + dump_file mli file + end; + Printf.fprintf mli "module %s : sig\n" unit; + Printf.fprintf mli "# 1 %S\n" file ; + dump_file mli file; + Printf.fprintf mli "end\n"; + if unit = "Result" then begin + Printf.fprintf mli "type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n"; + end; + done + +let () = + Printf.fprintf mli {| +module type PACKED_PROTOCOL = sig + val hash : Hash.Protocol_hash.t + include Updater.PROTOCOL + val error_encoding : error Data_encoding.t + val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] + val pp : Format.formatter -> error -> unit +end +val __cast: (module PACKED_PROTOCOL) -> (module Protocol.PACKED_PROTOCOL) +|} + +let () = + close_out mli diff --git a/src/node/updater/fitness.ml b/src/node/updater/fitness.ml new file mode 100644 index 000000000..31ce7e5e9 --- /dev/null +++ b/src/node/updater/fitness.ml @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type fitness = MBytes.t list + + +(* Fitness comparison: + - shortest lists are smaller ; + - lexicographical order for lists of the same length. *) +let compare_bytes b1 b2 = + let len1 = MBytes.length b1 in + let len2 = MBytes.length b2 in + let c = compare len1 len2 in + if c <> 0 + then c + else + let rec compare_byte b1 b2 pos len = + if pos = len + then 0 + else + let c = compare (MBytes.get_char b1 pos) (MBytes.get_char b2 pos) in + if c <> 0 + then c + else compare_byte b1 b2 (pos+1) len + in + compare_byte b1 b2 0 len1 + +let compare f1 f2 = + let rec compare_rec f1 f2 = match f1, f2 with + | [], [] -> 0 + | i1 :: f1, i2 :: f2 -> + let i = compare_bytes i1 i2 in + if i = 0 then compare_rec f1 f2 else i + | _, _ -> assert false in + let len = compare (List.length f1) (List.length f2) in + if len = 0 then compare_rec f1 f2 else len + +let rec pp fmt = function + | [] -> () + | [f] -> Format.fprintf fmt "%s" (Hex_encode.hex_of_bytes f) + | f1 :: f -> Format.fprintf fmt "%s::%a" (Hex_encode.hex_of_bytes f1) pp f + +let to_string x = Format.asprintf "%a" pp x + +let encoding = + let open Data_encoding in + describe ~title: "Tezos block fitness" + (list bytes) diff --git a/src/node/updater/fitness.mli b/src/node/updater/fitness.mli new file mode 100644 index 000000000..b8b52f5a6 --- /dev/null +++ b/src/node/updater/fitness.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type fitness = MBytes.t list + +val compare: fitness -> fitness -> int +val pp: Format.formatter -> fitness -> unit +val to_string: fitness -> string + +val encoding: fitness Data_encoding. + t + diff --git a/src/node/updater/proto_environment.ml b/src/node/updater/proto_environment.ml new file mode 100644 index 000000000..05e795ef3 --- /dev/null +++ b/src/node/updater/proto_environment.ml @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Environment + +let __cast (type error) (module X : PACKED_PROTOCOL) = + (module X : Protocol.PACKED_PROTOCOL) diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli new file mode 100644 index 000000000..a4bfc8398 --- /dev/null +++ b/src/node/updater/protocol.mli @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Environment - Protocol Implementation Signature *) + +(** The score of a block as a sequence of as unsigned bytes. Ordered + by length and then by contents lexicographically. *) +type fitness = Fitness.fitness + +type net_id = Store.net_id = Net of Block_hash.t + +(** The version agnostic toplevel structure of operations. *) +type shell_operation = Store.shell_operation = { + net_id: net_id ; +} + +type raw_operation = Store.operation = { + shell: shell_operation ; + proto: MBytes.t ; +} + +(** The version agnostic toplevel structure of blocks. *) +type shell_block_header = Store.shell_block_header = + { net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + predecessor: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: MBytes.t list ; + (** The announced score of the block. As a sequence of sequences + of unsigned bytes. Ordered by length and then by contents + lexicographically. *) + operations: Operation_hash.t list ; + (** The sequence of operations. *) + } + +type raw_block_header = Store.block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} + +(** Result of the {!PROTOCOL.preapply} function of the protocol for + discriminating cacheable operations from droppable ones. *) +type 'error preapply_result = + { applied: Operation_hash.t list; + (** Operations that where successfully applied. *) + refused: 'error list Operation_hash_map.t; + (** Operations which triggered a context independent, unavoidable + error (e.g. invalid signature). *) + branch_refused: 'error list Operation_hash_map.t; + (** Operations which triggered an error that might not arise in a + different context (e.g. past account counter, insufficent + balance). *) + branch_delayed: 'error list Operation_hash_map.t; + (** Operations which triggered an error that might not arise in a + future update of this context (e.g. futur account counter). *) } + +(** This is the signature of a Tezos protocol implementation. It has + access to the standard library and the Environment module. *) +module type PROTOCOL = sig + + type error = .. + type 'a tzresult = ('a, error list) result + + (** The version specific type of operations. *) + type operation + + (** The maximum size of operations in bytes *) + val max_operation_data_length : int + + (** The version specific part of blocks. *) + type block_header + + (** The maximum size of block headers in bytes *) + val max_block_header_length : int + + (** The maximum *) + val max_number_of_operations : int + + (** The parsing / preliminary validation function for blocks. Its + role is to check that the raw header is well formed, and to + produce a pre-decomposed value of the high level, protocol defined + {!block_header} type. It does not have access to the storage + context. It may store the hash and raw bytes for later signature + verification by {!apply} or {!preapply}. *) + val parse_block_header : raw_block_header -> block_header tzresult + + (** The parsing / preliminary validation function for + operations. Similar to {!parse_block_header}. *) + val parse_operation : + Operation_hash.t -> raw_operation -> operation tzresult + + (** The main protocol function that validates blocks. It receives the + block header and the list of associated operations, as + pre-decomposed by {!parse_block_header} and {!parse_operation}. *) + val apply : + Context.t -> block_header -> operation list -> + Context.t tzresult Lwt.t + + (** The auxiliary protocol entry point that validates pending + operations out of blocks. This function tries to apply the all + operations in the given order, and returns which applications have + suceeded and which ones have failed. The first three parameters + are a context in which to apply the operations, the hash of the + preceding block and the date at which the operations are + executed. This function is used by the shell for accepting or + dropping operations, as well as the mining client to check that a + sequence of operations forms a valid block. *) + val preapply : + Context.t -> Block_hash.t -> Time.t -> bool -> operation list -> + (Context.t * error preapply_result) tzresult Lwt.t + + (** The context rating function to determine the winning block chain. *) + val fitness : + Context.t -> fitness Lwt.t + + (** The list of remote procedures exported by this implementation *) + val rpc_services : Context.t RPC.directory + + val configure_sandbox : + Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t + +end + +module type PACKED_PROTOCOL = sig + val hash : Protocol_hash.t + include PROTOCOL + val error_encoding : error Data_encoding.t + val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] + val pp : Format.formatter -> error -> unit +end diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml new file mode 100644 index 000000000..af075fd0e --- /dev/null +++ b/src/node/updater/register.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Proto : Protocol.PACKED_PROTOCOL) = struct + type proto_error = Proto.error + type Error_monad.error += Ecoproto_error of Proto.error list + let wrap_error = function + | Ok _ as ok -> ok + | Error errors -> Error [Ecoproto_error errors] + let () = + let id = Format.asprintf "Ecoproto.%a" Protocol_hash.pp Proto.hash in + Error_monad.register_wrapped_error_kind + (fun ecoerrors -> Proto.classify_errors ecoerrors) + ~id ~title:"Error returned by the protocol" + ~description:"Wrapped error for the economical protocol." + ~pp:(fun ppf -> + Format.fprintf ppf + "@[Economical error:@ %a@]" + (Format.pp_print_list Proto.pp)) + Data_encoding.(obj1 (req "ecoproto" (list Proto.error_encoding))) + (function Ecoproto_error ecoerrors -> Some ecoerrors + | _ -> None ) + (function ecoerrors -> Ecoproto_error ecoerrors) +end + +let register proto = + let module Proto = (val Proto_environment.__cast proto) in + let module V = struct + include Proto + include Make(Proto) + let parse_block_header d = parse_block_header d |> wrap_error + let parse_operation h b = parse_operation h b |> wrap_error + let apply c h ops = apply c h ops >|= wrap_error + let preapply c h t b ops = + (preapply c h t b ops >|= wrap_error) >>=? fun (ctxt, r) -> + return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r) + let configure_sandbox c j = + configure_sandbox c j >|= wrap_error + end in + Updater.register Proto.hash (module V) diff --git a/src/node/updater/register.mli b/src/node/updater/register.mli new file mode 100644 index 000000000..4da480158 --- /dev/null +++ b/src/node/updater/register.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Proto : Protocol.PACKED_PROTOCOL) : sig + type Error_monad.error += Ecoproto_error of Proto.error list + val wrap_error: 'a Proto.tzresult -> 'a tzresult +end + +val register: (module Proto_environment.PACKED_PROTOCOL) -> unit diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml new file mode 100644 index 000000000..3f6ed4c2e --- /dev/null +++ b/src/node/updater/updater.ml @@ -0,0 +1,215 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Updater + +let (//) = Filename.concat + +module type PROTOCOL = Protocol.PROTOCOL +module type REGISTRED_PROTOCOL = sig + val hash: Protocol_hash.t + include Protocol.PROTOCOL with type error := error + and type 'a tzresult := 'a tzresult +end + +type net_id = Store.net_id = Net of Block_hash.t + +let net_id_encoding = Store.net_id_encoding + +type shell_operation = Store.shell_operation = { + net_id: net_id ; +} +let shell_operation_encoding = Store.shell_operation_encoding + +type raw_operation = Store.operation = { + shell: shell_operation ; + proto: MBytes.t ; +} +let raw_operation_encoding = Store.operation_encoding + +(** The version agnostic toplevel structure of blocks. *) +type shell_block_header = Store.shell_block_header = { + net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + predecessor: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: MBytes.t list ; + (** The announced score of the block. As a sequence of sequences + of unsigned bytes. Ordered by length and then by contents + lexicographically. *) + operations: Operation_hash.t list ; + (** The sequence of operations. *) +} +let shell_block_header_encoding = Store.shell_block_header_encoding + +type raw_block_header = Store.block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} +let raw_block_header_encoding = Store.block_header_encoding + +type 'error preapply_result = 'error Protocol.preapply_result = { + applied: Operation_hash.t list; + refused: 'error list Operation_hash_map.t; + branch_refused: 'error list Operation_hash_map.t; + branch_delayed: 'error list Operation_hash_map.t; +} + +let empty_result = { + applied = [] ; + refused = Operation_hash_map.empty ; + branch_refused = Operation_hash_map.empty ; + branch_delayed = Operation_hash_map.empty ; +} + +let map_result f r = { + applied = r.applied; + refused = Operation_hash_map.map f r.refused ; + branch_refused = Operation_hash_map.map f r.branch_refused ; + branch_delayed = Operation_hash_map.map f r.branch_delayed ; +} + +let preapply_result_encoding error_encoding = + let open Data_encoding in + let refused_encoding = tup2 Operation_hash.encoding error_encoding in + let build_list map = Operation_hash_map.bindings map in + let build_map list = + List.fold_right + (fun (k, e) m -> Operation_hash_map.add k e m) + list Operation_hash_map.empty in + conv + (fun { applied ; refused ; branch_refused ; branch_delayed } -> + (applied, build_list refused, + build_list branch_refused, build_list branch_delayed)) + (fun (applied, refused, branch_refused, branch_delayed) -> + let refused = build_map refused in + let branch_refused = build_map branch_refused in + let branch_delayed = build_map branch_delayed in + { applied ; refused ; branch_refused ; branch_delayed }) + (obj4 + (req "applied" (list Operation_hash.encoding)) + (req "refused" (list refused_encoding)) + (req "branch_refused" (list refused_encoding)) + (req "branch_delayed" (list refused_encoding))) + + +(** Version table *) + +module VersionTable = Protocol_hash_table + +let versions : ((module REGISTRED_PROTOCOL)) VersionTable.t = + VersionTable.create 20 + +let register hash proto = + VersionTable.add versions hash proto + +let activate = Context.set_protocol +let fork_test_network = Context.fork_test_network +let set_test_protocol = Context.set_test_protocol + +let get_exn hash = VersionTable.find versions hash +let get hash = + try Some (get_exn hash) + with Not_found -> None + +(** Compiler *) + +let basedir = ref None +let get_basedir () = + match !basedir with + | None -> fatal_error "not initialized" + | Some m -> m + +let init dir = + basedir := Some dir + +type component = { + name : string ; + interface : string option ; + implementation : string ; +} + +let create_files dir units = + Utils.remove_dir dir >>= fun () -> + Utils.create_dir dir >>= fun () -> + Lwt_list.map_s + (fun unit -> + let ml = dir // (unit.name ^ ".ml") in + let mli = dir // (unit.name ^ ".mli") in + Utils.create_file ml unit.implementation >>= fun () -> + match unit.interface with + | None -> Lwt.return [ml] + | Some content -> + Utils.create_file mli content >>= fun () -> + Lwt.return [mli;ml]) + units >>= fun files -> + let files = List.concat files in + Lwt.return files + +let do_compile hash units = + let basedir = get_basedir () in + let source_dir = basedir // Protocol_hash.to_short_b48check hash // "src" in + let log_file = basedir // Protocol_hash.to_short_b48check hash // "LOG" in + let plugin_file = + basedir // Protocol_hash.to_b48check hash + // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in + create_files source_dir units >>= fun _files -> + Tezos_compiler.Meta.to_file + (source_dir // "TEZOS") + hash + (List.map (fun {name} -> String.capitalize_ascii name) units); + let compiler_command = + (Sys.executable_name, + Array.of_list [Node_compiler_main.compiler_name; plugin_file; source_dir]) in + let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in + let pi = + Lwt_process.exec + ~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd) + compiler_command in + pi >>= function + | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + log_error "INTERRUPTED COMPILATION (%s)" log_file; + Lwt.return false + | Unix.WEXITED x when x <> 0 -> + log_error "COMPILATION ERROR (%s)" log_file; + Lwt.return false + | Unix.WEXITED _ -> + try Dynlink.loadfile_private plugin_file; Lwt.return true + with Dynlink.Error err -> + log_error "Can't load plugin: %s (%s)" + (Dynlink.error_message err) plugin_file; + Lwt.return false + +let compile hash units = + if VersionTable.mem versions hash then + Lwt.return true + else begin + do_compile hash units >>= fun success -> + let loaded = VersionTable.mem versions hash in + if success && not loaded then + log_error "Internal error while compiling %a" Protocol_hash.pp hash; + Lwt.return loaded + end + +let operations t = + let ops = + List.fold_left + (fun acc x -> Operation_hash_set.add x acc) + Operation_hash_set.empty t.applied in + let ops = + Operation_hash_map.fold + (fun x _ acc -> Operation_hash_set.add x acc) + t.branch_delayed ops in + let ops = + Operation_hash_map.fold + (fun x _ acc -> Operation_hash_set.add x acc) + t.branch_refused ops in + ops diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli new file mode 100644 index 000000000..0935018fe --- /dev/null +++ b/src/node/updater/updater.mli @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type net_id = Store.net_id = Net of Block_hash.t + +val net_id_encoding: net_id Data_encoding.t + +type shell_operation = Store.shell_operation = { + net_id: net_id ; +} +val shell_operation_encoding: shell_operation Data_encoding.t + +type raw_operation = Store.operation = { + shell: shell_operation ; + proto: MBytes.t ; +} +val raw_operation_encoding: raw_operation Data_encoding.t + +(** The version agnostic toplevel structure of blocks. *) +type shell_block_header = Store.shell_block_header = { + net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + predecessor: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: MBytes.t list ; + (** The announced score of the block. As a sequence of sequences + of unsigned bytes. Ordered by length and then by contents + lexicographically. *) + operations: Operation_hash.t list ; + (** The sequence of operations. *) +} +val shell_block_header_encoding: shell_block_header Data_encoding.t + +type raw_block_header = Store.block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} +val raw_block_header_encoding: raw_block_header Data_encoding.t + +type 'error preapply_result = 'error Protocol.preapply_result = { + applied: Operation_hash.t list; + refused: 'error list Operation_hash_map.t; (* e.g. invalid signature. *) + branch_refused: 'error list Operation_hash_map.t; (* e.g. past account counter; + insufficent balance *) + branch_delayed: 'error list Operation_hash_map.t; (* e.g. futur account counter. *) +} + +val empty_result: 'error preapply_result +val map_result: ('a list -> 'b list) -> 'a preapply_result -> 'b preapply_result + +val operations: 'error preapply_result -> Operation_hash_set.t + +val preapply_result_encoding : + 'error list Data_encoding.t -> + 'error preapply_result Data_encoding.t + +module type PROTOCOL = Protocol.PROTOCOL +module type REGISTRED_PROTOCOL = sig + val hash: Protocol_hash.t + (* exception Ecoproto_error of error list *) + include Protocol.PROTOCOL with type error := error + and type 'a tzresult := 'a tzresult +end + +type component = { + name : string ; + interface : string option ; + implementation : string ; +} + +val compile: Protocol_hash.t -> component list -> bool Lwt.t + +val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t +val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t +val fork_test_network: Context.t -> Context.t Lwt.t + +val register: Protocol_hash.t -> (module REGISTRED_PROTOCOL) -> unit + +val get: Protocol_hash.t -> (module REGISTRED_PROTOCOL) option +val get_exn: Protocol_hash.t -> (module REGISTRED_PROTOCOL) + +val init: string -> unit diff --git a/src/node_main.ml b/src/node_main.ml new file mode 100644 index 000000000..c9f243d63 --- /dev/null +++ b/src/node_main.ml @@ -0,0 +1,336 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open Logging.Node.Main + +let genesis_block = + Block_hash.of_b48check + "qBeeesNtMrdyRDj6hSK2PxEN9R67brGSm64EFRjJSBTTqLcQCRHNR" + +let genesis_protocol = + Protocol_hash.of_b48check + "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" + +let test_protocol = + Some (Protocol_hash.of_b48check + "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee") + +let genesis_time = + Time.of_notation_exn "2016-08-01T00:00:00Z" + +let genesis = { + Store.time = genesis_time ; + block = genesis_block ; + protocol = genesis_protocol ; +} + +module Globals = struct + + open Config_file + + let (//) = Filename.concat + + let home = + try Sys.getenv "HOME" + with Not_found -> "/root" + + class string_option_cp ?group name ?short_name default help = + object (self) + inherit [string] option_cp + string_wrappers ?group name ?short_name default help + method get_spec = + let set = function + | "" + | "none" -> self#set None | s -> self#set (Some s) in + Arg.String set + end + + let addr_wrappers = { + to_raw = (fun v -> Raw.String (Ipaddr.to_string v)); + of_raw = function + | Raw.String v -> Ipaddr.of_string_exn v + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Int expected, got %a\n%!" Raw.to_channel r))} + class addr_cp = [Ipaddr.t] cp_custom_type addr_wrappers + + (** Command line options *) + + let cli_group = new group + + let base_dir = + new filename_cp ~group:cli_group ["base-dir"] (home // ".tezos-node") + "The directory where the tezos node will store all its data." + + let config_file = + new filename_cp ~group:cli_group ["config-file"] (base_dir#get // "config") + "The main configuration file." + + let () = + let config_file_forced = ref false in + let update_config _old_file _new_file = config_file_forced := true in + let update_base_dir old_dir new_dir = + if new_dir <> old_dir then + if not !config_file_forced then begin + config_file#set (new_dir // "config"); + config_file_forced := false + end + in + config_file#add_hook update_config; + base_dir#add_hook update_base_dir + + let sandbox = + new string_option_cp ~group:cli_group ["sandbox"] None + "Run a sandboxed daemon \ + \ (P2P is disabled, \ + \ data are stored in custom directory)." + + let sandbox_param = + new string_option_cp ~group:cli_group ["sandbox-param"] None + "Custom paramater for the ecoproto." + + let () = + let sandboxed _ = function + | None -> base_dir#reset + | Some dir -> base_dir#set dir in + sandbox#add_hook sandboxed + + (** File options *) + + let file_group = new group + + let store_root = + new filename_cp ~group:file_group ["db"; "store"] + "DUMMY" (* See update default *) "TODO" + + let context_root = + new filename_cp ~group:file_group ["db"; "context"] + "DUMMY" (* See update default *) "TODO" + + let protocol_dir = + new filename_cp ~group:file_group ["protocol"; "dir"] + "DUMMY" (* See update default *) "TODO" + + let peers_file = + new filename_cp ~group:file_group ["net"; "peers"] + "DUMMY" (* See update default *) + "A file storing information about known peers" + + (** Network options *) + + let in_both_groups cp = + file_group # add cp ; cli_group # add cp ; cp + + let min_connections = in_both_groups @@ + new int_cp [ "net" ; "min-connections" ] 4 + "The number of connections under which aggressive peer discovery mode must be entered" + + let max_connections = in_both_groups @@ + new int_cp [ "net" ; "max-connections" ] 400 + "The number of connections over which some have to be closed" + + let expected_connections = in_both_groups @@ + new int_cp [ "net" ; "expected-connections" ] 20 + "The minimum number of connections to be ensured by the cruise control" + + let incoming_port = in_both_groups @@ + new option_cp int_wrappers [ "net" ; "port" ] ~short_name:"P" (Some 9732) + "The TCP address at which this instance can be reached" + + let discovery_port = in_both_groups @@ + new bool_cp [ "net" ; "local-discovery" ] ~short_name:"D" false + "Automatic discovery of peers on the local network" + + let bootstrap_peers = in_both_groups @@ + new list_cp (tuple2_wrappers addr_wrappers int_wrappers) + [ "net" ; "bootstrap-peers" ] ~short_name:"B" [ ] + "The peers to bootstrap the networks from" + + let closed_network = in_both_groups @@ + new bool_cp + [ "net" ; "closed" ] ~short_name:"X" false + "Only accept connections from the bootstrap peers" + + + (** Logging *) + + let log_kind = + new string_cp ~group:file_group [ "log" ; "kind" ] "stderr" + "Which logger to use: 'stderr', 'stdout', 'file', 'null' or 'syslog'." + + let log_file = + new filename_cp ~group:file_group ["log"; "file"] + "DUMMY" (* See update default *) + "The log-file path when 'log_kind = file'." + + (** RPC *) + + let rpc_listening_port = in_both_groups @@ + new option_cp int_wrappers [ "rpc" ; "port" ] ~short_name:"P" None + "The TCP port at which this RPC-server instance can be reached" + + let rpc_listening_addr = in_both_groups @@ + new string_option_cp [ "rpc" ; "addr" ] ~short_name:"A" None + "The TCP address at which this RPC-server instance can be reached" + + (** Entry point *) + + let update_defaults () = + (* Set default path relatively to [base_dir]. *) + store_root#set (base_dir#get // "store"); + context_root#set (base_dir#get // "context"); + protocol_dir#set (base_dir#get // "protocol"); + peers_file#set (base_dir#get // "peers-cache"); + log_file#set (base_dir#get // "tezos-node.log") + + let parse_args () = + let args = cli_group#command_line_args "-" in + let anon_fun str = + Arg.usage args + (Printf.sprintf + "\nError: Unknown command line argument %S.\n\nUsage:" str); + Utils.exit 1 + in + Arg.parse args anon_fun "Usage:"; + update_defaults (); + if Sys.file_exists config_file#get then begin + try + file_group#read config_file#get ; + (* parse once again to overwrite file options by cli ones *) + Arg.parse_argv ~current:(ref 0) Sys.argv args anon_fun "Usage:" + with Sys_error msg -> + Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg; + Utils.exit 1 + end else begin + try + Lwt_main.run (Utils.create_dir (Filename.dirname config_file#get)); + file_group#write config_file#get + with Sys_error msg -> + Printf.eprintf + "Warning: can't create the default configuration file: %s\n%!" msg + end + +end + +let init_logger () = + let open Logging in + match Globals.log_kind#get with + | "" | "stderr" -> Logging.init Stderr + | "stdout" -> Logging.init Stdout + | "file" -> Logging.init (File Globals.log_file#get) + | "null" -> Logging.init Null + | "syslog" -> Logging.init Syslog + | kind -> Printf.eprintf "Warning: unknown log_kind \"%s\".\n%!" kind + +let init_node () = + let patch_context json ctxt = + let module Proto = (val Updater.get_exn genesis_protocol) in + Lwt.catch + (fun () -> + Proto.configure_sandbox ctxt json >|= function + | Error _ -> + warn "Error while configuring ecoproto for the sandboxed mode." ; + ctxt + | Ok ctxt -> ctxt) + (fun exn -> + warn "Error while configuring ecoproto for the sandboxed mode. (%s)" + (Printexc.to_string exn) ; + Lwt.return ctxt) in + begin + match Globals.sandbox#get with + | None -> Lwt.return_none + | Some _ -> + match Globals.sandbox_param#get with + | None -> Lwt.return (Some (patch_context None)) + | Some file -> + Data_encoding.Json.read_file file >>= function + | None -> + lwt_warn + "Can't parse sandbox parameters (%s)" file >>= fun () -> + Lwt.return (Some (patch_context None)) + | Some _ as json -> + Lwt.return (Some (patch_context json)) + end >>= fun patch_context -> + let net_params = + let open P2p in + match Globals.sandbox#get with + | Some _ -> None + | None -> + let limits = + { max_packet_size = 10_000 ; + peer_answer_timeout = 5. ; + expected_connections = Globals.expected_connections#get ; + min_connections = Globals.min_connections#get ; + max_connections = Globals.max_connections#get ; + blacklist_time = 30. } + and config = + { incoming_port = Globals.incoming_port#get ; + discovery_port = + if Globals.discovery_port#get then Some 7732 else None ; + supported_versions = Node.supported_versions ; + known_peers = Globals.bootstrap_peers#get ; + peers_file = Globals.peers_file#get ; + closed_network = Globals.closed_network#get } + in + Some (config, limits) in + Node.create + ~genesis + ~store_root:Globals.store_root#get + ~context_root:Globals.context_root#get + ?test_protocol + ?patch_context + net_params + +let init_rpc node = + match Globals.rpc_listening_port#get, Globals.rpc_listening_addr#get with + | None, None -> + lwt_log_notice "Not listening to RPC calls." >>= fun () -> + Lwt.return None + | port, addr -> + let addr = match addr with Some a -> a | None -> "127.0.0.1" in + let port = match port with Some p -> p | None -> 8732 in + lwt_log_notice "Starting the RPC server at %s:%d." addr port >>= fun () -> + let dir = Node_rpc.build_rpc_directory node in + RPC.(launch addr port dir) >>= fun server -> + Lwt.return (Some server) + +let may f = function + | None -> Lwt.return_unit + | Some x -> f x + +let init_signal () = + let handler id = try Utils.exit id with _ -> () in + ignore (Lwt_unix.on_signal 2 handler : Lwt_unix.signal_handler_id) + +let main () = + Random.self_init () ; + Sodium.Random.stir () ; + Globals.parse_args (); + init_logger (); + Updater.init Globals.protocol_dir#get; + lwt_log_notice "Starting the Tezos node..." >>= fun () -> + init_node () >>=? fun node -> + init_rpc node >>= fun rpc -> + init_signal (); + lwt_log_notice "The Tezos node is now running!" >>= fun () -> + Utils.termination_thread >>= fun x -> + lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> + Node.shutdown node >>= fun () -> + lwt_log_notice "Shutting down the RPC server..." >>= fun () -> + may RPC.shutdown rpc >>= fun () -> + lwt_log_notice "BYE (%d)" x >>= fun () -> + return () + +let () = + Lwt_main.run begin + main () >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "%a@." Error_monad.pp_print_error err + end diff --git a/src/proto/bootstrap/.merlin b/src/proto/bootstrap/.merlin new file mode 100644 index 000000000..46edbf5ec --- /dev/null +++ b/src/proto/bootstrap/.merlin @@ -0,0 +1,9 @@ +B ../../node/updater/ +B _tzbuild +FLG -nopervasives +FLG -open Proto_environment +FLG -open Hash +FLG -open Local_error_monad +FLG -open Error_monad +FLG -open Logging +FLG -w -40 diff --git a/src/proto/bootstrap/TEZOS_PROTOCOL b/src/proto/bootstrap/TEZOS_PROTOCOL new file mode 100644 index 000000000..00f61d8d1 --- /dev/null +++ b/src/proto/bootstrap/TEZOS_PROTOCOL @@ -0,0 +1,57 @@ +hash = "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" +modules = [ + + Misc ; + Tezos_hash ; + + Qty_repr ; + Tez_repr ; + Period_repr ; + Time_repr ; + Constants_repr ; + Fitness_repr ; + Raw_level_repr ; + Voting_period_repr ; + Cycle_repr ; + Level_repr ; + Seed_repr ; + Script_int_repr ; + Script_repr ; + Contract_repr ; + Roll_repr ; + Asset_repr ; + Vote_repr ; + Operation_repr ; + Block_repr ; + + Storage_sigs ; + Storage_functors ; + Storage ; + + Level_storage ; + Nonce_storage ; + Seed_storage ; + Roll_storage ; + Contract_storage ; + Reward_storage ; + Bootstrap_storage ; + Fitness_storage ; + Vote_storage ; + Init_storage ; + + Tezos_context ; + + Script_typed_ir ; + Script_ir_translator ; + Script_interpreter ; + + Mining ; + Amendment ; + Apply ; + + Services ; + Services_registration ; + + Main ; + +] diff --git a/src/proto/bootstrap/amendment.ml b/src/proto/bootstrap/amendment.ml new file mode 100644 index 000000000..4771bfea4 --- /dev/null +++ b/src/proto/bootstrap/amendment.ml @@ -0,0 +1,146 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context + +let select_winning_proposal proposals = + let merge proposal vote winners = + match winners with + | None -> Some ([proposal], vote) + | Some (winners, winners_vote) as previous -> + if Compare.Int32.(vote = winners_vote) then + Some (proposal :: winners, winners_vote) + else if Compare.Int32.(vote >= winners_vote) then + Some ([proposal], vote) + else + previous in + match Protocol_hash_map.fold merge proposals None with + | None -> None + | Some ([proposal], _) -> Some proposal + | Some _ -> None (* in case of a tie, lets do nothing. *) + +let check_approval_and_update_quorum ctxt = + Vote.get_ballots ctxt >>=? fun ballots -> + Vote.listing_size ctxt >>=? fun maximum_vote -> + Vote.get_current_quorum ctxt >>=? fun expected_quorum -> + (* FIXME check overflow ??? *) + let casted_vote = Int32.add ballots.yay ballots.nay in + let actual_vote = Int32.add casted_vote ballots.pass in + let actual_quorum = + Int32.div (Int32.mul actual_vote 100_00l) maximum_vote in + let supermajority = Int32.div (Int32.mul 8l casted_vote) 10l in + let updated_quorum = + Int32.div + (Int32.add (Int32.mul 8l expected_quorum) + (Int32.mul 2l actual_quorum)) + 10l in + Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> + return + (ctxt, + Compare.Int32.(actual_quorum >= expected_quorum + && ballots.yay >= supermajority)) + +let start_new_voting_cycle ctxt = + Vote.get_current_period_kind ctxt >>=? function + | Proposal -> begin + Vote.get_proposals ctxt >>=? fun proposals -> + Vote.clear_proposals ctxt >>=? fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + match select_winning_proposal proposals with + | None -> + Vote.froze_listings ctxt >>=? fun ctxt -> + Vote.clear_current_proposal ctxt >>=? fun ctxt -> + return ctxt + | Some proposal -> + Vote.set_current_proposal ctxt proposal >>=? fun ctxt -> + Vote.froze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Testing_vote >>=? fun ctxt -> + return ctxt + end + | Testing_vote -> + check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + Vote.clear_ballots ctxt >>= fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + if approved then + Vote.get_current_proposal ctxt >>=? fun proposal -> + set_test_protocol ctxt proposal >>= fun ctxt -> + fork_test_network ctxt >>= fun ctxt -> + Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> + return ctxt + else + Vote.clear_current_proposal ctxt >>=? fun ctxt -> + Vote.froze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> + return ctxt + | Testing -> + Vote.froze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt -> + return ctxt + | Promotion_vote -> + check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + begin + if approved then + Vote.get_current_proposal ctxt >>=? fun proposal -> + activate ctxt proposal >>= fun ctxt -> + return ctxt + else + return ctxt + end >>=? fun ctxt -> + Vote.clear_ballots ctxt >>= fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + Vote.clear_current_proposal ctxt >>=? fun ctxt -> + Vote.froze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> + return ctxt + +type error += + | Invalid_proposal + | Unexpected_proposal + | Unauthorized_proposal + | Unexpected_ballot + | Unauthorized_ballot + +let record_proposals ctxt delegate proposals = + Vote.get_current_period_kind ctxt >>=? function + | Proposal -> + Vote.in_listings ctxt delegate >>= fun in_listings -> + if in_listings then + fold_left_s + (fun ctxt proposal -> + Vote.record_proposal ctxt proposal delegate) + ctxt proposals + else + fail Unauthorized_proposal + | Testing_vote | Testing | Promotion_vote -> + fail Unexpected_proposal + +let record_ballot ctxt delegate proposal ballot = + Vote.get_current_proposal ctxt >>=? fun current_proposal -> + fail_unless (Protocol_hash.equal proposal current_proposal) + Invalid_proposal >>=? fun () -> + Vote.get_current_period_kind ctxt >>=? function + | Testing_vote | Promotion_vote -> + Vote.in_listings ctxt delegate >>= fun in_listings -> + if in_listings then + Vote.record_ballot ctxt delegate ballot + else + fail Unauthorized_ballot + | Testing | Proposal -> + fail Unexpected_ballot + +let first_of_a_voting_period l = + Compare.Int32.(l.Level.voting_period_position = 0l) + +let may_start_new_voting_cycle ctxt = + Level.current ctxt >>=? fun level -> + if first_of_a_voting_period level then + start_new_voting_cycle ctxt + else + return ctxt + diff --git a/src/proto/bootstrap/amendment.mli b/src/proto/bootstrap/amendment.mli new file mode 100644 index 000000000..645de93c7 --- /dev/null +++ b/src/proto/bootstrap/amendment.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context + +val may_start_new_voting_cycle: + context -> context tzresult Lwt.t + +type error += + | Unexpected_proposal + | Unauthorized_proposal + +val record_proposals: + context -> + public_key_hash -> Protocol_hash.t list -> + context tzresult Lwt.t + +type error += + | Invalid_proposal + | Unexpected_ballot + | Unauthorized_ballot + +val record_ballot: + context -> + public_key_hash -> Protocol_hash.t -> Vote.ballot -> + context tzresult Lwt.t diff --git a/src/proto/bootstrap/apply.ml b/src/proto/bootstrap/apply.ml new file mode 100644 index 000000000..150e020f4 --- /dev/null +++ b/src/proto/bootstrap/apply.ml @@ -0,0 +1,331 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Main Entry Points *) + +open Tezos_context + +type error += Bad_endorsement (* TODO: doc *) +type error += Insert_coin (* TODO: doc *) +type error += Contract_not_delegatable (* TODO: doc *) +type error += Unimplemented +type error += Invalid_voting_period + +let apply_delegate_operation_content + ctxt delegate pred_block block_priority = function + | Endorsement { block ; slot } -> + fail_unless + (Block_hash.equal block pred_block) Bad_endorsement >>=? fun () -> + Mining.check_signing_rights ctxt slot delegate >>=? fun () -> + Fitness.increase ctxt >>=? fun ctxt -> + Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) -> + Mining.endorsement_reward ~block_priority >>=? fun reward -> + Level.current ctxt >>=? fun { cycle = current_cycle } -> + Lwt.return Tez.(reward +? bond) >>=? fun full_reward -> + Reward.record ctxt delegate current_cycle full_reward + | Proposals { period ; proposals } -> + Level.current ctxt >>=? fun level -> + fail_unless Voting_period.(level.voting_period = period) + Invalid_voting_period >>=? fun () -> + Amendment.record_proposals ctxt delegate proposals + | Ballot { period ; proposal ; ballot } -> + Level.current ctxt >>=? fun level -> + fail_unless Voting_period.(level.voting_period = period) + Invalid_voting_period >>=? fun () -> + Amendment.record_ballot ctxt delegate proposal ballot + +let rec is_reject = function + | [] -> false + | Script_interpreter.Reject _ :: _ -> true + | _ :: err -> is_reject err + +type error += Non_scripted_contract_with_parameter +type error += Scripted_contract_without_paramater + +let apply_manager_operation_content ctxt accept_failing_script source = function + | Transaction { amount ; parameters ; destination } -> begin + Contract.spend ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? function + | No_script -> begin + match parameters with + | None | Some (Prim (_, "void", [])) -> return ctxt + | Some _ -> fail Non_scripted_contract_with_parameter + end + | Script { code ; storage } -> + match parameters with + | None -> fail Scripted_contract_without_paramater + | Some parameters -> + Script_interpreter.execute + source destination ctxt storage code amount parameters + (Constants.instructions_per_transaction ctxt) + >>= function + | Ok (storage_res, _res, _steps, ctxt) -> + (* TODO: pay for the steps and the storage diff: + update_script_storage checks the storage cost *) + Contract.update_script_storage + ctxt destination storage_res >>=? fun ctxt -> + return ctxt + | Error err -> + if accept_failing_script && is_reject err then + return ctxt + else + Lwt.return (Error err) + end + | Origination { manager ; delegate ; script ; + spendable ; delegatable ; credit } -> begin + match script with + | No_script -> return () + | Script { code ; storage } -> + Script_ir_translator.parse_script ctxt storage code >>=? fun _ -> + let storage_fee = Script.storage_cost storage in + let code_fee = Script.code_cost code in + Lwt.return Tez.(code_fee +? storage_fee) >>=? fun script_fee -> + Lwt.return Tez.(script_fee +? Constants.origination_burn) >>=? fun total_fee -> + fail_unless Tez.(credit > total_fee) Insert_coin >>=? fun () -> + return () + end >>=? fun () -> + Contract.spend ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + ~manager ~delegate ~balance + ~script ~spendable ~delegatable >>=? fun (ctxt, _) -> + return ctxt + | Issuance { asset = (asset, key); amount } -> + Contract.issue ctxt source asset key amount + (* TODO: pay for the storage diff *) + | Delegation delegate -> + Contract.is_delegatable ctxt source >>=? fun delegatable -> + fail_unless delegatable Contract_not_delegatable >>=? fun () -> + Contract.set_delegate ctxt source delegate + +let check_signature_and_update_public_key ctxt id public_key op = + begin + match public_key with + | None -> return ctxt + | Some public_key -> + Public_key.set ctxt id public_key + end >>=? fun ctxt -> + Public_key.get ctxt id >>=? fun public_key -> + Operation.check_signature public_key op >>=? fun () -> + return ctxt + +(* TODO document parameters *) +let apply_sourced_operation + ctxt accept_failing_script miner_contract pred_block block_prio operation ops = + match ops with + | Manager_operations { source ; public_key ; fee ; counter ; operations = contents } -> + Contract.get_manager ctxt source >>=? fun manager -> + check_signature_and_update_public_key + ctxt manager public_key operation >>=? fun ctxt -> + Contract.check_counter_increment + ctxt source counter >>=? fun () -> + Contract.increment_counter ctxt source >>=? fun ctxt -> + Contract.spend ctxt source fee >>=? fun ctxt -> + (match miner_contract with + | None -> return ctxt + | Some contract -> + Contract.credit ctxt contract fee) >>=? fun ctxt -> + fold_left_s (fun ctxt content -> + apply_manager_operation_content ctxt accept_failing_script source content) + ctxt contents >>=? fun ctxt -> + return ctxt + | Delegate_operations { source ; operations = contents } -> + let delegate = Ed25519.hash source in + check_signature_and_update_public_key + ctxt delegate (Some source) operation >>=? fun ctxt -> + (* TODO, see how to extract the public key hash after this operation to + pass it to apply_delegate_operation_content *) + fold_left_s (fun ctxt content -> + apply_delegate_operation_content + ctxt delegate pred_block block_prio content) + ctxt contents >>=? fun ctxt -> + return ctxt + +let apply_anonymous_operation ctxt miner_contract kind = + match kind with + | Seed_nonce_revelation { level ; nonce } -> + let level = Level.from_raw ctxt level in + Nonce.reveal ctxt level nonce >>=? fun (ctxt, delegate_to_reward, + reward_amount) -> + Reward.record ctxt + delegate_to_reward level.cycle reward_amount >>=? fun ctxt -> + (match miner_contract with + | None -> return ctxt + | Some contract -> + Contract.credit ctxt contract Constants.seed_nonce_revelation_tip) + +let apply_operation + ctxt accept_failing_script miner_contract pred_block block_prio operation = + match operation.contents with + | Anonymous_operations ops -> + fold_left_s + (fun ctxt -> apply_anonymous_operation ctxt miner_contract) + ctxt ops + | Sourced_operations op -> + apply_sourced_operation + ctxt accept_failing_script miner_contract pred_block block_prio + operation op + +let may_start_new_cycle ctxt = + Mining.dawn_of_a_new_cycle ctxt >>=? function + | None -> return ctxt + | Some new_cycle -> + let last_cycle = + match Cycle.pred new_cycle with + | None -> assert false + | Some last_cycle -> last_cycle in + Seed.clear_cycle ctxt last_cycle >>=? fun ctxt -> + Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> + Roll.clear_cycle ctxt last_cycle >>=? fun ctxt -> + Roll.froze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> + Timestamp.get_current ctxt >>=? fun timestamp -> + Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt))) + >>=? fun reward_date -> + Reward.set_reward_time_for_cycle + ctxt last_cycle reward_date >>=? fun ctxt -> + return ctxt + +let apply_main ctxt accept_failing_script block_header operations = + (* read only checks *) + Mining.check_proof_of_work_stamp ctxt block_header >>=? fun () -> + Mining.check_fitness_gap ctxt block_header >>=? fun () -> + Mining.check_mining_rights ctxt block_header >>=? fun delegate_pkh -> + Mining.check_signature ctxt block_header delegate_pkh >>=? fun () -> + (* automatic bonds payment *) + Mining.pay_mining_bond ctxt block_header delegate_pkh >>=? fun ctxt -> + (* set timestamp *) + Timestamp.set_current ctxt block_header.shell.timestamp >>=? fun ctxt -> + (* do effectful stuff *) + Fitness.increase ctxt >>=? fun ctxt -> + let priority = snd block_header.proto.mining_slot in + fold_left_s (fun ctxt operation -> + apply_operation + ctxt accept_failing_script + (Some (Contract.default_contract delegate_pkh)) + block_header.shell.predecessor priority operation) + ctxt operations >>=? fun ctxt -> + (* end of level (from this point nothing should fail) *) + let reward = + Mining.base_mining_reward ctxt + ~priority:(snd block_header.proto.mining_slot) in + Nonce.record_hash ctxt + delegate_pkh reward block_header.proto.seed_nonce_hash >>=? fun ctxt -> + Reward.pay_due_rewards ctxt >>=? fun ctxt -> + Level.increment_current ctxt >>=? fun ctxt -> + (* end of cycle *) + may_start_new_cycle ctxt >>=? fun ctxt -> + Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt -> + return ctxt + +type error += Internal_error of string + +let apply ctxt accept_failing_script block_header operations = + (init ctxt >>=? fun ctxt -> + get_prevalidation ctxt >>= function + | true -> + fail (Internal_error "we should not call `apply` after `preapply`!") + | false -> + apply_main ctxt accept_failing_script block_header operations >>=? fun ctxt -> + finalize ctxt) + +let empty_result = + { Updater.applied = []; + refused = Operation_hash_map.empty; + branch_refused = Operation_hash_map.empty; + branch_delayed = Operation_hash_map.empty; + } + +let compare_operations op1 op2 = + match op1.contents, op2.contents with + | Anonymous_operations _, Anonymous_operations _ -> 0 + | Anonymous_operations _, Sourced_operations _ -> 1 + | Sourced_operations _, Anonymous_operations _ -> -1 + | Sourced_operations op1, Sourced_operations op2 -> + match op1, op2 with + | Delegate_operations _, Manager_operations _ -> -1 + | Manager_operations _, Delegate_operations _ -> 1 + | Delegate_operations _, Delegate_operations _ -> 0 + | Manager_operations op1, Manager_operations op2 -> begin + (* Manager operations with smaller counter are pre-validated first. *) + Int32.compare op1.counter op2.counter + end + +let merge_result r r' = + let open Updater in + let merge _key a b = + match a, b with + | None, None -> None + | Some x, None -> Some x + | _, Some y -> Some y in + { applied = r.applied @ r'.applied ; + refused = Operation_hash_map.merge merge r.refused r'.refused ; + branch_refused = + Operation_hash_map.merge merge r.branch_refused r'.branch_refused ; + branch_delayed = r'.branch_delayed ; + } + +let prevalidate ctxt pred_block sort operations = + let operations = + if sort then List.sort compare_operations operations else operations in + let rec loop ctxt operations = + (Lwt_list.fold_left_s + (fun (ctxt, r) op -> + apply_operation ctxt false None pred_block 0l op >>= function + | Ok ctxt -> + let applied = op.hash :: r.Updater.applied in + Lwt.return (ctxt, { r with Updater.applied} ) + | Error errors -> + match classify_errors errors with + | `Branch -> + let branch_refused = + Operation_hash_map.add op.hash errors r.Updater.branch_refused in + Lwt.return (ctxt, { r with Updater.branch_refused }) + | `Permanent -> + let refused = + Operation_hash_map.add op.hash errors r.Updater.refused in + Lwt.return (ctxt, { r with Updater.refused }) + | `Temporary -> + let branch_delayed = + Operation_hash_map.add op.hash errors r.Updater.branch_delayed in + Lwt.return (ctxt, { r with Updater.branch_delayed })) + (ctxt, empty_result) + operations >>= fun (ctxt, r) -> + match r.Updater.applied with + | _ :: _ when sort -> + let rechecked_operations = + List.filter + (fun op -> Operation_hash_map.mem op.hash r.Updater.branch_delayed) + operations in + loop ctxt rechecked_operations >>=? fun (ctxt, r') -> + return (ctxt, merge_result r r') + | _ -> + return (ctxt, r)) in + loop ctxt operations + +let preapply ctxt pred_block timestamp sort operations = + let result = + init ctxt >>=? fun ctxt -> + begin + get_prevalidation ctxt >>= function + | true -> return ctxt + | false -> + set_prevalidation ctxt >>= fun ctxt -> + Fitness.increase ctxt >>=? fun ctxt -> + return ctxt + end >>=? fun ctxt -> + Timestamp.set_current ctxt timestamp >>=? fun ctxt -> + prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) -> + (* TODO should accept failing script in the last round ? + or: what should we export to let the miner decide *) + finalize ctxt >>=? fun ctxt -> + return (ctxt, r) in + (* "Reify" errors into options. *) + result >>|? function (ctxt, r) -> + (ctxt, { r with Updater.applied = List.rev r.Updater.applied }) diff --git a/src/proto/bootstrap/asset_repr.ml b/src/proto/bootstrap/asset_repr.ml new file mode 100644 index 000000000..8148a11d9 --- /dev/null +++ b/src/proto/bootstrap/asset_repr.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = int32 +type asset = t +let of_int32 i = i +let to_int32 i = i + +let encoding = + let open Data_encoding in + describe + ~title: "Asset type" + ~description: "A type of asset" + (conv to_int32 of_int32 int32) + + +module Map = struct + module Raw = Map.Make(struct + type t = asset * Ed25519.public_key_hash + let compare (a1, pk1) (a2, pk2) = + if Compare.Int32.(a1 = a2) then + Ed25519.compare_hash pk1 pk2 + else + Compare.Int32.compare a1 a2 + end) + type t = Tez_repr.tez Raw.t + let empty = Raw.empty + let add map asset key quantity = + let previous_quantity = + try Raw.find (asset, key) map + with Not_found -> Tez_repr.zero in + Tez_repr.(previous_quantity +? quantity) >>? fun total -> + ok (Raw.add (asset, key) total map) + + let of_tuple_list_exn tl = + List.fold_left + (fun map (key, qty) -> Raw.add key qty map) + Raw.empty tl + + +let encoding = + let open Data_encoding in + describe + ~title: "Assets" + ~description: "A list of assets held in the contract" + (conv + Raw.bindings + (Json.wrap_error of_tuple_list_exn) + (list + (tup2 + (tup2 encoding Ed25519.public_key_hash_encoding) + Tez_repr.encoding))) + +end + diff --git a/src/proto/bootstrap/asset_repr.mli b/src/proto/bootstrap/asset_repr.mli new file mode 100644 index 000000000..b0f8fb033 --- /dev/null +++ b/src/proto/bootstrap/asset_repr.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type asset = t + +val encoding: asset Data_encoding.t +val of_int32 : int32 -> asset + +module Map : sig + type t + val empty: t + val add: + t -> asset -> Ed25519.public_key_hash -> Tez_repr.tez -> t tzresult + val encoding: t Data_encoding.t +end diff --git a/src/proto/bootstrap/block_repr.ml b/src/proto/bootstrap/block_repr.ml new file mode 100644 index 000000000..7982d8d78 --- /dev/null +++ b/src/proto/bootstrap/block_repr.ml @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +(** Block header *) + +(** Exported type *) +type header = { + shell: Updater.shell_block_header ; + proto: proto_header ; + signature: Ed25519.signature ; +} + +and proto_header = { + mining_slot: mining_slot ; + seed_nonce_hash: Nonce_hash.t ; + proof_of_work_nonce: MBytes.t ;} + +and mining_slot = Raw_level_repr.t * Int32.t + +let mining_slot_encoding = + let open Data_encoding in + tup2 Raw_level_repr.encoding int32 + +let proto_header_encoding = + let open Data_encoding in + conv + (fun { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } -> + (mining_slot, seed_nonce_hash, proof_of_work_nonce)) + (fun (mining_slot, seed_nonce_hash, proof_of_work_nonce) -> + { mining_slot ; seed_nonce_hash ; proof_of_work_nonce }) + (obj3 + (req "slot" mining_slot_encoding) + (req "seed_nonce_hash" Nonce_hash.encoding) + (req "proof_of_work_nonce" (Fixed.bytes Constants_repr.proof_of_work_nonce_size))) + +let signed_proto_header_encoding = + let open Data_encoding in + merge_objs + proto_header_encoding + (obj1 (req "signature" Ed25519.signature_encoding)) + +let unsigned_header_encoding = + let open Data_encoding in + merge_objs + Updater.shell_block_header_encoding + proto_header_encoding + +(** Constants *) + +let max_header_length = + match Data_encoding.classify signed_proto_header_encoding with + | `Fixed n -> n + | `Dynamic | `Variable -> assert false + +(** Header parsing entry point *) + +type error += + | Cant_parse_proto_header + +let parse_header + ({ shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ; + proto } : Updater.raw_block_header) : header tzresult = + match Data_encoding.Binary.of_bytes signed_proto_header_encoding proto with + | None -> Error [Cant_parse_proto_header] + | Some (proto, signature) -> + let shell = + { Updater.net_id ; predecessor ; timestamp ; fitness ; operations } in + Ok { shell ; proto ; signature } + +let forge_header shell proto = + Data_encoding.Binary.to_bytes unsigned_header_encoding (shell, proto) diff --git a/src/proto/bootstrap/block_repr.mli b/src/proto/bootstrap/block_repr.mli new file mode 100644 index 000000000..02509613e --- /dev/null +++ b/src/proto/bootstrap/block_repr.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +(** Exported type *) +type header = { + shell: Updater.shell_block_header ; + proto: proto_header ; + signature: Ed25519.signature ; +} + +and proto_header = { + mining_slot: mining_slot ; + seed_nonce_hash: Nonce_hash.t ; + proof_of_work_nonce: MBytes.t ; +} + +and mining_slot = Raw_level_repr.t * Int32.t + +val mining_slot_encoding: mining_slot Data_encoding.encoding + +(** The maximum size of block headers in bytes *) +val max_header_length: int + +(** Parse the protocol-specific part of a block header. *) +val parse_header: Updater.raw_block_header -> header tzresult + +val unsigned_header_encoding: + (Updater.shell_block_header * proto_header) Data_encoding.encoding + +val forge_header: + Updater.shell_block_header -> proto_header -> MBytes.t + diff --git a/src/proto/bootstrap/bootstrap_storage.ml b/src/proto/bootstrap/bootstrap_storage.ml new file mode 100644 index 000000000..d73438a58 --- /dev/null +++ b/src/proto/bootstrap/bootstrap_storage.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type account = { + public_key_hash : Ed25519.public_key_hash ; + public_key : Ed25519.public_key ; + secret_key : Ed25519.secret_key ; +} + +(* FIXME: when incresing wealth *10, the node is very slow to initialize... + this should be investigated... *) +let wealth = Tez_repr.of_cents_exn 2_000_000_00L + +let make ~raw_secret_key ~raw_public_key = + let raw_secret_key = + raw_secret_key + |> Hex_encode.hex_decode + |> MBytes.of_string in + let raw_public_key = + raw_public_key + |> Hex_encode.hex_decode + |> MBytes.of_string in + let secret_key = + match Data_encoding.Binary.of_bytes Ed25519.secret_key_encoding raw_secret_key with + | None -> assert false + | Some v -> v in + let public_key = + match Data_encoding.Binary.of_bytes Ed25519.public_key_encoding raw_public_key with + | None -> assert false + | Some v -> v in + (* check that keys correspond *) + let bytes = MBytes.of_string "some test text" in + let signature = Ed25519.sign secret_key bytes in + assert (Ed25519.check_signature public_key signature bytes) ; + let public_key_hash = Ed25519.hash public_key in + { public_key_hash ; public_key ; secret_key } + +let accounts = [ + make + ~raw_public_key: + "000000204798D2CC98473D7E250C898885718AFD2E4EFBCB1A1595AB9730761ED830DE0F" + ~raw_secret_key: + "000000408500C86780141917FCD8AC6A54A43A9EEDA1ABA9D263CE5DEC5A1D0E5DF1E598\ + 4798D2CC98473D7E250C898885718AFD2E4EFBCB1A1595AB9730761ED830DE0F" ; + make + ~raw_public_key: + "000000202dc050925cf3a80c0d0fd4589e1d86e2a4e07118e29458a537ed6382cb697d97" + ~raw_secret_key: + "000000403f6aa02bc3cf23d7d4955f3d2708c84368372779aca1cfe013def93cf15dfcdb\ + 2dc050925cf3a80c0d0fd4589e1d86e2a4e07118e29458a537ed6382cb697d97" ; + make + ~raw_public_key: + "000000206b6aa000041caa65d1df72354d329beae2a782c59021f25c6f40bf4a88781c1b" + ~raw_secret_key: + "00000040c56dcb77f1fff00d1a1f5330a77a9f1f31cf70fa7ad691a22b5ec28cdb232350\ + 6b6aa000041caa65d1df72354d329beae2a782c59021f25c6f40bf4a88781c1b" ; + make + ~raw_public_key: + "0000002050e67edf7dbff2c9a45f0bfae892964c67c61472a74d3ab1e51aa009611c788f" + ~raw_secret_key: + "000000401fa3088f39928af52331654f0d9234787f345988a4ee46b619b94d8ad5405dc8\ + 50e67edf7dbff2c9a45f0bfae892964c67c61472a74d3ab1e51aa009611c788f" ; + make + ~raw_public_key: + "00000020c34b689f812ccca41c114a123aa44f55846fec7eb956b6b852d2d19003e63165" + ~raw_secret_key: + "00000040e4104362f6db39d47aa1a85bd0d5b54b712f6d8c603c0c81bf01b42123d0d9b9\ + c34b689f812ccca41c114a123aa44f55846fec7eb956b6b852d2d19003e63165" ; +] + +let init_account ctxt account = + Storage.Public_key.init ctxt account.public_key_hash account.public_key >>=? fun ctxt -> + Contract_storage.credit + ctxt + (Contract_repr.default_contract account.public_key_hash) + wealth >>=? fun ctxt -> + return ctxt + +let init ctxt = + fold_left_s init_account ctxt accounts >>=? fun ctxt -> + return ctxt + +let account_encoding = + let open Data_encoding in + conv + (fun {public_key_hash ; public_key ; secret_key } -> + (public_key_hash, public_key, secret_key)) + (fun (public_key_hash, public_key, secret_key) -> + { public_key_hash ; public_key ; secret_key }) + (obj3 + (req "publicKeyHash" Ed25519.public_key_hash_encoding) + (req "publicKey" Ed25519.public_key_encoding) + (req "secretKey" Ed25519.secret_key_encoding)) + diff --git a/src/proto/bootstrap/bootstrap_storage.mli b/src/proto/bootstrap/bootstrap_storage.mli new file mode 100644 index 000000000..40eedc5d8 --- /dev/null +++ b/src/proto/bootstrap/bootstrap_storage.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type account = { + public_key_hash : Ed25519.public_key_hash ; + public_key : Ed25519.public_key ; + secret_key : Ed25519.secret_key ; +} + +val account_encoding: account Data_encoding.t + +val accounts: account list + +val init: Storage.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/bootstrap/constants_repr.ml b/src/proto/bootstrap/constants_repr.ml new file mode 100644 index 000000000..605d01df3 --- /dev/null +++ b/src/proto/bootstrap/constants_repr.ml @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let version_number = "\000" + +let max_operation_data_length = 16 * 1024 +let max_number_of_operations = 200 +let proof_of_work_nonce_size = 8 +let nonce_length = 32 + +let roll_value = + Tez_repr.of_cents_exn 10000_00L +let seed_nonce_revelation_tip = + Tez_repr.of_cents_exn 10_00L +let origination_burn = + Tez_repr.of_cents_exn 1_00L +let minimal_contract_balance = + Tez_repr.of_cents_exn 1_00L +let mining_bond_cost = + Tez_repr.of_cents_exn 1000_00L +let endorsement_bond_cost = + Tez_repr.of_cents_exn 1000_00L +let mining_reward = + Tez_repr.of_cents_exn 150_00L +let endorsement_reward = + Tez_repr.of_cents_exn 150_00L + +type constants = { + cycle_length: int32 ; + voting_period_length: int32 ; + time_before_reward: Period_repr.t ; + time_between_slots: Period_repr.t ; + first_free_mining_slot: int32 ; + max_signing_slot: int ; + instructions_per_transaction: int ; + proof_of_work_threshold: int ; +} + +let default = { + cycle_length = 2048l ; + voting_period_length = 32768l ; + time_before_reward = + Period_repr.of_seconds_exn + (* One year in seconds *) + Int64.(mul 365L (mul 24L 3600L)) ; + time_between_slots = + Period_repr.of_seconds_exn + (* One minute in seconds *) + 60L ; + first_free_mining_slot = 16l ; + max_signing_slot = 15 ; + instructions_per_transaction = 16 * 1024 ; + proof_of_work_threshold = 8 ; +} + +let opt (=) def v = if def = v then None else Some v +let unopt def = function None -> def | Some v -> v + +let map_option f = function + | None -> None + | Some x -> Some (f x) + +let constants_encoding = + (* let open Data_encoding in *) + Data_encoding.conv + (fun c -> + let open Compare in + let cycle_length = + opt Int32.(=) + default.cycle_length c.cycle_length + and voting_period_length = + opt Int32.(=) + default.voting_period_length c.voting_period_length + and time_before_reward = + map_option Period_repr.to_seconds @@ + opt Period_repr.(=) + default.time_before_reward c.time_before_reward + and time_between_slots = + map_option Period_repr.to_seconds @@ + opt Period_repr.(=) + default.time_between_slots c.time_between_slots + and first_free_mining_slot = + opt Int32.(=) + default.first_free_mining_slot c.first_free_mining_slot + and max_signing_slot = + opt Int.(=) + default.max_signing_slot c.max_signing_slot + and instructions_per_transaction = + opt Int.(=) + default.instructions_per_transaction c.instructions_per_transaction + and proof_of_work_threshold = + opt Int.(=) + default.proof_of_work_threshold c.proof_of_work_threshold + in + ( cycle_length, + voting_period_length, + time_before_reward, + time_between_slots, + first_free_mining_slot, + max_signing_slot, + instructions_per_transaction, + proof_of_work_threshold + ) ) + (fun ( cycle_length, + voting_period_length, + time_before_reward, + time_between_slots, + first_free_mining_slot, + max_signing_slot, + instructions_per_transaction, + proof_of_work_threshold + ) -> + { cycle_length = + unopt default.cycle_length cycle_length ; + voting_period_length = + unopt default.voting_period_length voting_period_length ; + time_before_reward = + unopt default.time_before_reward @@ + map_option Period_repr.of_seconds_exn time_before_reward ; + time_between_slots = + unopt default.time_between_slots @@ + map_option Period_repr.of_seconds_exn time_between_slots ; + first_free_mining_slot = + unopt default.first_free_mining_slot first_free_mining_slot ; + max_signing_slot = + unopt default.max_signing_slot max_signing_slot ; + instructions_per_transaction = + unopt default.instructions_per_transaction instructions_per_transaction ; + proof_of_work_threshold = + unopt default.proof_of_work_threshold proof_of_work_threshold ; + } ) + Data_encoding.( + obj8 + (opt "cycle_length" int32) + (opt "voting_period_length" int32) + (opt "time_before_reward" int64) + (opt "time_between_slots" int64) + (opt "first_free_mining_slot" int32) + (opt "max_signing_slot" int31) + (opt "instructions_per_transaction" int31) + (opt "proof_of_work_threshold" int31) + ) + +type error += Constant_read of exn + +let read = function + | None -> + return default + | Some json -> + match Data_encoding.Json.(destruct constants_encoding json) with + | exception exn -> fail (Constant_read exn) + | c -> return c diff --git a/src/proto/bootstrap/contract_repr.ml b/src/proto/bootstrap/contract_repr.ml new file mode 100644 index 000000000..d7e806669 --- /dev/null +++ b/src/proto/bootstrap/contract_repr.ml @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +type descr = { + manager: Ed25519.public_key_hash ; + delegate: Ed25519.public_key_hash option ; + spendable: bool ; + delegatable: bool ; + script: Script_repr.t ; +} + +type t = + | Default of Ed25519.public_key_hash + | Hash of Contract_hash.t +type contract = t + +type error += Invalid_contract_notation of string + +let to_b48check = function + | Default pbk -> Ed25519.Public_key_hash.to_b48check pbk + | Hash h -> Contract_hash.to_b48check h + +let of_b48check s = + try + match Base48.decode s with + | Ed25519.Public_key_hash.Hash h -> ok (Default h) + | Contract_hash.Hash h -> ok (Hash h) + | _ -> error (Invalid_contract_notation s) + with _ -> error (Invalid_contract_notation s) + +let encoding = + let open Data_encoding in + describe + ~title: + "A contract handle" + ~description: + "A contract notation as given to a RPC or inside scripts. \ + Contract handles can be written 'dd' \ + for the default contract of some ID (public key hash) or \ + 'hh' for a created contract or account, \ + as replied by the contract origination RPC." @@ + splitted + ~binary: + (union ~tag_size:`Int8 [ + case ~tag:0 Ed25519.public_key_hash_encoding + (function Default k -> Some k | _ -> None) + (fun k -> Default k) ; + case ~tag:1 Contract_hash.encoding + (function Hash k -> Some k | _ -> None) + (fun k -> Hash k) ; + ]) + ~json: + (conv + to_b48check + (fun s -> + match of_b48check s with + | Ok s -> s + | Error _ -> Json.cannot_destruct "Invalid contract notation.") + string) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"InvalidContractNotationError" + ~title: "Invalid contract notation" + ~description: + "A malformed contract notation was given to a RPC or by a script. \ + Contract handles can be written 'dd' \ + for the default contract of some ID (public key hash) or \ + 'hh' for a created contract or account, \ + as replied by the contract origination RPC." + (obj1 (req "notation" string)) + (function Invalid_contract_notation loc -> Some loc | _ -> None) + (fun loc -> Invalid_contract_notation loc) + +let default_contract id = Default id + +let is_default = function + | Default m -> Some m + | Hash _ -> None + +let descr_encoding = + let open Data_encoding in + conv + (fun { manager; delegate; spendable; delegatable; script } -> + (manager, delegate, spendable, delegatable, script)) + (fun (manager, delegate, spendable, delegatable, script) -> + { manager; delegate; spendable; delegatable; script }) + (obj5 + (req "manager" Ed25519.public_key_hash_encoding) + (opt "delegate" Ed25519.public_key_hash_encoding) + (dft "spendable" bool false) + (dft "delegatable" bool false) + (req "script" Script_repr.encoding)) + +let generic_contract ~manager ~delegate ~spendable ~delegatable ~script = + match delegate, spendable, delegatable, script with + | Some delegate, true, false, Script_repr.No_script + when Ed25519.equal_hash manager delegate -> + default_contract manager + | _ -> + let data = + Data_encoding.Binary.to_bytes + descr_encoding + { manager; delegate; spendable; delegatable; script } in + Hash (Contract_hash.hash_bytes [data]) + +let arg = + let construct = to_b48check in + let destruct hash = + match of_b48check hash with + | Error _ -> Error "Cannot parse contract id" + | Ok contract -> Ok contract in + RPC.Arg.make + ~descr: "A contract identifier encoded in b48check." + ~name: "contract_id" + ~construct + ~destruct + +let compare l1 l2 = + match l1, l2 with + | Default pkh1, Default pkh2 -> + Ed25519.compare_hash pkh1 pkh2 + | Hash h1, Hash h2 -> + Contract_hash.compare h1 h2 + | Default _, Hash _ -> -1 + | Hash _, Default _ -> 1 +let (=) l1 l2 = Compare.Int.(=) (compare l1 l2) 0 +let (<>) l1 l2 = Compare.Int.(<>) (compare l1 l2) 0 +let (>) l1 l2 = Compare.Int.(>) (compare l1 l2) 0 +let (>=) l1 l2 = Compare.Int.(>=) (compare l1 l2) 0 +let (<=) l1 l2 = Compare.Int.(<=) (compare l1 l2) 0 +let (<) l1 l2 = Compare.Int.(<) (compare l1 l2) 0 +let min l1 l2 = if l1 <= l2 then l1 else l2 +let max l1 l2 = if l1 >= l2 then l1 else l2 diff --git a/src/proto/bootstrap/contract_repr.mli b/src/proto/bootstrap/contract_repr.mli new file mode 100644 index 000000000..86047b798 --- /dev/null +++ b/src/proto/bootstrap/contract_repr.mli @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +type t = private + | Default of Ed25519.public_key_hash + | Hash of Contract_hash.t +type contract = t + +type descr = { + manager: Ed25519.public_key_hash ; + delegate: Ed25519.public_key_hash option ; + spendable: bool ; + delegatable: bool ; + script: Script_repr.t ; +} + +include Compare.S with type t := contract + +val default_contract : Ed25519.public_key_hash -> contract + +val is_default : contract -> Ed25519.public_key_hash option + +val generic_contract : + manager:Ed25519.public_key_hash -> + delegate:Ed25519.public_key_hash option -> + spendable:bool -> + delegatable:bool -> + script:Script_repr.t -> + contract + +(** {2 Human readable notation} ***********************************************) + +type error += Invalid_contract_notation of string + +val to_b48check: contract -> string + +val of_b48check: string -> contract tzresult + +(** {2 Serializers} ***********************************************************) + +val encoding : contract Data_encoding.t +val descr_encoding : descr Data_encoding.t + +val arg : contract RPC.Arg.arg diff --git a/src/proto/bootstrap/contract_storage.ml b/src/proto/bootstrap/contract_storage.ml new file mode 100644 index 000000000..28501948f --- /dev/null +++ b/src/proto/bootstrap/contract_storage.ml @@ -0,0 +1,312 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Contract_repr + +type error += + | Insert_coin of Contract_repr.contract (* TODO: doc *) + | Initial_amount_too_low (* TODO: doc *) + | Failure of string + | Invalid_counter of Contract_repr.contract * int32 * int32 + | Code_without_storage + | Unspendable_contract + | Non_existing_contract + | No_delegate + | Undelagatable_contract + | Scriptless_contract + | Too_low_balance + +let () = + register_error_kind + `Branch + ~id:"contract.too_low_balance" + ~title:"Too low balance" + ~description:"TODO" + ~pp:(fun ppf () -> Format.fprintf ppf "Too low balance") + Data_encoding.empty + (function Too_low_balance -> Some () | _ -> None) + (fun () -> Too_low_balance) + +let () = + register_error_kind + `Branch + ~id:"contract.invalid_counter" + ~title:"Invalid counter in a manager operation" + ~description:"TODO" + ~pp:(fun ppf (contract, exp, found) -> + Format.fprintf ppf + "Unexpected counter %ld for contract %s (expected %ld)" + found (Contract_repr.to_b48check contract) exp) + Data_encoding. + (obj3 + (req "contract" Contract_repr.encoding) + (req "expected" int32) + (req "found" int32)) + (function Invalid_counter (c, x, y) -> Some (c, x, y) | _ -> None) + (fun (c, x, y) -> Invalid_counter (c, x, y)) + +let failwith msg = fail (Failure msg) + +let create_base c contract ~balance ~manager ~delegate ~script ~spendable ~delegatable = + (match Contract_repr.is_default contract with + | None -> return 0l + | Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter -> + Storage.Contract.Balance.init c contract balance >>=? fun c -> + Storage.Contract.Manager.init c contract manager >>=? fun c -> + (* TODO, to answer: + If the contract is not delegatable, can it be created with a delegate ? *) + begin + match delegate with + | None -> return c + | Some delegate -> + Storage.Contract.Delegate.init c contract delegate + end >>=? fun c -> + Storage.Contract.Spendable.init c contract spendable >>=? fun c -> + Storage.Contract.Delegatable.init c contract delegatable >>=? fun c -> + Storage.Contract.Assets.init c contract Asset_repr.Map.empty >>=? fun c -> + Storage.Contract.Counter.init c contract counter >>=? fun c -> + (match script with + | Script_repr.Script { code ; storage } -> + Storage.Contract.Code.init c contract code >>=? fun c -> + Storage.Contract.Storage.init c contract storage + | No_script -> + return c) >>=? fun c -> + Roll_storage.Contract.init c contract >>=? fun c -> + Roll_storage.Contract.add_amount c contract balance >>=? fun c -> + Storage.Contract.Set.add c contract >>=? fun c -> + Lwt.return (Ok (c, contract)) + +let create c ~balance ~manager ~delegate ~script ~spendable ~delegatable = + let contract = + Contract_repr.generic_contract ~manager ~delegate + ~script ~spendable ~delegatable in + create_base c contract ~balance ~manager ~delegate ~script ~spendable ~delegatable + +let create_default c manager ~balance = + let contract = Contract_repr.default_contract manager in + create_base c contract ~manager ~delegate:(Some manager) + ~spendable:true ~delegatable:false ~script:Script_repr.No_script + ~balance + +let delete c contract = + Storage.Contract.Balance.get c contract >>=? fun balance -> + Roll_storage.Contract.remove_amount c contract balance >>=? fun c -> + Roll_storage.Contract.assert_empty c contract >>=? fun () -> + Storage.Contract.Balance.delete c contract >>=? fun c -> + Storage.Contract.Manager.delete c contract >>=? fun c -> + Storage.Contract.Delegate.delete c contract >>=? fun c -> + Storage.Contract.Spendable.delete c contract >>=? fun c -> + Storage.Contract.Delegatable.delete c contract >>=? fun c -> + Storage.Contract.Counter.delete c contract >>=? fun c -> + Storage.Contract.Code.remove c contract >>= fun c -> + Storage.Contract.Storage.remove c contract >>= fun c -> + Storage.Contract.Set.del c contract + +let exists c contract = + match Contract_repr.is_default contract with + | Some _ -> return true + | None -> + Storage.Contract.Counter.get_option c contract >>=? function + | None -> return false + | Some _ -> return true + +let list c = + Storage.Contract.Set.elements c + +let check_counter_increment c contract counter = + Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + if Compare.Int32.(Int32.succ contract_counter = counter) + then return () + else + fail (Invalid_counter (contract, Int32.succ contract_counter, counter)) + +let increment_counter c contract = + Storage.Contract.Global_counter.get c >>=? fun global_counter -> + Storage.Contract.Global_counter.set c (Int32.succ global_counter) >>=? fun c -> + Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + Storage.Contract.Counter.set c contract (Int32.succ contract_counter) + +let get_script c contract = + Storage.Contract.Code.get_option c contract >>=? fun code -> + Storage.Contract.Storage.get_option c contract >>=? fun storage -> + match code, storage with + | None, None -> return Script_repr.No_script + | Some code, Some storage -> return (Script_repr.Script { code ; storage }) + | None, Some _ | Some _, None -> fail Code_without_storage + +let get_counter c contract = + Storage.Contract.Counter.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some _ -> Storage.Contract.Global_counter.get c + | None -> failwith "get_counter" + end + | Some v -> return v + +let get_manager c contract = + Storage.Contract.Manager.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some manager -> return manager + | None -> failwith "get_manager" + end + | Some v -> return v + +let get_delegate_opt = Roll_storage.get_contract_delegate + +let get_delegate c contract = + get_delegate_opt c contract >>=? function + | None -> fail No_delegate + | Some delegate -> return delegate + +let get_balance c contract = + Storage.Contract.Balance.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some _ -> return Tez_repr.zero + | None -> failwith "get_balance" + end + | Some v -> return v + +let get_assets c contract = + Storage.Contract.Assets.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some _ -> return Asset_repr.Map.empty + | None -> failwith "get_assets" + end + | Some a -> return a + +let is_delegatable c contract = + Storage.Contract.Delegatable.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some _ -> return false + | None -> failwith "is_delegatable" + end + | Some v -> return v + +let is_spendable c contract = + Storage.Contract.Spendable.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_default contract with + | Some _ -> return true + | None -> failwith "is_spendable" + end + | Some v -> return v + +let get_descr c contract = + get_manager c contract >>=? fun manager -> + get_delegate_opt c contract >>=? fun delegate -> + is_spendable c contract >>=? fun spendable -> + is_delegatable c contract >>=? fun delegatable -> + get_script c contract >>=? fun script -> + return { manager ; delegate ; spendable ; delegatable ; script } + +let set_delegate c contract delegate = + (* A contract delegate can be set only if the contract is delegatable *) + Storage.Contract.Delegatable.get c contract >>=? fun delegatable -> + if not delegatable + then fail Undelagatable_contract + else + match delegate with + | None -> + Storage.Contract.Delegate.remove c contract >>= fun c -> + return c + | Some delegate -> + Storage.Contract.Delegate.init_set c contract delegate + +(** Verify that the balance is high enouth for the used memory *) +let check_fee script balance = + (match script with + | Script_repr.No_script -> return Constants_repr.minimal_contract_balance + | Script { code ; storage } -> + let storage_fee = Script_repr.storage_cost storage in + let code_fee = Script_repr.code_cost code in + Lwt.return Tez_repr.(code_fee +? storage_fee) >>=? fun script_fee -> + Lwt.return Tez_repr.(Constants_repr.minimal_contract_balance +? script_fee)) >>=? fun fee -> + return Tez_repr.(fee <= balance) + +let update_script_storage c contract storage = + let open Script_repr in + Storage.Contract.Balance.get_option c contract >>=? function + | None -> + (* The contract was destroyed *) + return c + | Some balance -> + get_script c contract >>=? function + | No_script -> fail Scriptless_contract + | Script { code ; storage = { storage_type } } -> + check_fee + (Script_repr.Script { code ; storage = { storage; storage_type }}) balance >>=? fun ok -> + fail_unless ok (Insert_coin contract) >>=? fun () -> + Storage.Contract.Storage.set c contract { storage; storage_type } + +let unconditional_spend c contract amount = + Storage.Contract.Balance.get c contract >>=? fun balance -> + match Tez_repr.(balance - amount) with + | None -> + fail Too_low_balance + | Some new_balance -> + get_script c contract >>=? fun script -> + check_fee script new_balance >>=? fun keep_contract -> + if keep_contract then + Storage.Contract.Balance.set c contract new_balance >>=? fun c -> + Roll_storage.Contract.remove_amount c contract amount + else + delete c contract + +let credit c contract amount = + Storage.Contract.Balance.get_option c contract >>=? function + | None -> begin + (* If the contract does not exists and it is a default contract, + create it *) + match Contract_repr.is_default contract with + | None -> fail Non_existing_contract + | Some manager -> + if Tez_repr.(amount < Constants_repr.minimal_contract_balance) + then + (* If this is not enough to maintain the contract alive, + we just drop the money *) + return c + else + create_default c manager ~balance:amount >>=? fun (c, _) -> + (* TODO: fail_unless Contract_repr.(contract = new_contract) still needed ?? *) + return c + end + | Some balance -> + Lwt.return Tez_repr.(amount +? balance) >>=? fun balance -> + Storage.Contract.Balance.set c contract balance >>=? fun c -> + Roll_storage.Contract.add_amount c contract amount + +let issue c contract asset key quantity = + Storage.Contract.Assets.get_option c contract >>=? function + | None -> + Lwt.return (Asset_repr.Map.add Asset_repr.Map.empty asset key quantity) >>=? + Storage.Contract.Assets.set c contract + | Some assets -> + Lwt.return (Asset_repr.Map.add assets asset key quantity) >>=? + Storage.Contract.Assets.set c contract + +let spend c contract amount = + Storage.Contract.Spendable.get c contract >>=? fun spendable -> + if not spendable + then fail Unspendable_contract + else unconditional_spend c contract amount + +let originate c ~balance ~manager ~script ~delegate ~spendable ~delegatable = + check_fee script balance >>=? fun possible -> + fail_unless possible Initial_amount_too_low >>=? fun () -> + create c ~balance ~manager ~delegate ~script ~spendable ~delegatable + +let init c = + Storage.Contract.Global_counter.init c 0l + +let pp fmt c = + Format.pp_print_string fmt (Contract_repr.to_b48check c) diff --git a/src/proto/bootstrap/contract_storage.mli b/src/proto/bootstrap/contract_storage.mli new file mode 100644 index 000000000..b62812b91 --- /dev/null +++ b/src/proto/bootstrap/contract_storage.mli @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += + | Insert_coin of Contract_repr.t + | Initial_amount_too_low + | Failure of string + | Invalid_counter of Contract_repr.t * int32 * int32 + | Code_without_storage + | Unspendable_contract + | Non_existing_contract + | No_delegate + | Undelagatable_contract + | Scriptless_contract + | Too_low_balance + +val delete : Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t + +val exists: Storage.t -> Contract_repr.t -> bool tzresult Lwt.t + +val list: Storage.t -> Contract_repr.t list tzresult Lwt.t + +val check_counter_increment: Storage.t -> Contract_repr.t -> int32 -> unit tzresult Lwt.t +val increment_counter: Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t + +val is_delegatable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t +val is_spendable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t + +val get_descr: Storage.t -> Contract_repr.t -> Contract_repr.descr tzresult Lwt.t +val get_manager: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash tzresult Lwt.t +val get_delegate: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash tzresult Lwt.t +val get_delegate_opt: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option tzresult Lwt.t +val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t +val get_assets: Storage.t -> Contract_repr.t -> Asset_repr.Map.t tzresult Lwt.t +val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t + +val get_script: Storage.t -> Contract_repr.t -> Script_repr.t tzresult Lwt.t + +(** Update_script_storage fails if the contract has not enouth tez to + store the new data. + It does not fail if the contract does not exists *) +val update_script_storage: Storage.t -> Contract_repr.t -> Script_repr.expr -> + Storage.t tzresult Lwt.t + +(** fails if the contract is not delegatable *) +val set_delegate : Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option -> Storage.t tzresult Lwt.t + +val credit : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + +(** checks that the contract is spendable and decrease_balance *) +val spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + +(* decrease balance uncondionally *) +val unconditional_spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + +val issue : + Storage.t -> Contract_repr.t -> Asset_repr.t -> Ed25519.public_key_hash -> Tez_repr.t -> Storage.t tzresult Lwt.t + +val originate : + Storage.t -> + balance:Tez_repr.t -> + manager:Ed25519.public_key_hash -> + script:Script_repr.t -> + delegate:Ed25519.public_key_hash option -> + spendable:bool -> + delegatable:bool -> + (Storage.t * Contract_repr.t) tzresult Lwt.t + +val init : + Storage.t -> Storage.t tzresult Lwt.t + +val pp: Format.formatter -> Contract_repr.t -> unit diff --git a/src/proto/bootstrap/cycle_repr.ml b/src/proto/bootstrap/cycle_repr.ml new file mode 100644 index 000000000..e7f441277 --- /dev/null +++ b/src/proto/bootstrap/cycle_repr.ml @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = int32 +type cycle = t + +let encoding = Data_encoding.int32 +let arg = + let construct = Int32.to_string in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse cycle" + | cycle -> Ok cycle in + RPC.Arg.make + ~descr:"A cycle integer" + ~name: "block_cycle" + ~construct + ~destruct + +let pp ppf cycle = Format.fprintf ppf "%ld" cycle + +include (Compare.Int32 : Compare.S with type t := t) + +let root = 0l +let succ = Int32.succ +let pred = function + | 0l -> None + | i -> Some (Int32.pred i) + +let to_int32 i = i + +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Level_repr.Cycle.of_int32" diff --git a/src/proto/bootstrap/cycle_repr.mli b/src/proto/bootstrap/cycle_repr.mli new file mode 100644 index 000000000..9ef5f2dde --- /dev/null +++ b/src/proto/bootstrap/cycle_repr.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type cycle = t +include Compare.S with type t := t +val encoding: cycle Data_encoding.t +val arg: cycle RPC.Arg.arg +val pp: Format.formatter -> cycle -> unit + +val root: cycle +val pred: cycle -> cycle option +val succ: cycle -> cycle + +val to_int32: cycle -> int32 +val of_int32_exn: int32 -> cycle diff --git a/src/proto/bootstrap/fitness_repr.ml b/src/proto/bootstrap/fitness_repr.ml new file mode 100644 index 000000000..3c8661e8d --- /dev/null +++ b/src/proto/bootstrap/fitness_repr.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += Invalid_fitness + + +let int64_to_bytes i = + let b = MBytes.create 8 in + MBytes.set_int64 b 0 i; + b + +let int64_of_bytes b = + if Compare.Int.(MBytes.length b <> 8) then + fail Invalid_fitness + else + return (MBytes.get_int64 b 0) + +let from_int64 fitness = + return + [ MBytes.of_string Constants_repr.version_number ; + int64_to_bytes fitness ] + +let to_int64 = function + | [ version ; + fitness ] + when Compare.String. + (MBytes.to_string version = Constants_repr.version_number) -> + int64_of_bytes fitness + | _ -> fail Invalid_fitness diff --git a/src/proto/bootstrap/fitness_storage.ml b/src/proto/bootstrap/fitness_storage.ml new file mode 100644 index 000000000..1996c2166 --- /dev/null +++ b/src/proto/bootstrap/fitness_storage.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let increase ctxt = + Storage.Current_fitness.get ctxt >>=? fun fitness -> + Storage.Current_fitness.set ctxt (Int64.succ fitness) + +let raw_get = Storage.Current_fitness.get +let raw_read = Fitness_repr.to_int64 + +let get ctxt = + Storage.Current_fitness.get ctxt >>=? fun fitness -> + Fitness_repr.from_int64 fitness + +let init ctxt = + Storage.Current_fitness.init ctxt 0L diff --git a/src/proto/bootstrap/init_storage.ml b/src/proto/bootstrap/init_storage.ml new file mode 100644 index 000000000..4d044d6b6 --- /dev/null +++ b/src/proto/bootstrap/init_storage.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let version_key = ["version"] +(* This key should always be populated for every version of the + protocol. It's absence meaning that the context is empty. *) +let version_value = "genesis" + +(* This is the genesis protocol: initialise the state *) +let initialize (ctxt:Context.t) = + Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt -> + Storage.prepare ctxt >>=? fun store -> + Storage.get_genesis_time store >>= fun time -> + Storage.Current_timestamp.init_set store time >>=? fun store -> + Fitness_storage.init store >>=? fun store -> + Level_storage.init store >>=? fun store -> + Roll_storage.init store >>=? fun store -> + Seed_storage.init store >>=? fun store -> + Contract_storage.init store >>=? fun store -> + Reward_storage.init store >>=? fun store -> + Bootstrap_storage.init store >>=? fun store -> + Roll_storage.froze_rolls_for_cycle + store Cycle_repr.root >>=? fun store -> + Roll_storage.froze_rolls_for_cycle + store Cycle_repr.(succ root) >>=? fun store -> + Vote_storage.init store >>=? fun store -> + return store + +type error += + | Incompatiple_protocol_version + | Unimplemented_sandbox_migration + +let may_initialize ctxt = + Context.get ctxt version_key >>= function + | None -> + (* This is the genesis protocol: The only acceptable preceding + version is an empty context *) + initialize ctxt + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) + then Storage.prepare ctxt + else fail Incompatiple_protocol_version + +let configure_sandbox ctxt json = + let json = + match json with + | None -> `O [] + | Some json -> json in + Context.get ctxt version_key >>= function + | None -> + Storage.set_sandboxed ctxt json >>= fun ctxt -> + initialize ctxt >>=? fun ctxt -> + return (Storage.recover ctxt) + | Some _ -> + Storage.get_sandboxed ctxt >>=? function + | None -> + fail Unimplemented_sandbox_migration + | Some _ -> + (* FIXME GRGR fail if parameter changed! *) + (* failwith "Changing sandbox parameter is not yet implemented" *) + return ctxt diff --git a/src/proto/bootstrap/level_repr.ml b/src/proto/bootstrap/level_repr.ml new file mode 100644 index 000000000..b39f700ed --- /dev/null +++ b/src/proto/bootstrap/level_repr.ml @@ -0,0 +1,72 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +type t = { + level: Raw_level_repr.t ; + cycle: Cycle_repr.t ; + cycle_position: int32 ; + voting_period: Voting_period_repr.t ; + voting_period_position: int32 ; +} + +type level = t + +let pp ppf { level } = Raw_level_repr.pp ppf level + +let encoding = + let open Data_encoding in + conv + (fun { level ; cycle ; cycle_position ; + voting_period; voting_period_position } -> + (level, cycle, cycle_position, + voting_period, voting_period_position)) + (fun (level, cycle, cycle_position, + voting_period, voting_period_position) -> + { level ; cycle ; cycle_position ; + voting_period ; voting_period_position }) + (obj5 + (req "level" Raw_level_repr.encoding) + (req "cycle" Cycle_repr.encoding) + (req "cycle_position" int32) + (req "voting_period" Voting_period_repr.encoding) + (req "voting_period_position" int32)) + +let root = + { level = Raw_level_repr.root ; + cycle = Cycle_repr.root ; + cycle_position = 0l ; + voting_period = Voting_period_repr.root ; + voting_period_position = 0l ; + } + +let from_raw ~cycle_length ~voting_period_length level = + let raw_level = Raw_level_repr.to_int32 level in + let cycle = Cycle_repr.of_int32_exn (Int32.div raw_level cycle_length) in + let cycle_position = Int32.rem raw_level cycle_length in + let voting_period = + Voting_period_repr.of_int32_exn + (Int32.div raw_level voting_period_length) in + let voting_period_position = + Int32.rem raw_level voting_period_length in + { level ; cycle ; cycle_position ; + voting_period ; voting_period_position } + +let diff { level = l1 } { level = l2 } = + Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2) + +let compare { level = l1 } { level = l2 } = Raw_level_repr.compare l1 l2 +let (=) { level = l1 } { level = l2 } = Raw_level_repr.(=) l1 l2 +let (<>) { level = l1 } { level = l2 } = Raw_level_repr.(<>) l1 l2 +let (>) { level = l1 } { level = l2 } = Raw_level_repr.(>) l1 l2 +let (>=) { level = l1 } { level = l2 } = Raw_level_repr.(>=) l1 l2 +let (<=) { level = l1 } { level = l2 } = Raw_level_repr.(<=) l1 l2 +let (<) { level = l1 } { level = l2 } = Raw_level_repr.(<) l1 l2 +let min l1 l2 = if l1 <= l2 then l1 else l2 +let max l1 l2 = if l1 >= l2 then l1 else l2 diff --git a/src/proto/bootstrap/level_repr.mli b/src/proto/bootstrap/level_repr.mli new file mode 100644 index 000000000..842f60373 --- /dev/null +++ b/src/proto/bootstrap/level_repr.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = private { + level: Raw_level_repr.t ; + cycle: Cycle_repr.t ; + cycle_position: int32 ; + voting_period: Voting_period_repr.t ; + voting_period_position: int32 ; +} + +type level = t +val encoding: level Data_encoding.t +val pp: Format.formatter -> level -> unit +include Compare.S with type t := level + +val root: level + +val from_raw: + cycle_length:int32 -> voting_period_length:int32 -> + Raw_level_repr.t -> level + +val diff: level -> level -> int32 diff --git a/src/proto/bootstrap/level_storage.ml b/src/proto/bootstrap/level_storage.ml new file mode 100644 index 000000000..923ed3a86 --- /dev/null +++ b/src/proto/bootstrap/level_storage.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Level_repr + +let from_raw c ?offset l = + let l = + match offset with + | None -> l + | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in + let constants = Storage.constants c in + Level_repr.from_raw + ~cycle_length:constants.Constants_repr.cycle_length + ~voting_period_length:constants.Constants_repr.voting_period_length + l + +let succ c l = from_raw c (Raw_level_repr.succ l.level) +let pred c l = + match Raw_level_repr.pred l.Level_repr.level with + | None -> None + | Some l -> Some (from_raw c l) + +let current ctxt = + Storage.Current_level.get ctxt >>=? fun l -> + return (from_raw ctxt l) + +let previous ctxt = + current ctxt >>=? fun l -> + match pred ctxt l with + | None -> assert false (* Context inited with level = 1. *) + | Some p -> return p + +let increment_current ctxt = + Storage.Current_level.get ctxt >>=? fun l -> + Storage.Current_level.set ctxt (Raw_level_repr.succ l) + + +let first_level_in_cycle ctxt c = + let constants = Storage.constants ctxt in + from_raw ctxt + (Raw_level_repr.of_int32_exn + (Int32.mul constants.Constants_repr.cycle_length (Cycle_repr.to_int32 c))) + +let last_level_in_cycle ctxt c = + match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with + | None -> assert false + | Some x -> x + +let levels_in_cycle ctxt c = + let first = first_level_in_cycle ctxt c in + let rec loop n acc = + if Cycle_repr.(n.cycle = first.cycle) + then loop (succ ctxt n) (n :: acc) + else acc + in + loop first [] + +let init ctxt = + Storage.Current_level.init ctxt Raw_level_repr.(succ root) + + diff --git a/src/proto/bootstrap/level_storage.mli b/src/proto/bootstrap/level_storage.mli new file mode 100644 index 000000000..117d348a8 --- /dev/null +++ b/src/proto/bootstrap/level_storage.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val init: Storage.t -> Storage.t tzresult Lwt.t + +val increment_current: Storage.t -> Storage.t tzresult Lwt.t +val current: Storage.t -> Level_repr.t tzresult Lwt.t +val previous: Storage.t -> Level_repr.t tzresult Lwt.t + +val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t +val pred: Storage.t -> Level_repr.t -> Level_repr.t option +val succ: Storage.t -> Level_repr.t -> Level_repr.t + +val last_level_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t +val levels_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t list diff --git a/src/proto/bootstrap/main.ml b/src/proto/bootstrap/main.ml new file mode 100644 index 000000000..b002a7ac6 --- /dev/null +++ b/src/proto/bootstrap/main.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Protocol Signature Instance *) + +type operation = Tezos_context.operation + +let parse_operation = Tezos_context.Operation.parse + +let max_operation_data_length = + Tezos_context.Operation.max_operation_data_length + +type block_header = + Tezos_context.Block.header + +let parse_block_header = + Tezos_context.Block.parse_header + +let max_number_of_operations = + Tezos_context.Constants.max_number_of_operations + +let max_block_header_length = + Tezos_context.Block.max_header_length + +let rpc_services = Services_registration.rpc_services + +let fitness ctxt = + begin + Tezos_context.init ctxt >>=? fun ctxt -> + Tezos_context.Fitness.get ctxt + end >|= function + | Ok fitness -> fitness + | Error _ -> [] + +let apply ctxt header ops = Apply.apply ctxt true header ops + +let preapply = Apply.preapply + +let configure_sandbox = Tezos_context.configure_sandbox diff --git a/src/proto/bootstrap/main.mli b/src/proto/bootstrap/main.mli new file mode 100644 index 000000000..987aea5f9 --- /dev/null +++ b/src/proto/bootstrap/main.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Protocol Signature Instance *) + +include Updater.PROTOCOL with type error := error + and type 'a tzresult := 'a tzresult diff --git a/src/proto/bootstrap/mining.ml b/src/proto/bootstrap/mining.ml new file mode 100644 index 000000000..c6d765237 --- /dev/null +++ b/src/proto/bootstrap/mining.ml @@ -0,0 +1,200 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Misc +open Tezos_context + +type error += + | Too_early of Timestamp.t * Timestamp.t + | Invalid_level of Raw_level.t * Raw_level.t + | Cannot_pay_mining_bond + | Cannot_pay_endorsement_bond + | Bad_slot + | Bad_delegate + +let minimal_time c priority = + Timestamp.get_current c >>=? fun prev_timestamp -> + Lwt.return + (Period.mult (Int32.succ priority) + (Constants.time_between_slots c)) >>=? fun period -> + Lwt.return Timestamp.(prev_timestamp +? period) + +let check_timestamp c priority timestamp = + minimal_time c priority >>=? fun minimal_time -> + fail_unless Timestamp.(minimal_time <= timestamp) + (Too_early (minimal_time, timestamp)) + +let check_mining_rights c + { Block.shell = { timestamp } ; + proto = { mining_slot = (raw_level, priority) } } = + Level.current c >>=? fun current_level -> + fail_unless + Raw_level.(raw_level = current_level.level) + (Invalid_level (current_level.Level.level, raw_level)) >>=? fun () -> + let level = Level.from_raw c raw_level in + Roll.mining_rights_owner c level ~priority >>=? fun delegate -> + check_timestamp c priority timestamp >>=? fun () -> + return delegate + +let pay_mining_bond c + { Block.proto = { mining_slot = (_raw_level, priority) } } + id = + if Compare.Int32.(priority >= Constants.first_free_mining_slot c) + then return c + else + Contract.unconditional_spend c + (Contract.default_contract id) Constants.mining_bond_cost + |> trace Cannot_pay_mining_bond + +let pay_endorsement_bond c id = + let bond = Constants.endorsement_bond_cost in + Contract.unconditional_spend c (Contract.default_contract id) bond + |> trace Cannot_pay_endorsement_bond >>=? fun c -> + return (c, bond) + +let check_signing_rights c slot delegate = + fail_unless Compare.Int.(slot <= Constants.max_signing_slot c) + Bad_slot >>=? fun () -> + Level.current c >>=? fun level -> + Roll.endorsement_rights_owner c level ~slot >>=? fun owning_delegate -> + fail_unless (Ed25519.Public_key_hash.equal owning_delegate delegate) + Bad_delegate + +let paying_priorities c = + 0l ---> Constants.first_free_mining_slot c + +let bond_and_reward = + match Tez.(Constants.mining_bond_cost +? Constants.mining_reward) with + | Ok v -> v + | Error _ -> assert false + +let base_mining_reward c ~priority = + if Compare.Int32.(priority < Constants.first_free_mining_slot c) + then bond_and_reward + else Constants.mining_reward + +type error += Incorect_priority + +let endorsement_reward ~block_priority:prio = + if Compare.Int32.(prio >= 0l) + then + return + Tez.(Constants.endorsement_reward / (Int64.(succ (of_int32 prio)))) + else fail Incorect_priority + +let mining_priorities c level = + let rec f priority = + Roll.mining_rights_owner c level ~priority >>=? fun delegate -> + return (LCons (delegate, (fun () -> f (Int32.succ priority)))) + in + f 0l + +let endorsement_priorities c level = + let rec f slot = + Roll.endorsement_rights_owner c level ~slot >>=? fun delegate -> + return (LCons (delegate, (fun () -> f (succ slot)))) + in + f 0 + +let select_delegate delegate delegate_list max_priority = + let rec loop acc l n = + if Compare.Int32.(n >= max_priority) + then return (List.rev acc) + else + let LCons (pkh, t) = l in + let acc = + if Ed25519.Public_key_hash.equal delegate pkh + then n :: acc + else acc in + t () >>=? fun t -> + loop acc t (Int32.succ n) + in + loop [] delegate_list 0l + +let first_mining_priorities + ctxt + ?(max_priority = Constants.first_free_mining_slot ctxt) + delegate level = + mining_priorities ctxt level >>=? fun delegate_list -> + select_delegate delegate delegate_list max_priority + +let first_endorsement_slots + ctxt + ?(max_priority = + Int32.of_int (Constants.max_signing_slot ctxt)) + delegate level = + endorsement_priorities ctxt level >>=? fun delegate_list -> + select_delegate delegate delegate_list max_priority + + +let check_hash hash stamp_threshold = + let bytes = Block_hash.to_bytes hash in + let len = MBytes.length bytes * 8 in + try + for i = len - 1 downto (len - stamp_threshold) do + if MBytes.get_bool bytes i then raise Exit + done; + true + with Exit -> false + +let check_header_hash {Block.shell;proto;signature} stamp_threshold = + let hash = + Block_hash.hash_bytes [ + Data_encoding.Binary.to_bytes + (Data_encoding.tup2 + Block.unsigned_header_encoding Ed25519.signature_encoding) + ((shell, proto), signature)] in + check_hash hash stamp_threshold + +type error += + | Invalid_signature + | Invalid_stamp + +let check_proof_of_work_stamp ctxt block_header = + let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in + if check_header_hash block_header proof_of_work_threshold then + return () + else + fail Invalid_stamp + +let check_signature ctxt block_header id = + Public_key.get ctxt id >>=? fun key -> + let check_signature key { Block.proto ; shell ; signature } = + let unsigned_header = Block.forge_header shell proto in + Ed25519.check_signature key signature unsigned_header in + if check_signature key block_header then + return () + else + fail Invalid_signature + +let max_fitness_gap ctxt = + let slots = Int64.of_int (Constants.max_signing_slot ctxt + 1) in + Int64.add slots 1L + +type error += Invalid_fitness_gap + +let check_fitness_gap ctxt (block_header : Block.header) = + Fitness.raw_get ctxt >>=? fun current_fitness -> + Fitness.raw_read block_header.shell.fitness >>=? fun announced_fitness -> + let gap = Int64.sub announced_fitness current_fitness in + if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then + fail Invalid_fitness_gap + else + return () + +let first_of_a_cycle l = + Compare.Int32.(l.Level.cycle_position = 0l) + +let dawn_of_a_new_cycle ctxt = + Level.current ctxt >>=? fun level -> + if first_of_a_cycle level then + return (Some level.cycle) + else + return None + diff --git a/src/proto/bootstrap/mining.mli b/src/proto/bootstrap/mining.mli new file mode 100644 index 000000000..0e56dbebd --- /dev/null +++ b/src/proto/bootstrap/mining.mli @@ -0,0 +1,82 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +open Tezos_context +open Misc + +val paying_priorities: context -> int32 list + +val minimal_time: + context -> int32 -> Time.t tzresult Lwt.t + +val pay_mining_bond: + context -> + Block.header -> + public_key_hash -> + context tzresult Lwt.t + +val pay_endorsement_bond: + context -> public_key_hash -> (context * Tez.t) tzresult Lwt.t + +(** [check_mining_rights] verifies that: + * the contract that owned the roll at cycle start has the block signer as delegate. + * the timestamp is coherent with the announced slot. + * the bond have been payed if the slot is below [Constants.first_free_mining_slot]. +*) +val check_mining_rights: + context -> Block.header -> public_key_hash tzresult Lwt.t + +(** [check_signing_rights c slot contract] verifies that: + * the slot is valid; + * [contract] owned, at cycle start, the roll that has the right to sign + for the slot and the current level. +*) +val check_signing_rights: + context -> int -> public_key_hash -> unit tzresult Lwt.t + +(** If this priority should have payed the bond it is the base mining + reward and the bond, or just the base reward otherwise *) +val base_mining_reward: context -> priority:int32 -> Tez.t + +val endorsement_reward: block_priority:int32 -> Tez.t tzresult Lwt.t + + +(** The contract owning rolls for the first mining priorities of a level. *) +val mining_priorities: + context -> Level.t -> public_key_hash lazy_list +val endorsement_priorities: + context -> Level.t -> public_key_hash lazy_list + +val first_mining_priorities: + context -> + ?max_priority:int32 -> + public_key_hash -> + Level.t -> + int32 list tzresult Lwt.t + +val first_endorsement_slots: + context -> + ?max_priority:int32 -> + public_key_hash -> + Level.t -> int32 list tzresult Lwt.t + +val check_signature: + context -> Block.header -> public_key_hash -> unit tzresult Lwt.t + +val check_hash: Block_hash.t -> int -> bool +val check_proof_of_work_stamp: + context -> Block.header -> unit tzresult Lwt.t + +type error += Invalid_fitness_gap + +val check_fitness_gap: + context -> Block.header -> unit tzresult Lwt.t + +val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t diff --git a/src/proto/bootstrap/misc.ml b/src/proto/bootstrap/misc.ml new file mode 100644 index 000000000..daf65577f --- /dev/null +++ b/src/proto/bootstrap/misc.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type 'a lazyt = unit -> 'a +type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +let rec (-->) i j = (* [i; i+1; ...; j-1] *) + if Compare.Int.(i >= j) + then [] + else i :: (succ i --> j) + +let rec (--->) i j = (* [i; i+1; ...; j-1] *) + if Compare.Int32.(i >= j) + then [] + else i :: (Int32.succ i ---> j) + +let split delim ?(limit = max_int) path = + let l = String.length path in + let rec do_slashes acc limit i = + if Compare.Int.(i >= l) then + List.rev acc + else if Compare.Char.(String.get path i = delim) then + do_slashes acc limit (i + 1) + else + do_split acc limit i + and do_split acc limit i = + if Compare.Int.(limit <= 0) then + if Compare.Int.(i = l) then + List.rev acc + else + List.rev (String.sub path i (l - i) :: acc) + else + do_component acc (pred limit) i i + and do_component acc limit i j = + if Compare.Int.(j >= l) then + if Compare.Int.(i = j) then + List.rev acc + else + List.rev (String.sub path i (j - i) :: acc) + else if Compare.Char.(String.get path j = delim) then + do_slashes (String.sub path i (j - i) :: acc) limit j + else + do_component acc limit i (j + 1) in + if Compare.Int.(limit > 0) then + do_slashes [] limit 0 + else + [ path ] + +let pp_print_paragraph ppf description = + Format.fprintf ppf "@[%a@]" + Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) + (split ' ' description) + +let take n l = + let rec loop acc n = function + | xs when Compare.Int.(n <= 0) -> Some (List.rev acc, xs) + | [] -> None + | x :: xs -> loop (x :: acc) (n-1) xs in + loop [] n l diff --git a/src/proto/bootstrap/misc.mli b/src/proto/bootstrap/misc.mli new file mode 100644 index 000000000..0ffcf1dfe --- /dev/null +++ b/src/proto/bootstrap/misc.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** {2 Stuff} ****************************************************************) + +type 'a lazyt = unit -> 'a +type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +(** Include lower bound, exclude upper bound *) +val (-->) : int -> int -> int list +val (--->) : Int32.t -> Int32.t -> Int32.t list + +val pp_print_paragraph : Format.formatter -> string -> unit + +val take: int -> 'a list -> ('a list * 'a list) option diff --git a/src/proto/bootstrap/nonce_storage.ml b/src/proto/bootstrap/nonce_storage.ml new file mode 100644 index 000000000..df2b2d3ba --- /dev/null +++ b/src/proto/bootstrap/nonce_storage.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = Seed_repr.nonce +type nonce = t +let encoding = Seed_repr.nonce_encoding + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +let get_unrevealed c level = + Level_storage.current c >>=? fun cur_level -> + let min_cycle = + match Cycle_repr.pred cur_level.cycle with + | None -> Cycle_repr.root + | Some min_cycle -> min_cycle in + fail_unless + Cycle_repr.(min_cycle <= level.Level_repr.cycle) + Too_late_revelation >>=? fun () -> + fail_unless + Raw_level_repr.(level.level < cur_level.level) + Too_early_revelation >>=? fun () -> + Storage.Seed.Nonce.get c level >>=? function + | Revealed _ -> + fail Previously_revealed_nonce + | Unrevealed { nonce_hash; delegate_to_reward ; reward_amount } -> + return (nonce_hash, delegate_to_reward, reward_amount) + +(* let get_unrevealed_hash c level = *) + (* get_unrevealed c level >>=? fun (nonce_hash, _) -> *) + (* return nonce_hash *) + +let record_hash c delegate_to_reward reward_amount nonce_hash = + Level_storage.current c >>=? fun level -> + Storage.Seed.Nonce.init c level + (Unrevealed { nonce_hash; delegate_to_reward ; reward_amount }) + +let reveal c level nonce = + get_unrevealed c level >>=? fun (nonce_hash, delegate_to_reward, reward_amount) -> + fail_unless + (Seed_repr.check_hash nonce nonce_hash) + Unexpected_nonce >>=? fun () -> + Storage.Seed.Nonce.set c level (Revealed nonce) >>=? fun c -> + return (c, delegate_to_reward, reward_amount) + +type status = Storage.Seed.nonce_status = + | Unrevealed of { + nonce_hash: Tezos_hash.Nonce_hash.t ; + delegate_to_reward: Ed25519.public_key_hash ; + reward_amount: Tez_repr.t ; + } + | Revealed of nonce + +let get c level = Storage.Seed.Nonce.get c level + +let of_bytes = Seed_repr.make_nonce +let hash = Seed_repr.hash +let check_hash = Seed_repr.check_hash diff --git a/src/proto/bootstrap/nonce_storage.mli b/src/proto/bootstrap/nonce_storage.mli new file mode 100644 index 000000000..1f996ad54 --- /dev/null +++ b/src/proto/bootstrap/nonce_storage.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +type t = Seed_repr.nonce +type nonce = t +val encoding: nonce Data_encoding.t + +val record_hash: + Storage.t -> + Ed25519.public_key_hash -> Tez_repr.t -> + Nonce_hash.t -> Storage.t tzresult Lwt.t + +val reveal: + Storage.t -> Level_repr.t -> nonce -> + (Storage.t * Ed25519.public_key_hash * Tez_repr.t) tzresult Lwt.t + +type status = + | Unrevealed of { + nonce_hash: Tezos_hash.Nonce_hash.t ; + delegate_to_reward: Ed25519.public_key_hash ; + reward_amount: Tez_repr.t ; + } + | Revealed of nonce + +val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t + +val of_bytes: MBytes.t -> nonce tzresult +val hash: nonce -> Nonce_hash.t +val check_hash: nonce -> Nonce_hash.t -> bool diff --git a/src/proto/bootstrap/operation_repr.ml b/src/proto/bootstrap/operation_repr.ml new file mode 100644 index 000000000..78241df9b --- /dev/null +++ b/src/proto/bootstrap/operation_repr.ml @@ -0,0 +1,330 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +type operation = { + hash: Operation_hash.t ; + shell: Updater.shell_operation ; + contents: proto_operation ; + signature: Ed25519.signature option ; +} + +and proto_operation = + | Anonymous_operations of anonymous_operation list + | Sourced_operations of sourced_operations + +and anonymous_operation = + | Seed_nonce_revelation of { + level: Raw_level_repr.t ; + nonce: Seed_repr.nonce ; + } + +and sourced_operations = + | Manager_operations of { + source: Contract_repr.contract ; + public_key: Ed25519.public_key option ; + fee: Tez_repr.tez ; + counter: counter ; + operations: manager_operation list ; + } + | Delegate_operations of { + source: Ed25519.public_key ; + operations: delegate_operation list ; + } + +and manager_operation = + | Transaction of { + amount: Tez_repr.tez ; + parameters: Script_repr.expr option ; + destination: Contract_repr.contract ; + } + | Origination of { + manager: Ed25519.public_key_hash ; + delegate: Ed25519.public_key_hash option ; + script: Script_repr.t ; + spendable: bool ; + delegatable: bool ; + credit: Tez_repr.tez ; + } + | Issuance of { + asset: Asset_repr.asset * Ed25519.public_key_hash ; + amount: Tez_repr.tez ; + } + | Delegation of Ed25519.public_key_hash option + +and delegate_operation = + | Endorsement of { + block: Block_hash.t ; + slot: int ; + } + | Proposals of { + period: Voting_period_repr.t ; + proposals: Protocol_hash.t list ; + } + | Ballot of { + period: Voting_period_repr.t ; + proposal: Protocol_hash.t ; + ballot: Vote_repr.ballot ; + } + +and counter = Int32.t + +module Encoding = struct + + open Data_encoding + + let transaction_encoding = + (obj4 + (req "kind" (constant "transaction")) + (req "amount" Tez_repr.encoding) + (req "destination" Contract_repr.encoding) + (opt "parameters" Script_repr.expr_encoding)) + + let transaction_case tag = + case ~tag transaction_encoding + (function + | Transaction { amount ; destination ; parameters } -> + Some ((), amount, destination, parameters) + | _ -> None) + (fun ((), amount, destination, parameters) -> + Transaction { amount ; destination ; parameters }) + + let origination_encoding = + (obj7 + (req "kind" (constant "origination")) + (req "managerPubkey" Ed25519.public_key_hash_encoding) + (req "balance" Tez_repr.encoding) + (opt "spendable" bool) + (opt "delegatable" bool) + (opt "delegate" Ed25519.public_key_hash_encoding) + (req "script" Script_repr.encoding)) + + let origination_case tag = + case ~tag origination_encoding + (function + | Origination { manager ; credit ; spendable ; + delegatable ; delegate ; script } -> + Some ((), manager, credit, Some spendable, + Some delegatable, delegate, script) + | _ -> None) + (fun ((), manager, credit, spendable, delegatable, delegate, script) -> + let delegatable = + match delegatable with None -> true | Some b -> b in + let spendable = + match spendable with None -> true | Some b -> b in + Origination + {manager ; credit ; spendable ; delegatable ; delegate ; script }) + + let issuance_encoding = + (obj3 + (req "kind" (constant "issuance")) + (req "asset" (tup2 Asset_repr.encoding Ed25519.public_key_hash_encoding)) + (req "quantity" Tez_repr.encoding)) + + let issuance_case tag = + case ~tag issuance_encoding + (function + | Issuance { asset ; amount } -> Some ((), asset, amount) + | _ -> None) + (fun ((), asset, amount) -> Issuance { asset ; amount }) + + let delegation_encoding = + (obj2 + (req "kind" (constant "delegation")) + (opt "delegate" Ed25519.public_key_hash_encoding)) + + let delegation_case tag = + case ~tag delegation_encoding + (function Delegation key -> Some ((), key) | _ -> None) + (fun ((), key) -> Delegation key) + + let manager_kind_encoding = + (obj5 + (req "source" Contract_repr.encoding) + (opt "public_key" Ed25519.public_key_encoding) + (req "fee" Tez_repr.encoding) + (req "counter" int32) + (req "operations" + (list (union ~tag_size:`Int8 [ + transaction_case 0 ; + origination_case 1 ; + issuance_case 2 ; + delegation_case 3 ; + ])))) + + let manager_kind_case tag = + case ~tag manager_kind_encoding + (function + | Manager_operations { source; public_key ; fee ; counter ;operations } -> + Some (source, public_key, fee, counter, operations) + | _ -> None) + (fun (source, public_key, fee, counter, operations) -> + Manager_operations { source; public_key ; fee ; counter ; operations }) + + let endorsement_encoding = + (obj3 + (req "kind" (constant "endorsement")) + (req "block" Block_hash.encoding) + (req "slot" int31)) + + let endorsement_case tag = + case ~tag endorsement_encoding + (function + | Endorsement { block ; slot } -> + Some ((), block, slot) + | _ -> None) + (fun ((), block, slot) -> + Endorsement { block ; slot }) + + let proposal_encoding = + (obj3 + (req "kind" (constant "proposal")) + (req "period" Voting_period_repr.encoding) + (req "proposals" (list Protocol_hash.encoding))) + + let proposal_case tag = + case ~tag proposal_encoding + (function + | Proposals { period ; proposals } -> + Some ((), period, proposals) + | _ -> None) + (fun ((), period, proposals) -> + Proposals { period ; proposals }) + + let ballot_encoding = + (obj4 + (req "kind" (constant "ballot")) + (req "period" Voting_period_repr.encoding) + (req "proposal" Protocol_hash.encoding) + (req "ballot" Vote_repr.ballot_encoding)) + + let ballot_case tag = + case ~tag ballot_encoding + (function + | Ballot { period ; proposal ; ballot } -> + Some ((), period, proposal, ballot) + | _ -> None) + (fun ((), period, proposal, ballot) -> + Ballot { period ; proposal ; ballot }) + + let delegate_kind_encoding = + (obj2 + (req "source" Ed25519.public_key_encoding) + (req "operations" + (list (union [ + endorsement_case 0 ; + proposal_case 1 ; + ballot_case 2 ; + ])))) + + let delegate_kind_case tag = + case ~tag delegate_kind_encoding + (function + | Delegate_operations { source ; operations } -> + Some (source, operations) + | _ -> None) + (fun (source, operations) -> Delegate_operations { source ; operations }) + + let signed_operations_case tag = + case ~tag + (union [ + manager_kind_case 0 ; + delegate_kind_case 1 ; + ]) + (function Sourced_operations ops -> Some ops | _ -> None) + (fun ops -> Sourced_operations ops) + + let seed_nonce_revelation_encoding = + (obj3 + (req "kind" (constant "seed_nonce_revelation")) + (req "level" Raw_level_repr.encoding) + (req "nonce" Seed_repr.nonce_encoding)) + + let seed_nonce_revelation_case tag = + case ~tag seed_nonce_revelation_encoding + (function + | Seed_nonce_revelation { level ; nonce } -> Some ((), level, nonce) + (* | _ -> None *) + ) + (fun ((), level, nonce) -> Seed_nonce_revelation { level ; nonce }) + + let unsigned_operation_case tag = + case ~tag + (obj1 + (req "operations" + (list + (union [ + seed_nonce_revelation_case 0 ; + ])))) + (function Anonymous_operations ops -> Some ops | _ -> None) + (fun ops -> Anonymous_operations ops) + + let proto_operation_encoding = + union [ + signed_operations_case 0 ; + unsigned_operation_case 1 ; + ] + + let unsigned_operation_encoding = + merge_objs + Updater.shell_operation_encoding + proto_operation_encoding + + let signed_proto_operation_encoding = + merge_objs + proto_operation_encoding + (obj1 (varopt "signature" Ed25519.signature_encoding)) + +end + +type error += Cannot_parse_operation + +let parse hash (op: Updater.raw_operation) = + if not (Compare.Int.(MBytes.length op.proto <= Constants_repr.max_operation_data_length)) then + error Cannot_parse_operation + else + match Data_encoding.Binary.of_bytes + Encoding.signed_proto_operation_encoding + op.proto with + | Some (contents, signature) -> + let shell = { Updater.net_id = op.shell.net_id } in + ok { hash ; shell ; contents ; signature } + | None -> error Cannot_parse_operation + +type error += + | Invalid_signature + | Missing_signature + +let forge shell proto = + Data_encoding.Binary.to_bytes + Encoding.unsigned_operation_encoding (shell, proto) + +let check_signature key { shell ; contents ; signature } = + match contents, signature with + | Anonymous_operations _, _ -> return () + | Sourced_operations _, None -> + fail Missing_signature + | Sourced_operations _, Some signature -> + let unsigned_operation = forge shell contents in + if Ed25519.check_signature key signature unsigned_operation then + return () + else + fail Invalid_signature + +let parse_proto bytes = + match Data_encoding.Binary.of_bytes + Encoding.signed_proto_operation_encoding + bytes with + | Some (proto, signature) -> return (proto, signature) + | None -> fail Cannot_parse_operation + +include Encoding + +let max_operation_data_length = Constants_repr.max_operation_data_length diff --git a/src/proto/bootstrap/operation_repr.mli b/src/proto/bootstrap/operation_repr.mli new file mode 100644 index 000000000..7d6abc0a7 --- /dev/null +++ b/src/proto/bootstrap/operation_repr.mli @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +type operation = { + hash: Operation_hash.t ; + shell: Updater.shell_operation ; + contents: proto_operation ; + signature: Ed25519.signature option ; +} + +and proto_operation = + | Anonymous_operations of anonymous_operation list + | Sourced_operations of sourced_operations + +and anonymous_operation = + | Seed_nonce_revelation of { + level: Raw_level_repr.t ; + nonce: Seed_repr.nonce ; + } + +and sourced_operations = + | Manager_operations of { + source: Contract_repr.contract ; + public_key: Ed25519.public_key option ; + fee: Tez_repr.tez ; + counter: counter ; + operations: manager_operation list ; + } + | Delegate_operations of { + source: Ed25519.public_key ; + operations: delegate_operation list ; + } + +and manager_operation = + | Transaction of { + amount: Tez_repr.tez ; + parameters: Script_repr.expr option ; + destination: Contract_repr.contract ; + } + | Origination of { + manager: Ed25519.public_key_hash ; + delegate: Ed25519.public_key_hash option ; + script: Script_repr.t ; + spendable: bool ; + delegatable: bool ; + credit: Tez_repr.tez ; + } + | Issuance of { + asset: Asset_repr.t * Ed25519.public_key_hash ; + amount: Tez_repr.tez ; + } + | Delegation of Ed25519.public_key_hash option + +and delegate_operation = + | Endorsement of { + block: Block_hash.t ; + slot: int ; + } + | Proposals of { + period: Voting_period_repr.t ; + proposals: Protocol_hash.t list ; + } + | Ballot of { + period: Voting_period_repr.t ; + proposal: Protocol_hash.t ; + ballot: Vote_repr.ballot ; + } + +and counter = Int32.t + +type error += Cannot_parse_operation + +val parse: + Operation_hash.t -> Updater.raw_operation -> operation tzresult + +val parse_proto: + MBytes.t -> + (proto_operation * Ed25519.signature option) tzresult Lwt.t + +type error += Invalid_signature +val check_signature: + Ed25519.public_key -> operation -> unit tzresult Lwt.t + +val forge: Updater.shell_operation -> proto_operation -> MBytes.t + +val proto_operation_encoding: + proto_operation Data_encoding.t + +val unsigned_operation_encoding: + (Updater.shell_operation * proto_operation) Data_encoding.t + +val max_operation_data_length: int diff --git a/src/proto/bootstrap/period_repr.ml b/src/proto/bootstrap/period_repr.ml new file mode 100644 index 000000000..3f03a54a9 --- /dev/null +++ b/src/proto/bootstrap/period_repr.ml @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = Int64.t +type period = t +include (Compare.Int64 : Compare.S with type t := t) +let encoding = Data_encoding.int64 + +let pp ppf v = Format.fprintf ppf "%Ld" v + +type error += + | Malformed_period + | Invalid_arg + +let of_seconds t = + if Compare.Int64.(t >= 0L) + then ok t + else error Malformed_period +let to_seconds t = t +let of_seconds_exn t = + match of_seconds t with + | Ok t -> t + | _ -> invalid_arg "Period.of_seconds_exn" + +let mult i p = + (* TODO check overflow *) + if Compare.Int32.(i < 0l) + then error Invalid_arg + else ok (Int64.mul (Int64.of_int32 i) p) + diff --git a/src/proto/bootstrap/period_repr.mli b/src/proto/bootstrap/period_repr.mli new file mode 100644 index 000000000..4aac33f4c --- /dev/null +++ b/src/proto/bootstrap/period_repr.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type period = t +include Compare.S with type t := t +val encoding : period Data_encoding.t +val pp: Format.formatter -> period -> unit + + +val to_seconds : period -> int64 + +(** [of_second period] fails if period is not positive *) +val of_seconds : int64 -> period tzresult + +(** [of_second period] fails if period is not positive. + It should only be used at toplevel for constants. *) +val of_seconds_exn : int64 -> period + +val mult : int32 -> period -> period tzresult diff --git a/src/proto/bootstrap/qty_repr.ml b/src/proto/bootstrap/qty_repr.ml new file mode 100644 index 000000000..032501a31 --- /dev/null +++ b/src/proto/bootstrap/qty_repr.ml @@ -0,0 +1,177 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type QTY = + sig + val id:string + end + +module type S = + sig + type qty + val id : string + val zero : qty + val ( - ) : qty -> qty -> qty option + val ( -? ) : qty -> qty -> qty tzresult + val ( +? ) : qty -> qty -> qty tzresult + val ( *? ) : qty -> int64 -> qty tzresult + val ( / ) : qty -> int64 -> qty + val to_cents : qty -> int64 + + (** [of_cents n] is None if n is negative *) + val of_cents : int64 -> qty option + + (** [of_cents_exn n] fails if n is negative. + It should only be used at toplevel for constants. *) + val of_cents_exn : int64 -> qty + + (** It should only be used at toplevel for constants. *) + val add_exn : qty -> qty -> qty + + val encoding : qty Data_encoding.t + + val to_int64 : qty -> int64 + + include Compare.S with type t := qty + + val pp: Format.formatter -> qty -> unit + + val of_string: string -> qty option + val to_string: qty -> string + + end + +type error += + | Qty_overflow + | Negative_qty + | Negative_qty_multiplicator + +module Make (T: QTY) : S = struct + + type qty = int64 (* invariant: positive *) + + include Compare.Int64 + let zero = 0L + let id = T.id + + let of_cents t = + if t < 0L + then None + else Some t + + let of_string s = + let len = String.length s in + let rec dec i len acc = + if Compare.Int.(i = len) then acc + else + dec (succ i) len + (Int64.add (Int64.mul 10L acc) + (match String.get s i with + | '0' -> 0L | '1' -> 1L | '2' -> 2L | '3' -> 3L | '4' -> 4L + | '5' -> 5L | '6' -> 6L | '7' -> 7L | '8' -> 8L | '9' -> 9L + | _ -> raise Exit)) in + let rec loop acc m len = + if Compare.Int.(len >= 4) && Compare.Char.(String.get s (len - 4) = ',') then + let acc = Int64.add acc Int64.(mul (dec (len - 3) len 0L) m) in + loop acc Int64.(mul 1000L m) (len - 4) + else + Int64.add acc Int64.(mul (dec 0 len 0L) m) in + let cents, len = + if Compare.Int.(len >= 3) && Compare.Char.(String.get s (len - 3) = '.') then + dec (len - 2) len 0L, len - 3 + else + 0L, len in + let res = + if Compare.Int.(len >= 4) && Compare.Char.(String.get s (len - 4) = ',') then + loop cents 100L len + else if Compare.Int.(len = 0) && Compare.Int.(String.length s = 3) then + cents + else + try + Int64.(add (mul 100L (of_string (String.sub s 0 len))) cents) + with _ -> raise Exit in + match of_cents res with + | None -> raise Exit + | Some tez -> tez + + let of_string s = + try Some (of_string s) with Exit -> None + + let pp ppf amount = + let rec loop ppf amount= + let d, r = Int64.div amount 1000L, Int64.rem amount 1000L in + if d > 0L then + Format.fprintf ppf "%a,%03Ld" loop d r + else + Format.fprintf ppf "%Ld" r in + let i, c = Int64.div amount 100L, Int64.rem amount 100L in + Format.fprintf ppf "%a.%02Ld" loop i c + + let to_string t = + Format.asprintf "%a" pp t + + let (-) t1 t2 = + if t2 <= t1 + then Some (Int64.sub t1 t2) + else None + + let (-?) t1 t2 = + match t1 - t2 with + | None -> error Negative_qty + | Some v -> ok v + + let (+?) t1 t2 = + let t = Int64.add t1 t2 in + if t < t1 + then error Qty_overflow + else ok t + + let ( *? ) t m = + let open Compare.Int64 in + let open Int64 in + let rec step cur pow acc = + if cur = 0L then + ok acc + else + pow +? pow >>? fun npow -> + if logand cur 1L = 1L then + acc +? pow >>? fun nacc -> + step (shift_right_logical cur 1) npow nacc + else + step (shift_right_logical cur 1) npow acc + in + if m < 0L then + error Negative_qty_multiplicator + else + step m t 0L + + let (/) t1 t2 = Int64.div t1 t2 + + let add_exn t1 t2 = + let t = Int64.add t1 t2 in + if t <= 0L + then invalid_arg "add_exn" + else t + + let to_cents t = t + + let of_cents_exn x = + match of_cents x with + | None -> invalid_arg "Qty.of_cents" + | Some v -> v + + let to_int64 t = t + + let encoding = + let open Data_encoding in + describe + ~title: "Amount in centiles" + (conv to_int64 (Json.wrap_error of_cents_exn) int64) + +end diff --git a/src/proto/bootstrap/raw_level_repr.ml b/src/proto/bootstrap/raw_level_repr.ml new file mode 100644 index 000000000..442f6be35 --- /dev/null +++ b/src/proto/bootstrap/raw_level_repr.ml @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = int32 +type raw_level = t +include (Compare.Int32 : Compare.S with type t := t) +let encoding = Data_encoding.int32 +let pp ppf level = Format.fprintf ppf "%ld" level +let arg = + let construct raw_level = Int32.to_string raw_level in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse level" + | raw_level -> Ok raw_level in + RPC.Arg.make + ~descr:"A level integer" + ~name: "block_level" + ~construct + ~destruct + +let root = 0l +let succ = Int32.succ +let pred l = + if l = 0l + then None + else Some (Int32.pred l) + +let to_int32 l = l +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Level_repr.of_int32" diff --git a/src/proto/bootstrap/raw_level_repr.mli b/src/proto/bootstrap/raw_level_repr.mli new file mode 100644 index 000000000..3ac9868e1 --- /dev/null +++ b/src/proto/bootstrap/raw_level_repr.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type raw_level = t +val encoding: raw_level Data_encoding.t +val arg: raw_level RPC.Arg.arg +val pp: Format.formatter -> raw_level -> unit +include Compare.S with type t := raw_level + +val to_int32: raw_level -> int32 +val of_int32_exn: int32 -> raw_level + +val root: raw_level + +val succ: raw_level -> raw_level +val pred: raw_level -> raw_level option diff --git a/src/proto/bootstrap/reward_storage.ml b/src/proto/bootstrap/reward_storage.ml new file mode 100644 index 000000000..7886401b0 --- /dev/null +++ b/src/proto/bootstrap/reward_storage.ml @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += + | Too_late_reward_recording + | Too_late_reward_discarding + | Incorrect_discard + +let record c delegate cycle amount = + Storage.Rewards.Next.get c >>=? fun min_cycle -> + fail_unless Cycle_repr.(min_cycle <= cycle) + Too_late_reward_recording >>=? fun () -> + Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function + | None -> + Storage.Rewards.Amount.init c (delegate, cycle) amount + | Some previous_amount -> + Lwt.return Tez_repr.(previous_amount +? amount) >>=? fun amount -> + Storage.Rewards.Amount.set c (delegate, cycle) amount + +let discard c delegate cycle amount = + Storage.Rewards.Next.get c >>=? fun min_cycle -> + fail_unless Cycle_repr.(min_cycle <= cycle) + Too_late_reward_discarding >>=? fun () -> + Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function + | None -> + fail Incorrect_discard + | Some previous_amount -> + match Tez_repr.(previous_amount -? amount) with + | Ok amount -> + if Tez_repr.(amount = zero) then + Storage.Rewards.Amount.remove c (delegate, cycle) >>= fun ctxt -> + return ctxt + else + Storage.Rewards.Amount.set c (delegate, cycle) amount + | Error _ -> + fail Incorrect_discard + +let pay_rewards_for_cycle c cycle = + Storage.Rewards.Amount.fold c (Ok c) + ~f:(fun (delegate, reward_cycle) amount c -> + match c with + | Error _ -> Lwt.return c + | Ok c -> + if not Cycle_repr.(cycle = reward_cycle) + then return c + else + Storage.Rewards.Amount.remove c (delegate, reward_cycle) >>= fun c -> + Contract_storage.credit c + (Contract_repr.default_contract delegate) + amount) + +let pay_due_rewards c = + Storage.Current_timestamp.get c >>=? fun timestamp -> + let rec loop c cycle = + Storage.Rewards.Date.get_option c cycle >>=? function + | None -> + Storage.Rewards.Next.set c cycle + | Some reward_time -> + if Time_repr.(reward_time > timestamp) + then + Storage.Rewards.Next.set c cycle + else + pay_rewards_for_cycle c cycle >>=? fun c -> + loop c (Cycle_repr.succ cycle) in + Storage.Rewards.Next.get c >>=? fun cycle -> + loop c cycle + +let set_reward_time_for_cycle = Storage.Rewards.Date.init + +let init c = + Storage.Rewards.Next.init c Cycle_repr.root diff --git a/src/proto/bootstrap/reward_storage.mli b/src/proto/bootstrap/reward_storage.mli new file mode 100644 index 000000000..8ba49d14a --- /dev/null +++ b/src/proto/bootstrap/reward_storage.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val record: + Storage.t -> Ed25519.public_key_hash -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + +val discard: + Storage.t -> Ed25519.public_key_hash -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + +val pay_due_rewards: Storage.t -> Storage.t tzresult Lwt.t + +val set_reward_time_for_cycle: + Storage.t -> Cycle_repr.t -> Time.t -> Storage.t tzresult Lwt.t + +val init: Storage.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/bootstrap/roll_repr.ml b/src/proto/bootstrap/roll_repr.ml new file mode 100644 index 000000000..3fadb0ac9 --- /dev/null +++ b/src/proto/bootstrap/roll_repr.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = int32 +type roll = t + +let encoding = Data_encoding.int32 + +let first = 0l +let succ i = Int32.succ i + +let random sequence ~bound = + Seed_repr.take_int32 sequence bound + +let to_int32 v = v + +let (=) = Compare.Int32.(=) diff --git a/src/proto/bootstrap/roll_repr.mli b/src/proto/bootstrap/roll_repr.mli new file mode 100644 index 000000000..828e23012 --- /dev/null +++ b/src/proto/bootstrap/roll_repr.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type roll = t + +val encoding: roll Data_encoding.t + +val random: + Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence + +val first: roll +val succ: roll -> roll + +val to_int32: roll -> Int32.t + +val (=): roll -> roll -> bool diff --git a/src/proto/bootstrap/roll_storage.ml b/src/proto/bootstrap/roll_storage.ml new file mode 100644 index 000000000..c7d1e7069 --- /dev/null +++ b/src/proto/bootstrap/roll_storage.ml @@ -0,0 +1,206 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += + | Consume_roll_change + | No_roll_in_contract + | Deleted_contract_owning_rolls + +let get_contract_delegate c contract = + match Contract_repr.is_default contract with + | Some manager -> return (Some manager) + | None -> Storage.Contract.Delegate.get_option c contract + +let clear_cycle c cycle = + Storage.Roll.Last_for_cycle.get c cycle >>=? fun last -> + Storage.Roll.Last_for_cycle.delete c cycle >>=? fun c -> + let rec loop c roll = + if Roll_repr.(roll = last) then + return c + else + Storage.Roll.Owner_for_cycle.delete c (cycle, roll) >>=? fun c -> + loop c (Roll_repr.succ roll) in + loop c Roll_repr.first + +let fold ctxt ~f init = + Storage.Roll.Next.get ctxt >>=? fun last -> + let rec loop ctxt roll acc = + acc >>=? fun acc -> + if Roll_repr.(roll = last) then + return acc + else + Storage.Roll.Owner.get_option ctxt roll >>=? function + | None -> + loop ctxt (Roll_repr.succ roll) (return acc) + | Some contract -> + loop ctxt (Roll_repr.succ roll) (f roll contract acc) in + loop ctxt Roll_repr.first (return init) + +let froze_rolls_for_cycle ctxt cycle = + fold ctxt (ctxt, Roll_repr.first) + ~f:(fun roll contract (ctxt, promoted_roll as acc) -> + get_contract_delegate ctxt contract >>=? function + | None -> return acc + | Some delegate -> + Storage.Roll.Owner_for_cycle.init + ctxt (cycle, roll) delegate >>=? fun ctxt -> + return (ctxt, Roll_repr.succ promoted_roll)) + >>=? fun (ctxt, last_promoted_roll) -> + Storage.Roll.Last_for_cycle.init ctxt cycle last_promoted_roll + +(* Roll selection *) + +module Random = struct + + let int32_to_bytes i = + let b = MBytes.create 4 in + MBytes.set_int32 b 0 i; + b + + let level_random seed use level = + let position = level.Level_repr.cycle_position in + Seed_repr.initialize_new seed + [MBytes.of_string ("level "^use^":"); + int32_to_bytes position] + + let owner c kind level offset = + let cycle = level.Level_repr.cycle in + Seed_storage.for_cycle c cycle >>=? fun random_seed -> + let rd = level_random random_seed kind level in + let sequence = Seed_repr.sequence rd offset in + Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound -> + let roll, _ = Roll_repr.random sequence bound in + Storage.Roll.Owner_for_cycle.get c (cycle, roll) + +end + +let mining_rights_owner c level ~priority = + Random.owner c "mining" level priority + +let endorsement_rights_owner c level ~slot = + Random.owner c "endorsement" level (Int32.of_int slot) + +module Contract = struct + + let fresh_roll c = + Storage.Roll.Next.get c >>=? fun roll -> + Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> + return (roll, c) + + let get_limbo_roll c = + Storage.Roll.Limbo.get c >>=? function + | None -> + fresh_roll c >>=? fun (roll, c) -> + Storage.Roll.Limbo.set c (Some roll) >>=? fun c -> + return (roll, c) + | Some roll -> + return (roll, c) + + let consume_roll_change c contract = + Storage.Roll.Contract_change.get c contract >>=? fun change -> + match Tez_repr.(change - Constants_repr.roll_value) with + | None -> fail Consume_roll_change + | Some new_change -> + Storage.Roll.Contract_change.set c contract new_change + + let recover_roll_change c contract = + Storage.Roll.Contract_change.get c contract >>=? fun change -> + Lwt.return Tez_repr.(change +? Constants_repr.roll_value) >>=? fun new_change -> + Storage.Roll.Contract_change.set c contract new_change + + let pop_roll_from_contract c contract = + recover_roll_change c contract >>=? fun c -> + (* beginning: + contract : roll -> successor_roll -> ... + limbo : limbo_head -> ... + *) + Storage.Roll.Limbo.get c >>=? fun limbo_head -> + Storage.Roll.Contract_roll_list.get c contract >>=? function + | None -> fail No_roll_in_contract + | Some roll -> + Storage.Roll.Owner.delete c roll >>=? fun c -> + Storage.Roll.Successor.get c roll >>=? fun successor_roll -> + Storage.Roll.Contract_roll_list.set c contract successor_roll >>=? fun c -> + (* contract : successor_roll -> ... + roll ------^ + limbo : limbo_head -> ... *) + Storage.Roll.Successor.set c roll limbo_head >>=? fun c -> + (* contract : successor_roll -> ... + roll ------v + limbo : limbo_head -> ... *) + Storage.Roll.Limbo.set c (Some roll) >>=? fun c -> + (* contract : successor_roll -> ... + limbo : roll -> limbo_head -> ... *) + Lwt.return (Ok (roll, c)) + + let create_roll_in_contract c contract = + consume_roll_change c contract >>=? fun c -> + + (* beginning: + contract : contract_head -> ... + limbo : roll -> limbo_successor -> ... + *) + Storage.Roll.Contract_roll_list.get c contract >>=? fun contract_head -> + get_limbo_roll c >>=? fun (roll, c) -> + Storage.Roll.Owner.init c roll contract >>=? fun c -> + Storage.Roll.Successor.get c roll >>=? fun limbo_successor -> + Storage.Roll.Limbo.set c limbo_successor >>=? fun c -> + (* contract : contract_head -> ... + roll ------v + limbo : limbo_successor -> ... *) + Storage.Roll.Successor.set c roll contract_head >>=? fun c -> + (* contract : contract_head -> ... + roll ------^ + limbo : limbo_successor -> ... *) + Storage.Roll.Contract_roll_list.set c contract (Some roll) + (* contract : roll -> contract_head -> ... + limbo : limbo_successor -> ... *) + + let init c contract = + Storage.Roll.Contract_change.init c contract Tez_repr.zero + + let add_amount c contract amount = + Storage.Roll.Contract_change.get c contract >>=? fun change -> + Lwt.return Tez_repr.(amount +? change) >>=? fun change -> + Storage.Roll.Contract_change.set c contract change >>=? fun c -> + let rec loop c change = + match Tez_repr.(change - Constants_repr.roll_value) with + | None -> Lwt.return (Ok c) + | Some change -> + create_roll_in_contract c contract >>=? fun c -> + loop c change in + loop c change + + let remove_amount c contract amount = + let rec loop c change = + if Tez_repr.(amount <= change) + then Lwt.return (Ok (c, change)) + else + pop_roll_from_contract c contract >>=? fun (_, c) -> + Lwt.return Tez_repr.(change +? Constants_repr.roll_value) >>=? fun change -> + loop c change + in + Storage.Roll.Contract_change.get c contract >>=? fun change -> + loop c change >>=? fun (c, change) -> + match Tez_repr.(change - amount) with + | None -> assert false + | Some change -> + Storage.Roll.Contract_change.set c contract change + + let assert_empty c contract = + Storage.Roll.Contract_change.get c contract >>=? fun change -> + Storage.Roll.Contract_roll_list.get c contract >>=? fun roll_list -> + fail_unless (Tez_repr.(change = zero) && + match roll_list with None -> true | Some _ -> false) + Deleted_contract_owning_rolls + +end + +let init c = + Storage.Roll.Next.init c Roll_repr.first diff --git a/src/proto/bootstrap/roll_storage.mli b/src/proto/bootstrap/roll_storage.mli new file mode 100644 index 000000000..6bfdcff77 --- /dev/null +++ b/src/proto/bootstrap/roll_storage.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** + + Basic roll manipulation. + + If storage related to roll (a.k.a. `Storage.Roll`) are not used + outside this module, this interface enforce the invariant that a + roll is always either in the limbo list or in a contract list. + +*) + +type error += + | Consume_roll_change + | No_roll_in_contract + +val init : Storage.t -> Storage.t tzresult Lwt.t + +val fold : + Storage.t -> + f:(Roll_repr.roll -> Contract_repr.t -> 'a -> 'a tzresult Lwt.t) -> + 'a -> 'a tzresult Lwt.t + +val froze_rolls_for_cycle : + Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + +val clear_cycle : + Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + +val mining_rights_owner : + Storage.t -> Level_repr.t -> priority:int32 -> + Ed25519.public_key_hash tzresult Lwt.t + +val endorsement_rights_owner : + Storage.t -> Level_repr.t -> slot:int -> + Ed25519.public_key_hash tzresult Lwt.t + +module Contract : sig + + val init : + Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t + + val add_amount : + Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + + val remove_amount : + Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + + val assert_empty : Storage.t -> Contract_repr.t -> unit tzresult Lwt.t + +end + +(**/**) + +val get_contract_delegate: + Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option tzresult Lwt.t diff --git a/src/proto/bootstrap/script_int_repr.ml b/src/proto/bootstrap/script_int_repr.ml new file mode 100644 index 000000000..37a44ff16 --- /dev/null +++ b/src/proto/bootstrap/script_int_repr.ml @@ -0,0 +1,235 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* sign *) +type signed = Signed +type unsigned = Unsigned + +(* length *) +type eight = Eight +type sixteen = Sixteen +type thirtytwo = Thirtytwo +type sixtyfour = Sixtyfour + +(* int values *) +type ('s, 'l) int_val = Int of repr and repr = int64 + +(* types *) +and ('s, 'l) int_kind = + | Int8 : (signed, eight) int_kind + | Uint8 : (unsigned, eight) int_kind + | Int16 : (signed, sixteen) int_kind + | Uint16 : (unsigned, sixteen) int_kind + | Int32 : (signed, thirtytwo) int_kind + | Uint32 : (unsigned, thirtytwo) int_kind + | Int64 : (signed, sixtyfour) int_kind + | Uint64 : (unsigned, sixtyfour) int_kind + +(* homogeneous operator types *) +type ('s, 'l) binop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val -> ('s, 'l) int_val +type ('s, 'l) unop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val +type ('s, 'l) checked_binop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val -> ('s, 'l) int_val option +type ('s, 'l) checked_unop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val option +type ('s, 'l) shift = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, eight) int_val -> ('s, 'l) int_val + +(* cast operators *) +let cast + : type tos tol. (tos, tol) int_kind -> (_, _) int_val -> (tos, tol) int_val + = fun to_kind (Int v) -> + let (land) = Int64.logand + and (lor) = Int64.logor + and (=) = Compare.Int64.(=) in + match to_kind with + | Int8 when v land 0x80L = 0x80L -> + Int ((v land 0x000000FFL) lor 0xFFFFFFFFFFFFFF00L) + | Int8 -> + Int (v land 0x000000FFL) + | Uint8 -> + Int (v land 0x000000FFL) + | Int16 when v land 0x8000L = 0x8000L -> + Int ((v land 0x0000FFFFL) lor 0xFFFFFFFFFFFF0000L) + | Int16 -> + Int (v land 0x0000FFFFL) + | Uint16 -> + Int (v land 0x0000FFFFL) + | Int32 when v land 0x80000000L = 0x80000000L -> + Int ((v land 0xFFFFFFFFL) lor 0xFFFFFFFF00000000L) + | Int32 -> + Int (v land 0xFFFFFFFFL) + | Uint32 -> + Int (v land 0xFFFFFFFFL) + | Int64 -> Int v + | Uint64 -> Int v + +let checked_cast + : type tos tol. (tos, tol) int_kind -> (_, _) int_val -> (tos, tol) int_val option + = fun to_kind (Int v as arg) -> + let Int casted as res = cast to_kind arg in + if Compare.Int64.(casted <> v) then None else Some res + +(* to native int64s *) +let to_int64 _ (Int v) = + v +let of_int64 k v = + cast k (Int v) +let checked_of_int64 k v = + checked_cast k (Int v) + +(* arithmetics *) +let add kind (Int va) (Int vb) = + of_int64 kind (Int64.add va vb) +let sub kind (Int va) (Int vb) = + of_int64 kind (Int64.sub va vb) +let mul : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val + = fun kind (Int va) (Int vb) -> let r = Int64.mul va vb in match kind with + | Int8 -> of_int64 Int8 r + | Uint8 -> of_int64 Uint8 r + | Int16 -> of_int64 Int16 r + | Uint16 -> of_int64 Uint16 r + | Int32 -> of_int64 Int32 r + | Uint32 -> of_int64 Uint32 r + | Int64 -> of_int64 Int64 r + | Uint64 -> invalid_arg "Script_int.mul" +let div : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val + = fun kind (Int va) (Int vb) -> let r = Int64.div va vb in match kind with + | Int8 -> of_int64 Int8 r + | Uint8 -> of_int64 Uint8 r + | Int16 -> of_int64 Int16 r + | Uint16 -> of_int64 Uint16 r + | Int32 -> of_int64 Int32 r + | Uint32 -> of_int64 Uint32 r + | Int64 -> of_int64 Int64 r + | Uint64 -> invalid_arg "Script_int.div" +let rem : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val + = fun kind (Int va) (Int vb) -> let r = Int64.rem va vb in match kind with + | Int8 -> of_int64 Int8 r + | Uint8 -> of_int64 Uint8 r + | Int16 -> of_int64 Int16 r + | Uint16 -> of_int64 Uint16 r + | Int32 -> of_int64 Int32 r + | Uint32 -> of_int64 Uint32 r + | Int64 -> of_int64 Int64 r + | Uint64 -> invalid_arg "Script_int.rem" +let neg kind (Int v) = + of_int64 kind (Int64.neg v) +let abs kind (Int v) = + of_int64 kind (Int64.abs v) + +(* bitwise logic *) +let logand _ (Int va) (Int vb) = + Int (Int64.logand va vb) +let logor _ (Int va) (Int vb) = + Int (Int64.logor va vb) +let logxor kind (Int va) (Int vb) = + cast kind (Int (Int64.logxor va vb)) +let lognot kind (Int v) = + cast kind (Int (Int64.lognot v)) +let logsl kind (Int va) (Int vb) = + cast kind (Int (Int64.shift_left va (Int64.to_int vb))) +let logsr _ (Int va) (Int vb) = + Int (Int64.shift_right_logical va (Int64.to_int vb)) + +(* sign aware comparison *) +let signed_compare va vb = + Compare.Int64.(if va = vb then 0 else if va > vb then 1 else -1) +let unsigned_compare va vb = + Compare.Int64.(if va >= 0L then if vb >= 0L then signed_compare va vb else -1 + else if vb >= 0L then 1 else signed_compare va vb) +let compare + : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (signed, sixtyfour) int_val + = fun kind (Int va) (Int vb) -> + let cmp = match kind with + | Int8 -> signed_compare va vb + | Uint8 -> unsigned_compare va vb + | Int16 -> signed_compare va vb + | Uint16 -> unsigned_compare va vb + | Int32 -> signed_compare va vb + | Uint32 -> unsigned_compare va vb + | Int64 -> signed_compare va vb + | Uint64 -> unsigned_compare va vb in + Int Compare.Int.(if cmp = 0 then 0L else if cmp > 0 then 1L else -1L) + +let equal kind va vb = + Compare.Int64.(to_int64 kind va = to_int64 kind vb) + +(* checked arithmetics *) +let checked_add : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val option + = fun kind (Int va) (Int vb) -> let r = Int64.add va vb in match kind with + | Int8 -> checked_of_int64 Int8 r + | Uint8 -> checked_of_int64 Uint8 r + | Int16 -> checked_of_int64 Int16 r + | Uint16 -> checked_of_int64 Uint16 r + | Int32 -> checked_of_int64 Int32 r + | Uint32 -> checked_of_int64 Uint32 r + | Int64 when Compare.Int.(signed_compare r va < 0) -> None + | Int64 -> Some (Int r) + | Uint64 when Compare.Int.(unsigned_compare r va < 0) -> None + | Uint64 -> Some (Int r) + +let checked_sub : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val option + = fun kind (Int va) (Int vb) -> let r = Int64.sub va vb in match kind with + | Int8 -> checked_of_int64 Int8 r + | Uint8 -> checked_of_int64 Uint8 r + | Int16 -> checked_of_int64 Int16 r + | Uint16 -> checked_of_int64 Uint16 r + | Int32 -> checked_of_int64 Int32 r + | Uint32 -> checked_of_int64 Uint32 r + | Int64 when Compare.Int64.(vb >= 0L) -> + if Compare.Int.(signed_compare r va <= 0) then Some (Int r) else None + | Int64 -> + if Compare.Int.(signed_compare r va >= 0) then Some (Int r) else None + | Uint64 when Compare.Int.(unsigned_compare r va > 0) -> None + | Uint64 -> Some (Int r) + +let checked_neg : type l. (signed, l) int_kind -> (signed, l) int_val -> (signed, l) int_val option + = fun kind (Int v) -> let r = Int64.neg v in match kind with + | Int8 -> checked_of_int64 Int8 r + | Int16 -> checked_of_int64 Int16 r + | Int32 -> checked_of_int64 Int32 r + | Int64 when Compare.Int64.(v = Int64.min_int) -> None + | Int64 -> Some (Int r) + +let checked_abs : type l. (signed, l) int_kind -> (signed, l) int_val -> (signed, l) int_val option + = fun kind (Int v) -> let r = Int64.abs v in match kind with + | Int8 -> checked_of_int64 Int8 r + | Int16 -> checked_of_int64 Int16 r + | Int32 -> checked_of_int64 Int32 r + | Int64 when Compare.Int64.(v = Int64.min_int) -> None + | Int64 -> Some (Int r) + +let checked_mul : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val option + = fun kind (Int va) (Int vb) -> let r = Int64.mul va vb in match kind with + | Int8 -> checked_of_int64 Int8 r + | Uint8 -> checked_of_int64 Uint8 r + | Int16 -> checked_of_int64 Int16 r + | Uint16 -> checked_of_int64 Uint16 r + | Int32 -> checked_of_int64 Int32 r + | Uint32 -> checked_of_int64 Uint32 r + | Int64 -> + if Compare.Int64.(vb = 0L || va = 0L) then Some (Int r) + else if Compare.Int64.(r = 0L) then None + else if Compare.Int64.(Int64.div r va = vb) then Some (Int r) + else None + | Uint64 -> invalid_arg "Script_int.checked_mul" + +let string_of_int_kind (type s) (type l) (kind:(s,l) int_kind) = + match kind with + | Int8 -> "int8" + | Uint8 -> "uint8" + | Int16 -> "int16" + | Uint16 -> "uint16" + | Int32 -> "int32" + | Uint32 -> "uint32" + | Int64 -> "int64" + | Uint64 -> "uint64" diff --git a/src/proto/bootstrap/script_int_repr.mli b/src/proto/bootstrap/script_int_repr.mli new file mode 100644 index 000000000..9f338e6d6 --- /dev/null +++ b/src/proto/bootstrap/script_int_repr.mli @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* sign *) +type signed = Signed +type unsigned = Unsigned + +(* length *) +type eight = Eight +type sixteen = Sixteen +type thirtytwo = Thirtytwo +type sixtyfour = Sixtyfour + +(* int values *) +type ('s, 'l) int_val = Int of repr and repr + +(* int types *) +type ('s, 'l) int_kind = + | Int8 : (signed, eight) int_kind + | Uint8 : (unsigned, eight) int_kind + | Int16 : (signed, sixteen) int_kind + | Uint16 : (unsigned, sixteen) int_kind + | Int32 : (signed, thirtytwo) int_kind + | Uint32 : (unsigned, thirtytwo) int_kind + | Int64 : (signed, sixtyfour) int_kind + | Uint64 : (unsigned, sixtyfour) int_kind + +(* homogeneous operator types *) +type ('s, 'l) binop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val -> ('s, 'l) int_val +type ('s, 'l) unop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val +type ('s, 'l) checked_binop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val -> ('s, 'l) int_val option +type ('s, 'l) checked_unop = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, 'l) int_val option +type ('s, 'l) shift = + ('s, 'l) int_kind -> ('s, 'l) int_val -> ('s, eight) int_val -> ('s, 'l) int_val + +(* cast operators *) +val cast : ('tos, 'tol) int_kind -> ('s, 'l) int_val -> ('tos, 'tol) int_val +val checked_cast : ('tos, 'tol) int_kind -> ('s, 'l) int_val -> ('tos, 'tol) int_val option + +(* to native int64s *) +val to_int64 : ('s, 'l) int_kind -> ('s, 'l) int_val -> int64 +val of_int64 : ('s, 'l) int_kind -> int64 -> ('s, 'l) int_val +val checked_of_int64 : ('s, 'l) int_kind -> int64 -> ('s, 'l) int_val option + +(* arithmetics *) +val abs : (signed, 'l) unop +val neg : (signed, 'l) unop +val add : ('s, 'l) binop +val sub : ('s, 'l) binop +val mul : ('s, 'l) binop +val div : ('s, 'l) binop +val rem : ('s, 'l) binop +val checked_abs : (signed, 'l) checked_unop +val checked_neg : (signed, 'l) checked_unop +val checked_add : ('s, 'l) checked_binop +val checked_sub : ('s, 'l) checked_binop +val checked_mul : ('s, 'l) checked_binop + +(* bitwise logic *) +val logand : (unsigned, 'l) binop +val logor : (unsigned, 'l) binop +val logxor : (unsigned, 'l) binop +val lognot : (unsigned, 'l) unop +val logsl : (unsigned, 'l) shift +val logsr : (unsigned, 'l) shift + +(* sign aware comparison *) +val compare : ('s, 'l) int_kind -> + ('s, 'l) int_val -> ('s, 'l) int_val -> (signed, sixtyfour) int_val +val equal : ('s, 'l) int_kind -> + ('s, 'l) int_val -> ('s, 'l) int_val -> bool + +(* utilities *) +val string_of_int_kind : ('s, 'l) int_kind -> string diff --git a/src/proto/bootstrap/script_interpreter.ml b/src/proto/bootstrap/script_interpreter.ml new file mode 100644 index 000000000..8b18f1589 --- /dev/null +++ b/src/proto/bootstrap/script_interpreter.ml @@ -0,0 +1,587 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context +open Script_int +open Script +open Script_typed_ir +open Script_ir_translator + +(* ---- Run-time errors -----------------------------------------------------*) + +type error += Quota_exceeded +type error += Overflow of Script.location +type error += Reject of Script.location +type error += Division_by_zero of Script.location + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"quotaExceededRuntimeError" + ~title: "Quota exceeded (runtime script error)" + ~description: + "A script or one of its callee took too much \ + time or storage space" + empty + (function Quota_exceeded -> Some () | _ -> None) + (fun () -> Quota_exceeded) ; + register_error_kind + `Permanent + ~id:"overflowRuntimeError" + ~title: "Value overflow (runtime script error)" + ~description: + "An integer or currency overflow happened \ + during the execution of a script" + (obj1 (req "location" Script.location_encoding)) + (function Overflow loc -> Some loc | _ -> None) + (fun loc -> Overflow loc) ; + register_error_kind + `Permanent + ~id:"divisionByZeroRuntimeError" + ~title: "Division by zero (runtime script error)" + ~description: "" + (obj1 (req "location" Script.location_encoding)) + (function Division_by_zero loc -> Some loc | _ -> None) + (fun loc -> Division_by_zero loc) ; + register_error_kind + `Temporary + ~id:"scriptRejectedRuntimeError" + ~title: "Script rejected (runtime script error)" + ~description: "" + (obj1 (req "location" Script.location_encoding)) + (function Reject loc -> Some loc | _ -> None) + (fun loc -> Reject loc) + +(* ---- interpreter ---------------------------------------------------------*) + +type 'tys stack = + | Item : 'ty * 'rest stack -> ('ty * 'rest) stack + | Empty : end_of_stack stack + +let is_nan x = match classify_float x with + | FP_nan -> true + | _ -> false + +let eq_comparable + : type a. a comparable_ty -> a -> a -> bool + = fun kind x v -> match kind with + | String_key -> Compare.String.(x = v) + | Bool_key -> Compare.Bool.(x = v) + | Float_key -> Compare.Float.(x = v) + | Tez_key -> Tez.(x = v) + | Key_key -> Ed25519.Public_key_hash.(equal x v) + | Int_key kind -> Script_int.(equal kind x v) + | Timestamp_key -> Timestamp.(x = v) + +let rec interp + : type p r. + int -> Contract.t -> Contract.t -> Tez.t -> + context -> (p, r) lambda -> p -> (r * int * context) tzresult Lwt.t + = fun qta orig source amount ctxt (Lam (code, _)) arg -> + let rec step + : type b a. + int -> context -> (b, a) instr -> b stack -> + (a stack * int * context) tzresult Lwt.t = + fun qta ctxt instr stack -> + if Compare.Int.(qta <= 0) then + fail Quota_exceeded + else match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + return (rest, qta - 1, ctxt) + | Dup, Item (v, rest) -> + return (Item (v, Item (v, rest)), qta - 1, ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + return (Item (vo, Item (vi, rest)), qta - 1, ctxt) + | Const v, rest -> + return (Item (v, rest), qta - 1, ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + return (Item (Some v, rest), qta - 1, ctxt) + | Cons_none _, rest -> + return (Item (None, rest), qta - 1, ctxt) + | If_none (bt, _), Item (None, rest) -> + step qta ctxt bt rest + | If_none (_, bf), Item (Some v, rest) -> + step qta ctxt bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + return (Item ((a, b), rest), qta - 1, ctxt) + | Car, Item ((a, _), rest) -> + return (Item (a, rest), qta - 1, ctxt) + | Cdr, Item ((_, b), rest) -> + return (Item (b, rest), qta - 1, ctxt) + (* unions *) + | Left, Item (v, rest) -> + return (Item (L v, rest), qta - 1, ctxt) + | Right, Item (v, rest) -> + return (Item (R v, rest), qta - 1, ctxt) + | If_left (bt, _), Item (L v, rest) -> + step qta ctxt bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + step qta ctxt bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + return (Item (hd :: tl, rest), qta - 1, ctxt) + | Nil, rest -> + return (Item ([], rest), qta - 1, ctxt) + | If_cons (_, bf), Item ([], rest) -> + step qta ctxt bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + step qta ctxt bt (Item (hd, Item (tl, rest))) + | List_iter, Item (lam, Item (l, rest)) -> + fold_left_s (fun ((), qta, ctxt) arg -> + interp qta orig source amount ctxt lam arg) + ((), qta, ctxt) l >>=? fun ((), qta, ctxt) -> + return (rest, qta, ctxt) + | List_map, Item (lam, Item (l, rest)) -> + fold_left_s (fun (tail, qta, ctxt) arg -> + interp qta orig source amount ctxt lam arg + >>=? fun (ret, qta, ctxt) -> + return (ret :: tail, qta, ctxt)) + ([], qta, ctxt) l >>=? fun (res, qta, ctxt) -> + return (Item (res, rest), qta, ctxt) + | List_reduce, Item (lam, Item (l, Item (init, rest))) -> + fold_left_s + (fun (partial, qta, ctxt) arg -> + interp qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt) -> + return (partial, qta, ctxt)) + (init, qta, ctxt) l >>=? fun (res, qta, ctxt) -> + return (Item (res, rest), qta, ctxt) + (* sets *) + | Empty_set t, rest -> + return (Item ((ref [], t), rest), qta - 1, ctxt) + | Set_iter, Item (lam, Item ((l, _), rest)) -> + fold_left_s (fun ((), qta, ctxt) arg -> + interp qta orig source amount ctxt lam arg) + ((), qta, ctxt) !l >>=? fun ((), qta, ctxt) -> + return (rest, qta, ctxt) + | Set_map t, Item (lam, Item ((l, _), rest)) -> + fold_left_s + (fun (tail, qta, ctxt) arg -> + interp qta orig source amount ctxt lam arg >>=? + fun (ret, qta, ctxt) -> + return (ret :: tail, qta, ctxt)) + ([], qta, ctxt) !l >>=? fun (res, qta, ctxt) -> + return (Item ((ref res, t), rest), qta, ctxt) + | Set_reduce, Item (lam, Item ((l, _), Item (init, rest))) -> + fold_left_s + (fun (partial, qta, ctxt) arg -> + interp qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt) -> + return (partial, qta, ctxt)) + (init, qta, ctxt) !l >>=? fun (res, qta, ctxt) -> + return (Item (res, rest), qta, ctxt) + | Set_mem, Item (v, Item ((l, kind), rest)) -> + return (Item (List.exists (eq_comparable kind v) !l, rest), qta - 1, ctxt) + | Set_update, Item (v, Item (false, Item ((l, kind), rest))) -> + l := List.filter (fun x -> not (eq_comparable kind x v)) !l ; + return (rest, qta - 1, ctxt) + | Set_update, Item (v, Item (true, Item ((l, kind), rest))) -> + l := v :: List.filter (fun x -> not (eq_comparable kind x v)) !l ; + return (rest, qta - 1, ctxt) + (* maps *) + | Empty_map (t, _), rest -> + return (Item ((ref [], t), rest), qta - 1, ctxt) + | Map_iter, Item (lam, Item ((l, _), rest)) -> + fold_left_s + (fun ((), qta, ctxt) arg -> interp qta orig source amount ctxt lam arg) + ((), qta, ctxt) !l >>=? fun ((), qta, ctxt) -> + return (rest, qta, ctxt) + | Map_map, Item (lam, Item ((l, t), rest)) -> + fold_left_s + (fun (tail, qta, ctxt) (k, v) -> + interp qta orig source amount ctxt lam (k, v) + >>=? fun (ret, qta, ctxt) -> + return ((k, ret) :: tail, qta, ctxt)) + ([], qta, ctxt) !l >>=? fun (res, qta, ctxt) -> + return (Item ((ref res, t), rest), qta, ctxt) + | Map_reduce, Item (lam, Item ((l, _), Item (init, rest))) -> + fold_left_s + (fun (partial, qta, ctxt) arg -> + interp qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt) -> + return (partial, qta, ctxt)) + (init, qta, ctxt) !l >>=? fun (res, qta, ctxt) -> + return (Item (res, rest), qta, ctxt) + | Map_mem, Item (v, Item ((l, kind), rest)) -> + let res = List.exists (fun (k, _) -> eq_comparable kind k v) !l in + return (Item (res, rest), qta - 1, ctxt) + | Map_get, Item (v, Item ((l, kind), rest)) -> + let res = + try Some (snd (List.find (fun (k, _) -> eq_comparable kind k v) !l)) + with Not_found -> None in + return (Item (res, rest), qta - 1, ctxt) + | Map_update, Item (vk, Item (None, Item ((l, kind), rest))) -> + l := List.filter (fun (k, _) -> not (eq_comparable kind k vk)) !l ; + return (rest, qta - 1, ctxt) + | Map_update, Item (vk, Item (Some v, Item ((l, kind), rest))) -> + l := (vk, v) :: List.filter (fun (k, _) -> not (eq_comparable kind k vk)) !l ; + return (rest, qta - 1, ctxt) + (* reference cells *) + | Ref, Item (v, rest) -> + return (Item (ref v, rest), qta - 1, ctxt) + | Deref, Item ({ contents = v}, rest) -> + return (Item (v, rest), qta - 1, ctxt) + | Set, Item (r, Item (v, rest)) -> + r := v ; + return (rest, qta - 1, ctxt) + (* timestamp operations *) + | Add_period_to_timestamp, Item (p, Item (t, rest)) -> + Lwt.return + (Period.of_seconds (Int64.of_float p) >>? fun p -> + Timestamp.(t +? p) >>? fun res -> + Ok (Item (res, rest), qta - 1, ctxt)) + | Add_seconds_to_timestamp (kind, _pos), Item (n, Item (t, rest)) -> + let n = Script_int.to_int64 kind n in + Lwt.return + (Period.of_seconds n >>? fun p -> + Timestamp.(t +? p) >>? fun res -> + Ok (Item (res, rest), qta - 1, ctxt)) + | Add_timestamp_to_period, Item (t, Item (p, rest)) -> + Lwt.return + (Period.of_seconds (Int64.of_float p) >>? fun p -> + Timestamp.(t +? p) >>? fun res -> + Ok (Item (res, rest), qta - 1, ctxt)) + | Add_timestamp_to_seconds (kind, _pos), Item (t, Item (n, rest)) -> + let n = Script_int.to_int64 kind n in + Lwt.return + (Period.of_seconds n >>? fun p -> + Timestamp.(t +? p) >>? fun res -> + Ok (Item (res, rest), qta - 1, ctxt)) + (* string operations *) + | Concat, Item (x, Item (y, rest)) -> + return (Item (x ^ y, rest), qta - 1, ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return Tez.(x +? y) >>=? fun res -> + return (Item (res, rest), qta - 1, ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return Tez.(x -? y) >>=? fun res -> + return (Item (res, rest), qta - 1, ctxt) + | Mul_tez kind, Item (x, Item (y, rest)) -> + Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> + return (Item (res, rest), qta - 1, ctxt) + | Mul_tez' kind, Item (y, Item (x, rest)) -> + Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> + return (Item (res, rest), qta - 1, ctxt) + (* float operations *) + | Floor, Item (x, rest) -> + return (Item (floor x, rest), qta - 1, ctxt) + | Ceil, Item (x, rest) -> + return (Item (ceil x, rest), qta - 1, ctxt) + | Inf, rest -> + return (Item (infinity, rest), qta - 1, ctxt) + | NaN, rest -> + return (Item (nan, rest), qta - 1, ctxt) + | IsNaN, Item (x, rest) -> + return (Item (is_nan x, rest), qta - 1, ctxt) + | NaNaN pos, Item (x, rest) -> + if is_nan x then fail (Reject pos) else return (rest, qta - 1, ctxt) + | Abs_float, Item (x, rest) -> + return (Item (abs_float x, rest), qta - 1, ctxt) + | Neg_float, Item (x, rest) -> + return (Item (0. -. x, rest), qta - 1, ctxt) + | Add_float, Item (x, Item (y, rest)) -> + return (Item (x +. y, rest), qta - 1, ctxt) + | Sub_float, Item (x, Item (y, rest)) -> + return (Item (x -. y, rest), qta - 1, ctxt) + | Mul_float, Item (x, Item (y, rest)) -> + return (Item (x *. y, rest), qta - 1, ctxt) + | Div_float, Item (x, Item (y, rest)) -> + return (Item (x /. y, rest), qta - 1, ctxt) + | Mod_float, Item (x, Item (y, rest)) -> + return (Item (mod_float x y, rest), qta - 1, ctxt) + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + return (Item (x || y, rest), qta - 1, ctxt) + | And, Item (x, Item (y, rest)) -> + return (Item (x && y, rest), qta - 1, ctxt) + | Xor, Item (x, Item (y, rest)) -> + return (Item (not x && y || x && not y, rest), qta - 1, ctxt) + | Not, Item (x, rest) -> + return (Item (not x, rest), qta - 1, ctxt) + (* integer operations *) + | Checked_abs_int (kind, pos), Item (x, rest) -> + begin match Script_int.checked_abs kind x with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Checked_neg_int (kind, pos), Item (x, rest) -> + begin match Script_int.checked_neg kind x with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Checked_add_int (kind, pos), Item (x, Item (y, rest)) -> + begin match Script_int.checked_add kind x y with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Checked_sub_int (kind, pos), Item (x, Item (y, rest)) -> + begin match Script_int.checked_sub kind x y with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Checked_mul_int (kind, pos), Item (x, Item (y, rest)) -> + begin match Script_int.checked_mul kind x y with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Abs_int kind, Item (x, rest) -> + return (Item (Script_int.abs kind x, rest), qta - 1, ctxt) + | Neg_int kind, Item (x, rest) -> + return (Item (Script_int.neg kind x, rest), qta - 1, ctxt) + | Add_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.add kind x y, rest), qta - 1, ctxt) + | Sub_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt) + | Mul_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt) + | Div_int (kind, pos), Item (x, Item (y, rest)) -> + if Compare.Int64.(Script_int.to_int64 kind y = 0L) then + fail (Division_by_zero pos) + else + return (Item (Script_int.div kind x y, rest), qta - 1, ctxt) + | Mod_int (kind, pos), Item (x, Item (y, rest)) -> + if Compare.Int64.(Script_int.to_int64 kind y = 0L) then + fail (Division_by_zero pos) + else + return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt) + | Lsl_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt) + | Lsr_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt) + | Or_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt) + | And_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt) + | Xor_int kind, Item (x, Item (y, rest)) -> + return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt) + | Not_int kind, Item (x, rest) -> + return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt) + (* control *) + | Seq (hd, tl), stack -> + step qta ctxt hd stack >>=? fun (trans, qta, ctxt) -> + step qta ctxt tl trans + | If (bt, _), Item (true, rest) -> + step qta ctxt bt rest + | If (_, bf), Item (false, rest) -> + step qta ctxt bf rest + | Loop body, Item (true, rest) -> + step qta ctxt body rest >>=? fun (trans, qta, ctxt) -> + step (qta - 1) ctxt (Loop body) trans + | Loop _, Item (false, rest) -> + return (rest, qta, ctxt) + | Dip b, Item (ign, rest) -> + step qta ctxt b rest >>=? fun (res, qta, ctxt) -> + return (Item (ign, res), qta, ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + interp qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) -> + return (Item (res, rest), qta - 1, ctxt) + | Lambda lam, rest -> + return (Item (lam, rest), qta - 1, ctxt) + | Fail pos, _ -> + fail (Reject pos) + | Nop, stack -> + return (stack, qta - 1, ctxt) + (* comparison *) + | Compare Bool_key, Item (a, Item (b, rest)) -> + let cmpres = Compare.Bool.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare String_key, Item (a, Item (b, rest)) -> + let cmpres = Compare.String.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Float_key, Item (a, Item (b, rest)) -> + let cmpres = Compare.Float.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Tez_key, Item (a, Item (b, rest)) -> + let cmpres = Tez.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare (Int_key kind), Item (a, Item (b, rest)) -> + let cmpres = Script_int.compare kind a b in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Key_key, Item (a, Item (b, rest)) -> + let cmpres = Ed25519.Public_key_hash.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Timestamp_key, Item (a, Item (b, rest)) -> + let cmpres = Timestamp.compare a b in + let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in + return (Item (cmpres, rest), qta - 1, ctxt) + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres = 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres <> 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres < 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres > 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres <= 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.to_int64 Int64 cmpres in + let cmpres = Compare.Int64.(cmpres >= 0L) in + return (Item (cmpres, rest), qta - 1, ctxt) + (* casts *) + | Checked_int_of_int (_, kt, pos), Item (v, rest) -> + begin match Script_int.checked_cast kt v with + | None -> fail (Overflow pos) + | Some res -> return (Item (res, rest), qta - 1, ctxt) + end + | Int_of_int (_, kt), Item (v, rest) -> + return (Item (Script_int.cast kt v, rest), qta - 1, ctxt) + | Int_of_float kt, Item (v, rest) -> + let v = Int64.of_float v in + return (Item (Script_int.of_int64 kt v, rest), qta - 1, ctxt) + | Float_of_int kf, Item (v, rest) -> + let v = Int64.to_float (Script_int.to_int64 kf v) in + return (Item (v, rest), qta - 1, ctxt) + (* protocol *) + | Manager, Item ((_, _, contract), rest) -> + Contract.get_manager ctxt contract >>=? fun manager -> + return (Item (manager, rest), qta - 1, ctxt) + | Transfer_funds (storage_type, loc), + Item (p, Item (amount, Item ((tp, Void_t, destination), Item (sto, Empty)))) -> begin + Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? fun destination_script -> + let sto = unparse_untagged_data storage_type sto in + Contract.update_script_storage ctxt source sto >>=? fun ctxt -> + begin match destination_script with + | No_script -> + (* we see non scripted contracts as (void, void) contract *) + Lwt.return (ty_eq tp Void_t |> + record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) -> + return (ctxt, qta) + | Script { code ; storage } -> + let p = unparse_untagged_data tp p in + execute source destination ctxt storage code amount p qta + >>=? fun (csto, ret, qta, ctxt) -> + Contract.update_script_storage + ctxt destination csto >>=? fun ctxt -> + trace + (Invalid_contract (loc, destination)) + (parse_untagged_data ctxt Void_t ret) >>=? fun () -> + return (ctxt, qta) + end >>=? fun (ctxt, qta) -> + Contract.get_script ctxt source >>=? (function + | No_script -> assert false + | Script { storage = { storage } } -> + parse_untagged_data ctxt storage_type storage >>=? fun sto -> + return (Item ((), Item (sto, Empty)), qta - 1, ctxt)) + end + | Transfer_funds (storage_type, loc), + Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin + Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? function + | No_script -> fail (Invalid_contract (loc, destination)) + | Script { code ; storage } -> + let sto = unparse_untagged_data storage_type sto in + Contract.update_script_storage ctxt source sto >>=? fun ctxt -> + let p = unparse_untagged_data tp p in + execute source destination ctxt storage code amount p qta + >>=? fun (sto, ret, qta, ctxt) -> + Contract.update_script_storage + ctxt destination sto >>=? fun ctxt -> + trace + (Invalid_contract (loc, destination)) + (parse_untagged_data ctxt tr ret) >>=? fun v -> + Contract.get_script ctxt source >>=? (function + | No_script -> assert false + | Script { storage = { storage } } -> + parse_untagged_data ctxt storage_type storage >>=? fun sto -> + return (Item (v, Item (sto, Empty)), qta - 1, ctxt)) + end + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + Contract.unconditional_spend ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + ~manager ~delegate ~balance + ~script:No_script ~spendable:true ~delegatable >>=? fun (ctxt, contract) -> + return (Item ((Void_t, Void_t, contract), rest), qta - 1, ctxt) + | Create_contract (g, p, r), + Item (manager, Item (delegate, Item (delegatable, Item (credit, + Item (Lam (_, code), Item (init, rest)))))) -> + let code, storage = + { code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type = unparse_ty g }, + { storage = unparse_untagged_data g init; storage_type = unparse_ty g } in + let storage_fee = Script.storage_cost storage in + let code_fee = Script.code_cost code in + Lwt.return Tez.(code_fee +? storage_fee) >>=? fun script_fee -> + Lwt.return Tez.(script_fee +? + Constants.origination_burn) >>=? fun total_fee -> + fail_unless Tez.(credit > total_fee) + Contract.Initial_amount_too_low >>=? fun () -> + Contract.unconditional_spend ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + ~manager ~delegate ~balance + ~script:(Script { code ; storage }) ~spendable:true ~delegatable + >>=? fun (ctxt, contract) -> + return (Item ((p, r, contract), rest), qta - 1, ctxt) + | Balance, rest -> + Contract.get_balance ctxt source >>=? fun balance -> + return (Item (balance, rest), qta - 1, ctxt) + | Now, rest -> + Timestamp.get_current ctxt >>=? fun now -> + return (Item (now, rest), qta - 1, ctxt) + | Check_signature, Item (key, Item ((signature, message), rest)) -> + Public_key.get ctxt key >>=? fun key -> + let message = MBytes.of_string message in + let res = Ed25519.check_signature key signature message in + return (Item (res, rest), qta - 1, ctxt) + | H ty, Item (v, rest) -> + let hash = Script.hash_expr (unparse_untagged_data ty v) in + return (Item (hash, rest), qta - 1, ctxt) + | Steps_to_quota, rest -> + let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in + return (Item (steps, rest), qta - 1, ctxt) + | Source (ta, tb), rest -> + return (Item ((ta, tb, orig), rest), qta - 1, ctxt) + | Amount, rest -> + return (Item (amount, rest), qta - 1, ctxt) + in + step qta ctxt code (Item (arg, Empty)) >>=? fun (Item (ret, Empty), qta, ctxt) -> + return (ret, qta, ctxt) + +(* ---- contract handling ---------------------------------------------------*) + +and execute orig source ctxt { storage; storage_type } { code; arg_type; ret_type } amount arg qta = + parse_ty arg_type >>=? fun (Ex arg_type) -> + parse_ty ret_type >>=? fun (Ex ret_type) -> + parse_ty storage_type >>=? fun (Ex storage_type) -> + let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in + let ret_type_full = Pair_t (ret_type, storage_type) in + parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda -> + parse_untagged_data ctxt arg_type arg >>=? fun arg -> + parse_untagged_data ctxt storage_type storage >>=? fun storage -> + interp qta orig source amount ctxt lambda ((amount, arg), storage) >>=? fun (ret, qta, ctxt) -> + let ret, storage = ret in + return (unparse_untagged_data storage_type storage, + unparse_untagged_data ret_type ret, + qta, ctxt) diff --git a/src/proto/bootstrap/script_interpreter.mli b/src/proto/bootstrap/script_interpreter.mli new file mode 100644 index 000000000..9a32c7987 --- /dev/null +++ b/src/proto/bootstrap/script_interpreter.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context + +type error += Quota_exceeded +type error += Overflow of Script.location +type error += Reject of Script.location +type error += Division_by_zero of Script.location + +(* calling convention : + ((amount, arg), globals)) -> (ret, globals) *) + +val execute: Contract.t -> Contract.t -> Tezos_context.t -> + Script.storage -> Script.code -> Tez.t -> + Script.expr -> int -> + (Script.expr * Script.expr * int * context) tzresult Lwt.t diff --git a/src/proto/bootstrap/script_ir_translator.ml b/src/proto/bootstrap/script_ir_translator.ml new file mode 100644 index 000000000..2e60e92e3 --- /dev/null +++ b/src/proto/bootstrap/script_ir_translator.ml @@ -0,0 +1,1450 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context +open Script_int +open Script +open Script_typed_ir + +(* ---- Error reporting -----------------------------------------------------*) + +type 'ty stack_ty = + | Item_t : 'ty ty * 'rest stack_ty -> ('ty * 'rest) stack_ty + | Empty_t : end_of_stack stack_ty + +(* Boxed existentials types to put in exception constructors *) +type stack_ty_val = Stack_ty : _ stack_ty -> stack_ty_val +type ty_val = + | Ty : _ ty -> ty_val + | Comparable_ty : _ comparable_ty -> ty_val +type int_kind_val = Int_kind : (_, _) int_kind -> int_kind_val + +type kind = Type | Constant | Instr + +(* Structure errors *) +type error += Invalid_arity of Script.location * kind * string * int * int +type error += Invalid_constant of Script.location * string +type error += Invalid_primitive of Script.location * kind * string +type error += Invalid_expression_kind of Script.location (* TODO: expected *) +type error += Sequence_parameter_expected of Script.location * kind * string * int + +(* Instruction errors *) +type error += Comparable_type_expected of Script.location +type error += Undefined_cast of Script.location * ty_val * ty_val +type error += Undefined_binop of Script.location * string * ty_val * ty_val +type error += Undefined_unop of Script.location * string * ty_val +type error += Bad_return of Script.location * stack_ty_val * ty_val +type error += Bad_stack of Script.location * int * stack_ty_val +type error += Unmatched_branches of Script.location * stack_ty_val * stack_ty_val +type error += Bad_stack_item of Script.location * int +type error += Transfer_in_lambda of Script.location + +(* Value typing errors *) +type error += Inconsistent_ints of int_kind_val * int_kind_val +type error += Inconsistent_types of ty_val * ty_val +type error += Inconsistent_stack_lengths +type error += Inconsistent_stack_items of int +type error += Incomparable_type of ty_val +type error += Bad_sign of int_kind_val +type error += Invalid_contract of Script.location * Contract.t + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"InvalidContractError" + ~title: "Invalid contract" + ~description: + "A script or RPC tried to reference a contract that does not \ + exists or assumed a wrong type for an existing contract" + (obj2 + (req "location" Script.location_encoding) + (req "contract" Contract.encoding)) + (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None) + (fun (loc, c) -> Invalid_contract (loc, c)) + +let location = function + | Prim (loc, _, _) + | Float (loc, _) + | Int (loc, _) + | String (loc, _) + | Seq (loc, _) -> loc + +let expect_sequence_parameter loc kind prim pos = function + | Script.Seq _ -> return () + | _ -> fail (Sequence_parameter_expected (loc, kind, prim, pos)) + +(* ---- Equality witnesses --------------------------------------------------*) + +type ('ta, 'tb) eq = + | Eq : 'same * 'same -> ('same, 'same) eq + +let eq + : type t. t -> t -> (t, t) eq tzresult + = fun ta tb -> Ok (Eq (ta, tb)) + +let int_kind_eq + : type sa la sb lb. (sa, la) int_kind -> (sb, lb) int_kind -> + ((sa, la) int_kind, (sb, lb) int_kind) eq tzresult + = fun ka kb -> match ka, kb with + | Int8, Int8 -> eq ka kb + | Uint8, Uint8 -> eq ka kb + | Int16, Int16 -> eq ka kb + | Uint16, Uint16 -> eq ka kb + | Int32, Int32 -> eq ka kb + | Uint32, Uint32 -> eq ka kb + | Int64, Int64 -> eq ka kb + | Uint64, Uint64 -> eq ka kb + | _ -> error @@ Inconsistent_ints (Int_kind ka, Int_kind kb) + +let unsigned_int_kind + : type sa la. (sa, la) int_kind -> (sa, unsigned) eq tzresult + = fun kind -> match kind with + | Uint8 -> eq Unsigned Unsigned + | Uint16 -> eq Unsigned Unsigned + | Uint32 -> eq Unsigned Unsigned + | Uint64 -> eq Unsigned Unsigned + | _ -> error @@ Bad_sign (Int_kind kind) + +let signed_int_kind + : type sa la. (sa, la) int_kind -> (sa, signed) eq tzresult + = fun kind -> match kind with + | Int8 -> eq Signed Signed + | Int16 -> eq Signed Signed + | Int32 -> eq Signed Signed + | Int64 -> eq Signed Signed + | _ -> error @@ Bad_sign (Int_kind kind) + +let rec ty_eq + : type ta tb. ta ty -> tb ty -> (ta ty, tb ty) eq tzresult + = fun ta tb -> + match ta, tb with + | Void_t, Void_t -> eq ta tb + | Int_t ka, Int_t kb -> + (int_kind_eq ka kb >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | String_t, String_t -> eq ta tb + | Signature_t, Signature_t -> eq ta tb + | Float_t, Float_t -> eq ta tb + | Tez_t, Tez_t -> eq ta tb + | Timestamp_t, Timestamp_t -> eq ta tb + | Bool_t, Bool_t -> eq ta tb + | Pair_t (tal, tar), Pair_t (tbl, tbr) -> + (ty_eq tal tbl >>? fun (Eq _) -> + ty_eq tar tbr >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | Union_t (tal, tar), Union_t (tbl, tbr) -> + (ty_eq tal tbl >>? fun (Eq _) -> + ty_eq tar tbr >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | Lambda_t (tal, tar), Lambda_t (tbl, tbr) -> + (ty_eq tal tbl >>? fun (Eq _) -> + ty_eq tar tbr >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | Contract_t (tal, tar), Contract_t (tbl, tbr) -> + (ty_eq tal tbl >>? fun (Eq _) -> + ty_eq tar tbr >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | Ref_t tva, Ref_t tvb -> + (ty_eq tva tvb >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | Option_t tva, Option_t tvb -> + (ty_eq tva tvb >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | List_t tva, List_t tvb -> + (ty_eq tva tvb >>? fun (Eq _) -> + (eq ta tb : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (Ty ta, Ty tb)) + | _, _ -> error (Inconsistent_types (Ty ta, Ty tb)) + +let rec stack_ty_eq + : type ta tb. int -> ta stack_ty -> tb stack_ty -> + (ta stack_ty, tb stack_ty) eq tzresult = fun lvl ta tb -> + match ta, tb with + | Item_t (tva, ra), Item_t (tvb, rb) -> + ty_eq tva tvb |> + record_trace (Inconsistent_stack_items lvl) >>? fun (Eq _) -> + stack_ty_eq (lvl + 1) ra rb >>? fun (Eq _) -> + (eq ta tb : (ta stack_ty, tb stack_ty) eq tzresult) + | Empty_t, Empty_t -> eq ta tb + | _, _ -> error Inconsistent_stack_lengths + +(* ---- Type checker resuls -------------------------------------------------*) + +type 'bef judgement = + | Typed : ('bef, 'aft) instr * 'aft stack_ty -> 'bef judgement + +(* ---- type checker --------------------------------------------------------*) + +type ex_comparable_ty = Ex : 'a comparable_ty -> ex_comparable_ty + +let parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult Lwt.t = function + | Prim (_, "int8", []) -> return @@ Ex (Int_key Int8) + | Prim (_, "int16", []) -> return @@ Ex (Int_key Int16) + | Prim (_, "int32", []) -> return @@ Ex (Int_key Int32) + | Prim (_, "int64", []) -> return @@ Ex (Int_key Int64) + | Prim (_, "uint8", []) -> return @@ Ex (Int_key Uint8) + | Prim (_, "uint16", []) -> return @@ Ex (Int_key Uint16) + | Prim (_, "uint32", []) -> return @@ Ex (Int_key Uint32) + | Prim (_, "uint64", []) -> return @@ Ex (Int_key Uint64) + | Prim (_, "string", []) -> return @@ Ex String_key + | Prim (_, "float", []) -> return @@ Ex Float_key + | Prim (_, "tez", []) -> return @@ Ex Tez_key + | Prim (_, "bool", []) -> return @@ Ex Bool_key + | Prim (_, "key", []) -> return @@ Ex Key_key + | Prim (_, "timestamp", []) -> return @@ Ex Timestamp_key + | Prim (loc, ("int8" | "int16" | "int32" | "int64" + | "uint8" | "uint16" | "uint32" | "uint64" + | "string" | "float" | "tez" | "bool" + | "key" | "timestamp" as prim), l) -> + fail @@ Invalid_arity (loc, Type, prim, 0, List.length l) + | Prim (loc, ("pair" | "union" | "set" | "map" + | "list" | "ref" | "option" | "lambda" + | "void" | "signature" | "contract"), _) -> + fail @@ Comparable_type_expected loc + | Prim (loc, prim, _) -> + fail @@ Invalid_primitive (loc, Type, prim) + | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> + fail @@ Invalid_expression_kind loc + +type ex_ty = Ex : 'a ty -> ex_ty + +let rec parse_ty : Script.expr -> ex_ty tzresult Lwt.t = function + | Prim (_, "void", []) -> return @@ Ex Void_t + | Prim (_, "int8", []) -> return @@ Ex (Int_t Int8) + | Prim (_, "int16", []) -> return @@ Ex (Int_t Int16) + | Prim (_, "int32", []) -> return @@ Ex (Int_t Int32) + | Prim (_, "int64", []) -> return @@ Ex (Int_t Int64) + | Prim (_, "uint8", []) -> return @@ Ex (Int_t Uint8) + | Prim (_, "uint16", []) -> return @@ Ex (Int_t Uint16) + | Prim (_, "uint32", []) -> return @@ Ex (Int_t Uint32) + | Prim (_, "uint64", []) -> return @@ Ex (Int_t Uint64) + | Prim (_, "string", []) -> return @@ Ex String_t + | Prim (_, "float", []) -> return @@ Ex Float_t + | Prim (_, "tez", []) -> return @@ Ex Tez_t + | Prim (_, "bool", []) -> return @@ Ex Bool_t + | Prim (_, "key", []) -> return @@ Ex Key_t + | Prim (_, "timestamp", []) -> return @@ Ex Timestamp_t + | Prim (_, "signature", []) -> return @@ Ex Signature_t + | Prim (_, "contract", [ utl; utr ]) -> + parse_ty utl >>=? fun (Ex tl) -> + parse_ty utr >>=? fun (Ex tr) -> + return @@ Ex (Contract_t (tl, tr)) + | Prim (_, "pair", [ utl; utr ]) -> + parse_ty utl >>=? fun (Ex tl) -> + parse_ty utr >>=? fun (Ex tr) -> + return @@ Ex (Pair_t (tl, tr)) + | Prim (_, "union", [ utl; utr ]) -> + parse_ty utl >>=? fun (Ex tl) -> + parse_ty utr >>=? fun (Ex tr) -> + return @@ Ex (Union_t (tl, tr)) + | Prim (_, "lambda", [ uta; utr ]) -> + parse_ty uta >>=? fun (Ex ta) -> + parse_ty utr >>=? fun (Ex tr) -> + return @@ Ex (Lambda_t (ta, tr)) + | Prim (_, "ref", [ ut ]) -> + parse_ty ut >>=? fun (Ex t) -> + return @@ Ex (Ref_t t) + | Prim (_, "option", [ ut ]) -> + parse_ty ut >>=? fun (Ex t) -> + return @@ Ex (Option_t t) + | Prim (_, "list", [ ut ]) -> + parse_ty ut >>=? fun (Ex t) -> + return @@ Ex (List_t t) + | Prim (_, "set", [ ut ]) -> + parse_comparable_ty ut >>=? fun (Ex t) -> + return @@ Ex (Set_t t) + | Prim (_, "map", [ uta; utr ]) -> + parse_comparable_ty uta >>=? fun (Ex ta) -> + parse_ty utr >>=? fun (Ex tr) -> + return @@ Ex (Map_t (ta, tr)) + | Prim (loc, ("pair" | "union" | "set" | "map" + | "list" | "ref" | "option" | "lambda" + | "void" | "signature" | "contract" + | "int8" | "int16" | "int32" | "int64" + | "uint8" | "uint16" | "uint32" | "uint64" + | "string" | "float" | "tez" | "bool" + | "key" | "timestamp" as prim), l) -> + fail @@ Invalid_arity (loc, Type, prim, 0, List.length l) + | Prim (loc, prim, _) -> + fail @@ Invalid_primitive (loc, Type, prim) + | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> + fail @@ Invalid_expression_kind loc + +let ty_of_comparable_ty + : type a. a comparable_ty -> a ty = function + | Int_key k -> Int_t k + | String_key -> String_t + | Float_key -> Float_t + | Tez_key -> Tez_t + | Bool_key -> Bool_t + | Key_key -> Key_t + | Timestamp_key -> Timestamp_t + +let comparable_ty_of_ty + : type a. a ty -> a comparable_ty tzresult = function + | Int_t k -> ok (Int_key k) + | String_t -> ok String_key + | Float_t -> ok Float_key + | Tez_t -> ok Tez_key + | Bool_t -> ok Bool_key + | Key_t -> ok Key_key + | Timestamp_t -> ok Timestamp_key + | ty -> error (Incomparable_type (Ty ty)) + +type ex_tagged_data = Ex : 'a ty * 'a -> ex_tagged_data + +let rec parse_tagged_data + : context -> Script.expr -> ex_tagged_data tzresult Lwt.t + = fun ctxt script_data -> + match script_data with + | Prim (_, "void", []) -> + return @@ Ex (Void_t, ()) + | Prim (loc, "void", l) -> + fail @@ Invalid_arity (loc, Constant, "void", 0, List.length l) + | String (_, v) -> + return @@ Ex (String_t, v) + | Prim (_, "string", [ arg ]) -> + parse_untagged_data ctxt String_t arg >>=? fun v -> + return @@ Ex (String_t, v) + | Prim (loc, "string", l) -> + fail @@ Invalid_arity (loc, Constant, "string", 1, List.length l) + | Prim (_, "true", []) -> + return @@ Ex (Bool_t, true) + | Prim (loc, "true", l) -> + fail @@ Invalid_arity (loc, Constant, "true", 0, List.length l) + | Prim (_, "false", []) -> + return @@ Ex (Bool_t, false) + | Prim (loc, "false", l) -> + fail @@ Invalid_arity (loc, Constant, "false", 0, List.length l) + | Prim (_, "bool", [ arg ]) -> + parse_untagged_data ctxt Bool_t arg >>=? fun v -> + return @@ Ex (Bool_t, v) + | Prim (loc, "bool", l) -> + fail @@ Invalid_arity (loc, Constant, "bool", 1, List.length l) + | Float (loc, v) -> begin try + return (Ex (Float_t, float_of_string v)) + with _ -> + fail @@ Invalid_constant (loc, "float") + end + | Prim (_, "float", [ arg ]) -> + parse_untagged_data ctxt Float_t arg >>=? fun v -> + return @@ Ex (Float_t, v) + | Prim (loc, "float", l) -> + fail @@ Invalid_arity (loc, Constant, "float", 1, List.length l) + | Prim (_, "timestamp", [ arg ]) -> + parse_untagged_data ctxt Timestamp_t arg >>=? fun v -> + return @@ Ex (Timestamp_t, v) + | Prim (loc, "timestamp", l) -> + fail @@ Invalid_arity (loc, Constant, "timestamp", 1, List.length l) + | Prim (_, "signature", [ arg ]) -> + parse_untagged_data ctxt Signature_t arg >>=? fun v -> + return @@ Ex (Signature_t, v) + | Prim (loc, "signature", l) -> + fail @@ Invalid_arity (loc, Constant, "signature", 1, List.length l) + | Prim (_, "tez", [ arg ]) -> + parse_untagged_data ctxt Tez_t arg >>=? fun v -> + return @@ Ex (Tez_t, v) + | Prim (loc, "tez", l) -> + fail @@ Invalid_arity (loc, Constant, "tez", 1, List.length l) + | Prim (_, "key", [ arg ]) -> + parse_untagged_data ctxt Key_t arg >>=? fun v -> + return @@ Ex (Key_t, v) + | Prim (loc, "key", l) -> + fail @@ Invalid_arity (loc, Constant, "key", 1, List.length l) + | Prim (_, "int8", [ arg ]) -> + parse_untagged_data ctxt (Int_t Int8) arg >>=? fun v -> + return @@ Ex (Int_t Int8, v) + | Prim (loc, "int8", l) -> + fail @@ Invalid_arity (loc, Constant, "int8", 1, List.length l) + | Prim (_, "int16", [ arg ]) -> + parse_untagged_data ctxt (Int_t Int16) arg >>=? fun v -> + return @@ Ex (Int_t Int16, v) + | Prim (loc, "int16", l) -> + fail @@ Invalid_arity (loc, Constant, "int16", 1, List.length l) + | Prim (_, "int32", [ arg ]) -> + parse_untagged_data ctxt (Int_t Int32) arg >>=? fun v -> + return @@ Ex (Int_t Int32, v) + | Prim (loc, "int32", l) -> + fail @@ Invalid_arity (loc, Constant, "int32", 1, List.length l) + | Prim (_, "int64", [ arg ]) -> + parse_untagged_data ctxt (Int_t Int64) arg >>=? fun v -> + return @@ Ex (Int_t Int64, v) + | Prim (loc, "int64", l) -> + fail @@ Invalid_arity (loc, Constant, "int64", 1, List.length l) + | Prim (_, "uint8", [ arg ]) -> + parse_untagged_data ctxt (Int_t Uint8) arg >>=? fun v -> + return @@ Ex (Int_t Uint8, v) + | Prim (loc, "uint8", l) -> + fail @@ Invalid_arity (loc, Constant, "uint8", 1, List.length l) + | Prim (_, "uint16", [ arg ]) -> + parse_untagged_data ctxt (Int_t Uint16) arg >>=? fun v -> + return @@ Ex (Int_t Uint16, v) + | Prim (loc, "uint16", l) -> + fail @@ Invalid_arity (loc, Constant, "uint16", 1, List.length l) + | Prim (_, "uint32", [ arg ]) -> + parse_untagged_data ctxt (Int_t Uint32) arg >>=? fun v -> + return @@ Ex (Int_t Uint32, v) + | Prim (loc, "uint32", l) -> + fail @@ Invalid_arity (loc, Constant, "uint32", 1, List.length l) + | Prim (_, "uint64", [ arg ]) -> + parse_untagged_data ctxt (Int_t Uint64) arg >>=? fun v -> + return @@ Ex (Int_t Uint64, v) + | Prim (loc, "uint64", l) -> + fail @@ Invalid_arity (loc, Constant, "uint64", 1, List.length l) + | Prim (_, "left", [ l; tr ]) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_tagged_data ctxt l >>=? fun (Ex (tl, l)) -> + return @@ Ex (Union_t (tl, tr), L l) + | Prim (loc, "left", l) -> + fail @@ Invalid_arity (loc, Constant, "left", 2, List.length l) + | Prim (_, "right", [ tl; r ]) -> + parse_ty tl >>=? fun (Ex tl) -> + parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> + return @@ Ex (Union_t (tl, tr), R r) + | Prim (loc, "right", l) -> + fail @@ Invalid_arity (loc, Constant, "right", 2, List.length l) + | Prim (_, "or", [ tl; tr; arg ]) -> + parse_ty tl >>=? fun (Ex tl) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_untagged_data ctxt (Union_t (tl, tr)) arg >>=? fun v -> + return @@ Ex (Union_t (tl, tr), v) + | Prim (loc, "or", l) -> + fail @@ Invalid_arity (loc, Constant, "or", 3, List.length l) + | Prim (_, "ref", [ r ]) -> + parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> + return @@ Ex (Ref_t tr, ref r) + | Prim (_, "ref", [ tr; r ]) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_untagged_data ctxt tr r >>=? fun r -> + return @@ Ex (Ref_t tr, ref r) + | Prim (loc, "ref", l) -> + fail @@ Invalid_arity (loc, Constant, "ref", 1, List.length l) + | Prim (_, "some", [ r ]) -> + parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> + return @@ Ex (Option_t tr, Some r) + | Prim (_, "some", [ tr; r ]) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_untagged_data ctxt tr r >>=? fun r -> + return @@ Ex (Option_t tr, Some r) + | Prim (loc, "some", l) -> + fail @@ Invalid_arity (loc, Constant, "some", 1, List.length l) + | Prim (_, "none", [ tr ]) -> + parse_ty tr >>=? fun (Ex tr) -> + return @@ Ex (Option_t tr, None) + | Prim (loc, "none", l) -> + fail @@ Invalid_arity (loc, Constant, "none", 1, List.length l) + | Prim (_, "option", [ tr; r ]) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_untagged_data ctxt (Option_t tr) r >>=? fun r -> + return @@ Ex (Option_t tr, r) + | Prim (loc, "option", l) -> + fail @@ Invalid_arity (loc, Constant, "option", 2, List.length l) + | Prim (_, "pair", [ tl; tr; l; r ]) -> + parse_ty tl >>=? fun (Ex tl) -> + parse_ty tr >>=? fun (Ex tr) -> + parse_untagged_data ctxt tl l >>=? fun l -> + parse_untagged_data ctxt tr r >>=? fun r -> + return @@ Ex (Pair_t (tl, tr), (l, r)) + | Prim (_, "pair", [ l; r ]) -> + parse_tagged_data ctxt l >>=? fun (Ex (tl, l)) -> + parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> + return @@ Ex (Pair_t (tl, tr), (l, r)) + | Prim (loc, "pair", l) -> + fail @@ Invalid_arity (loc, Constant, "pair", 4, List.length l) + | Prim (loc, "list", t :: items) -> + parse_ty t >>=? fun (Ex t) -> + parse_untagged_data ctxt + (List_t t) (Prim (loc, "list", items)) >>=? fun l -> + return @@ Ex (List_t t, l) + | Prim (loc, "list", l) -> + fail @@ Invalid_arity (loc, Constant, "list", 1, List.length l) + | Prim (loc, "set", t :: items) -> + parse_comparable_ty t >>=? fun (Ex t) -> + parse_untagged_data ctxt + (Set_t t) (Prim (loc, "set", items)) >>=? fun l -> + return @@ Ex (Set_t t, l) + | Prim (loc, "set", l) -> + fail @@ Invalid_arity (loc, Constant, "set", 1, List.length l) + | Prim (loc, "map", kt :: vt :: items) -> + parse_comparable_ty kt >>=? fun (Ex kt) -> + parse_ty vt >>=? fun (Ex vt) -> + parse_untagged_data ctxt + (Map_t (kt, vt)) (Prim (loc, "map", items)) >>=? fun l -> + return @@ Ex (Map_t (kt, vt), l) + | Prim (loc, "map", l) -> + fail @@ Invalid_arity (loc, Constant, "map", 2, List.length l) + | Prim (_, "contract", [ at; rt; c ]) -> + parse_ty at >>=? fun (Ex at) -> + parse_ty rt >>=? fun (Ex rt) -> + parse_untagged_data ctxt (Contract_t (at, rt)) c >>=? fun l -> + return @@ Ex (Contract_t (at, rt), l) + | Prim (loc, "contract", l) -> + fail @@ Invalid_arity (loc, Constant, "contract", 3, List.length l) + | Prim (loc, "lambda", [ at ; rt ; code ]) -> + expect_sequence_parameter loc Constant "lambda" 2 code >>=? fun () -> + parse_ty at >>=? fun (Ex at) -> + parse_ty rt >>=? fun (Ex rt) -> + parse_untagged_data ctxt (Lambda_t (at, rt)) code >>=? fun l -> + return @@ Ex (Lambda_t (at, rt), l) + | Prim (loc, "lambda", l) -> + fail @@ Invalid_arity (loc, Constant, "lambda", 3, List.length l) + | Prim (loc, name, _) -> + fail @@ Invalid_primitive (loc, Constant, name) + | Seq (loc, _) | Int (loc, _) -> + fail @@ Invalid_expression_kind loc + +and parse_untagged_data + : type a. context -> a ty -> Script.expr -> a tzresult Lwt.t + = fun ctxt ty script_data -> + match ty, script_data with + (* Void *) + | Void_t, Prim (_, "void", []) -> return () + | Void_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Float (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "void") + (* Strings *) + | String_t, String (_, v) -> return v + | String_t, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "string") + (* Floats *) + | Float_t, Float (loc, v) -> begin try + return (float_of_string v) + with _ -> + fail @@ Invalid_constant (loc, "float") + end + | Float_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "float") + (* Booleans *) + | Bool_t, Prim (_, "true", []) -> return true + | Bool_t, Prim (_, "false", []) -> return false + | Bool_t, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "bool") + (* Integers *) + | Int_t k, Int (loc, v) -> begin try + match checked_of_int64 k (Int64.of_string v) with + | None -> raise Exit + | Some i -> return i + with _ -> fail @@ Invalid_constant (loc, string_of_int_kind k) + end + | Int_t k, (Float (loc, _) | Prim (loc, _, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, string_of_int_kind k) + (* Tez amounts *) + | Tez_t, Int (loc, v) -> begin try + match Tez.of_string v with + | None -> raise Exit + | Some tez -> return tez + with _ -> + fail @@ Invalid_constant (loc, "tez") + end + | Tez_t, (Float (loc, _) | Prim (loc, _, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "tez") + (* Timestamps *) + | Timestamp_t, (Float (loc, v) | Int (loc, v)) -> begin + match (Timestamp.of_seconds v) with + | Some v -> return v + | None -> fail @@ Invalid_constant (loc, "timestamp") + end + | Timestamp_t, String (loc, s) -> begin try + match Timestamp.of_notation s with + | Some v -> return v + | None-> fail @@ Invalid_constant (loc, "timestamp") + with _ -> fail @@ Invalid_constant (loc, "timestamp") + end + | Timestamp_t, (Prim (loc, _, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "timestamp") + (* IDs *) + | Key_t, String (loc, s) -> begin try + return (Ed25519.Public_key_hash.of_b48check s) + with _ -> fail @@ Invalid_constant (loc, "key") + end + | Key_t, (Prim (loc, _, _) | Seq (loc, _) | Int (loc, _) | Float (loc, _)) -> + fail @@ Invalid_constant (loc, "key") + (* Signatures *) + | Signature_t, String (loc, s) -> begin try + match Data_encoding.Binary.of_bytes + Ed25519.signature_encoding + (MBytes.of_string (Hex_encode.hex_decode s)) with + | Some s -> return s + | None -> raise Not_found + with _ -> + fail @@ Invalid_constant (loc, "signature") + end + | Signature_t, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "signature") + (* Contracts *) + | Contract_t (ty1, ty2), String (loc, s) -> + trace + (Invalid_constant (loc, "contract")) + (Lwt.return (Contract.of_b48check s)) >>=? fun c -> + parse_contract ctxt ty1 ty2 loc c >>=? fun _ -> + return (ty1, ty2, c) + | Contract_t _, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "contract") + (* Pairs *) + | Pair_t (ta, tb), Prim (_, "pair", [ va; vb ]) -> + parse_untagged_data ctxt ta va >>=? fun va -> + parse_untagged_data ctxt tb vb >>=? fun vb -> + return (va, vb) + | Pair_t _, Prim (loc, "pair", l) -> + fail @@ Invalid_arity (loc, Constant, "pair", 2, List.length l) + | Pair_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "pair") + (* Unions *) + | Union_t (tl, _), Prim (_, "left", [ v ]) -> + parse_untagged_data ctxt tl v >>=? fun v -> + return (L v) + | Union_t _, Prim (loc, "left", l) -> + fail @@ Invalid_arity (loc, Constant, "left", 1, List.length l) + | Union_t (_, tr), Prim (_, "right", [ v ]) -> + parse_untagged_data ctxt tr v >>=? fun v -> + return (R v) + | Union_t _, Prim (loc, "right", l) -> + fail @@ Invalid_arity (loc, Constant, "right", 1, List.length l) + | Union_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "union") + (* Lambdas *) + | Lambda_t (ta, tr), (Seq _ as script_instr) -> + parse_lambda ctxt ta tr script_instr + | Lambda_t (_, _), (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _)) -> + fail @@ Invalid_constant (loc, "lambda") + (* References *) + | Ref_t t, Prim (_, "ref", [ v ]) -> + parse_untagged_data ctxt t v >>=? fun v -> + return (ref v) + | Ref_t _, Prim (loc, "ref", l) -> + fail @@ Invalid_arity (loc, Constant, "ref", 1, List.length l) + | Ref_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "ref") + (* Options *) + | Option_t t, Prim (_, "some", [ v ]) -> + parse_untagged_data ctxt t v >>=? fun v -> + return (Some v) + | Option_t _, Prim (loc, "some", l) -> + fail @@ Invalid_arity (loc, Constant, "some", 1, List.length l) + | Option_t _, Prim (_, "none", []) -> + return None + | Option_t _, Prim (loc, "none", l) -> + fail @@ Invalid_arity (loc, Constant, "none", 0, List.length l) + | Option_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "option") + (* Lists *) + | List_t t, Prim (_, "list", vs) -> + fold_left_s + (fun rest v -> + parse_untagged_data ctxt t v >>=? fun v -> + return (v :: rest)) + [] vs + | List_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "list") + (* Sets *) + | Set_t t, Prim (_, "set", vs) -> + fold_left_s + (fun rest v -> + parse_untagged_comparable_data ctxt t v >>=? fun v -> + return (v :: rest)) + [] vs >>=? fun v -> + return (ref v, t) + | Set_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "set") + (* Maps *) + | Map_t (tk, tv), Prim (_, "map", vs) -> + fold_left_s + (fun rest -> function + | Prim (_, "item", [ k; v ]) -> + parse_untagged_comparable_data ctxt tk k >>=? fun k -> + parse_untagged_data ctxt tv v >>=? fun v -> + return ((k, v) :: rest) + | Prim (loc, "item", l) -> + fail @@ Invalid_arity (loc, Constant, "item", 2, List.length l) + | Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> + fail @@ Invalid_constant (loc, "item")) + [] vs >>=? fun v -> + return (ref v, tk) + | Map_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> + fail @@ Invalid_constant (loc, "map") + +and parse_untagged_comparable_data + : type a. context -> a comparable_ty -> Script.expr -> a tzresult Lwt.t + = fun ctxt ty script_data -> + parse_untagged_data ctxt (ty_of_comparable_ty ty) script_data + +and parse_lambda + : type arg ret storage. context -> + ?storage_type: storage ty -> + arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = + fun ctxt ?storage_type arg ret script_instr -> + let loc = location script_instr in + parse_instr ctxt ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function + | Typed (instr, (Item_t (ty, Empty_t) as stack_ty)) -> + trace + (Bad_return (loc, Stack_ty stack_ty, Ty ret)) + (Lwt.return (ty_eq ty ret)) >>=? fun (Eq _) -> + return (Lam (instr, script_instr) : (arg, ret) lambda) + | Typed (_, stack_ty) -> + fail (Bad_return (loc, Stack_ty stack_ty, Ty ret)) + +and parse_instr + : type bef storage. context -> + ?storage_type: storage ty -> + Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t = + fun ctxt ?storage_type script_instr stack_ty -> + let return : bef judgement -> bef judgement tzresult Lwt.t = return in + let check_item_ty got exp pos n = + ty_eq got exp |> record_trace (Bad_stack_item (pos, n)) |> Lwt.return in + (* TODO: macros *) + match script_instr, stack_ty with + (* stack ops *) + | Prim (_, "drop", []), Item_t (_, rest) -> + return (Typed (Drop, rest)) + | Prim (_, "dup", []), Item_t (v, rest) -> + return (Typed (Dup, Item_t (v, Item_t (v, rest)))) + | Prim (_, "swap", []), Item_t (v, Item_t (w, rest)) -> + return (Typed (Swap, Item_t (w, Item_t (v, rest)))) + | Prim (_, "push", [ td ]), rest -> + parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> + return (Typed (Const v, Item_t (t, rest))) + (* options *) + | Prim (_, "some", []), Item_t (t, rest) -> + return (Typed (Cons_some, Item_t (Option_t t, rest))) + | Prim (_, "none", [ t ]), rest -> + parse_ty t >>=? fun (Ex t) -> + return (Typed (Cons_none t, Item_t (Option_t t, rest))) + | Prim (loc, "if_none", [ bt ; bf ]), Item_t (Option_t t, rest) -> + expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt rest >>=? fun (Typed (ibt, aftbt)) -> + parse_instr ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun (Typed (ibf, aftbf)) -> + trace + (Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf)) + (Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) -> + return (Typed (If_none (ibt, ibf), aftbt)) + (* pairs *) + | Prim (_, "pair", []), Item_t (a, Item_t (b, rest)) -> + return (Typed (Cons_pair, Item_t (Pair_t(a, b), rest))) + | Prim (_, "car", []), Item_t (Pair_t (a, _), rest) -> + return (Typed (Car, Item_t (a, rest))) + | Prim (_, "cdr", []), Item_t (Pair_t (_, b), rest) -> + return (Typed (Cdr, Item_t (b, rest))) + (* unions *) + | Prim (_, "left", [ tr ]), Item_t (tl, rest) -> + parse_ty tr >>=? fun (Ex tr) -> + return (Typed (Left, Item_t (Union_t (tl, tr), rest))) + | Prim (_, "right", [ tl ]), Item_t (tr, rest) -> + parse_ty tl >>=? fun (Ex tl) -> + return (Typed (Right, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "if_left", [ bt ; bf ]), Item_t (Union_t (tl, tr), rest) -> + expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun (Typed (ibt, aftbt)) -> + parse_instr ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun (Typed (ibf, aftbf)) -> + trace + (Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf)) + (Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) -> + return (Typed (If_left (ibt, ibf), aftbt)) + (* lists *) + | Prim (_, "nil", [ t ]), rest -> + parse_ty t >>=? fun (Ex t) -> + return (Typed (Nil, Item_t (List_t t, rest))) + | Prim (loc, "cons", []), Item_t (tv, Item_t (List_t t, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (ty_eq t tv)) >>=? fun (Eq _) -> + return (Typed (Cons_list, Item_t (List_t t, rest))) + | Prim (loc, "if_cons", [ bt ; bf ]), Item_t (List_t t, rest) -> + expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun (Typed (ibt, aftbt)) -> + parse_instr ?storage_type ctxt bf rest >>=? fun (Typed (ibf, aftbf)) -> + trace + (Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf)) + (Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) -> + return (Typed (If_cons (ibt, ibf), aftbt)) + | Prim (loc, "iter", []), Item_t (Lambda_t (param, Void_t), Item_t (List_t elt, rest)) -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (List_iter, rest)) + | Prim (loc, "map", []), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (List_map, Item_t (List_t ret, rest))) + | Prim (loc, "reduce", []), Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (List_t elt, Item_t (init, rest))) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (List_reduce, Item_t (r, rest))) + (* sets *) + | Prim (_, "empty_set", [ t ]), rest -> + parse_comparable_ty t >>=? fun (Ex t) -> + return (Typed (Empty_set t, Item_t (Set_t t, rest))) + | Prim (loc, "iter", []), Item_t (Lambda_t (param, Void_t), Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (Set_iter, rest)) + | Prim (loc, "map", []), Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (Set_map ret, Item_t (Set_t ret, rest))) + | Prim (loc, "reduce", []), Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (Set_t elt, Item_t (init, rest))) -> + let elt = ty_of_comparable_ty elt in + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (Set_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), Item_t (v, Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt v loc 2 >>=? fun (Eq _) -> + return (Typed (Set_mem, Item_t (Bool_t, rest))) + | Prim (loc, "update", []), Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt v loc 3 >>=? fun (Eq _) -> + return (Typed (Set_update, rest)) + (* maps *) + | Prim (_, "empty_map", [ tk ; tv ]), rest -> + parse_comparable_ty tk >>=? fun (Ex tk) -> + parse_ty tv >>=? fun (Ex tv) -> + return (Typed (Empty_map (tk, tv), Item_t (Map_t (tk, tv), rest))) + | Prim (loc, "iter", []), Item_t (Lambda_t (Pair_t (pk, pv), Void_t), Item_t (Map_t (k, v), rest)) -> + let k = ty_of_comparable_ty k in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_iter, rest)) + | Prim (loc, "map", []), Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_map, Item_t (Map_t (ck, ret), rest))) + | Prim (loc, "reduce", []), Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), + Item_t (Map_t (ck, v), Item_t (init, rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (Map_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), Item_t (vk, Item_t (Map_t (ck, _), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (Typed (Map_mem, Item_t (Bool_t, rest))) + | Prim (loc, "get", []), Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (Typed (Map_get, Item_t (Option_t elt, rest))) + | Prim (loc, "update", []), Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + check_item_ty vv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_update, rest)) + (* reference cells *) + | Prim (_, "ref", []), Item_t (t, rest) -> + return (Typed (Ref, Item_t (Ref_t t, rest))) + | Prim (_, "deref", []), Item_t (Ref_t t, rest) -> + return (Typed (Deref, Item_t (t, rest))) + | Prim (loc, "set", []), Item_t (Ref_t t, Item_t (tv, rest)) -> + check_item_ty tv t loc 2 >>=? fun (Eq _) -> + return (Typed (Set, rest)) + (* control *) + | Seq (_, []), rest -> + return (Typed (Nop, rest)) + | Seq (_, [ single ]), stack_ty -> + parse_instr ?storage_type ctxt single stack_ty + | Seq (loc, hd :: tl), stack_ty -> + parse_instr ?storage_type ctxt hd stack_ty >>=? fun (Typed (ihd, trans)) -> + parse_instr ?storage_type ctxt (Seq (loc, tl)) trans >>=? fun (Typed (itl, aft)) -> + return (Typed (Seq (ihd, itl), aft)) + | Prim (loc, "if", [ bt ; bf ]), Item_t (Bool_t, rest) -> + expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt rest >>=? fun (Typed (ibt, aftbt)) -> + parse_instr ?storage_type ctxt bf rest >>=? fun (Typed (ibf, aftbf)) -> + trace + (Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf)) + (Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) -> + return (Typed (If (ibt, ibf), aftbt)) + | Prim (loc, "loop", [ body ]), Item_t (Bool_t, rest) -> + expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () -> + parse_instr ?storage_type ctxt body rest >>=? fun (Typed (ibody, aftbody)) -> + trace + (Unmatched_branches (loc, Stack_ty aftbody, Stack_ty stack_ty)) + (Lwt.return (stack_ty_eq 0 aftbody stack_ty)) >>=? fun (Eq _) -> + return (Typed (Loop ibody, rest)) + | Prim (loc, "lambda", [ arg ; ret ; code ]), rest -> + parse_ty arg >>=? fun (Ex arg) -> + parse_ty ret >>=? fun (Ex ret) -> + expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () -> + parse_lambda ctxt arg ret code >>=? fun (lambda) -> + return (Typed (Lambda lambda, Item_t (Lambda_t (arg, ret), rest))) + | Prim (loc, "exec", []), Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> + check_item_ty arg param loc 1 >>=? fun (Eq _) -> + return (Typed (Exec, Item_t (ret, rest))) + | Prim (loc, "dip", [ code ]), Item_t (v, rest) -> + expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () -> + parse_instr ctxt code rest >>=? fun (Typed (instr, aft_rest)) -> + return (Typed (Dip instr, Item_t (v, aft_rest))) + | Prim (loc, "fail", []), rest -> + return (Typed (Fail loc, rest)) (* FIXME *) + | Prim (_, "nop", []), rest -> + return (Typed (Nop, rest)) + (* timestamp operations *) + | Prim (_, "add", []), Item_t (Timestamp_t, Item_t (Float_t, rest)) -> + return (Typed (Add_timestamp_to_period, Item_t (Timestamp_t, rest))) + | Prim (loc, "add", []), Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> + trace (Bad_stack_item (loc, 2)) (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest))) + | Prim (_, "add", []), Item_t (Float_t, Item_t (Timestamp_t, rest)) -> + return (Typed (Add_period_to_timestamp, Item_t (Timestamp_t, rest))) + | Prim (loc, "add", []), Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Add_seconds_to_timestamp (kind, loc), Item_t (Timestamp_t, rest))) + (* string operations *) + | Prim (_, "concat", []), Item_t (String_t, Item_t (String_t, rest)) -> + return (Typed (Concat, Item_t (String_t, rest))) + (* currency operations *) + | Prim (_, "add", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Add_tez, Item_t (Tez_t, rest))) + | Prim (_, "sub", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Sub_tez, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), Item_t (Tez_t, Item_t (Int_t kind, rest)) -> + trace (Bad_stack_item (loc, 2)) (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Mul_tez kind, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), Item_t (Int_t kind, Item_t (Tez_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Mul_tez' kind, Item_t (Tez_t, rest))) + (* float operations *) + | Prim (_, "floor", []), Item_t (Float_t, rest) -> + return (Typed (Floor, Item_t (Float_t, rest))) + | Prim (_, "ceil", []), Item_t (Float_t, rest) -> + return (Typed (Ceil, Item_t (Float_t, rest))) + | Prim (_, "inf", []), rest -> + return (Typed (Inf, Item_t (Float_t, rest))) + | Prim (_, "nan", []), rest -> + return (Typed (NaN, Item_t (Float_t, rest))) + | Prim (_, "isnan", []), Item_t (Float_t, rest) -> + return (Typed (IsNaN, Item_t (Bool_t, rest))) + | Prim (loc, "nanan", []), Item_t (Float_t, rest) -> + return (Typed (NaNaN loc, rest)) + | Prim (_, "abs", []), Item_t (Float_t, rest) -> + return (Typed (Abs_float, Item_t (Float_t, rest))) + | Prim (_, "neg", []), Item_t (Float_t, rest) -> + return (Typed (Neg_float, Item_t (Float_t, rest))) + | Prim (_, "add", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Add_float, Item_t (Float_t, rest))) + | Prim (_, "sub", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Sub_float, Item_t (Float_t, rest))) + | Prim (_, "mul", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Mul_float, Item_t (Float_t, rest))) + | Prim (_, "div", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Div_float, Item_t (Float_t, rest))) + | Prim (_, "mod", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Mod_float, Item_t (Float_t, rest))) + (* boolean operations *) + | Prim (_, "or", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Or, Item_t (Bool_t, rest))) + | Prim (_, "and", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (And, Item_t (Bool_t, rest))) + | Prim (_, "xor", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Xor, Item_t (Bool_t, rest))) + | Prim (_, "not", []), Item_t (Bool_t, rest) -> + return (Typed (Not, Item_t (Bool_t, rest))) + (* integer operations *) + | Prim (loc, "checked_abs", []), Item_t (Int_t k, rest) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Checked_abs_int (k, loc), Item_t (Int_t k, rest))) + | Prim (loc, "checked_neg", []), Item_t (Int_t k, rest) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Checked_neg_int (k, loc), Item_t (Int_t k, rest))) + | Prim (loc, "checked_add", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_add_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "checked_sub", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_sub_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "checked_mul", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_mul_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "abs", []), Item_t (Int_t k, rest) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Abs_int k, Item_t (Int_t k, rest))) + | Prim (loc, "neg", []), Item_t (Int_t k, rest) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Neg_int k, Item_t (Int_t k, rest))) + | Prim (loc, "add", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Add_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "sub", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Sub_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "mul", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Mul_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "div", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Div_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "mod", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Mod_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "lsl", []), Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Lsl_int k, Item_t (Int_t k, rest))) + | Prim (loc, "lsr", []), Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Lsr_int k, Item_t (Int_t k, rest))) + | Prim (loc, "or", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Or_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "and", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (And_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "xor", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Xor_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "not", []), Item_t (Int_t k, rest) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Not_int k, Item_t (Int_t k, rest))) + (* comparison *) + | Prim (loc, "compare", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Compare (Int_key kl), Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (String_t, Item_t (String_t, rest)) -> + return (Typed (Compare String_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (Float_t, Item_t (Float_t, rest)) -> + return (Typed (Compare Float_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (Key_t, Item_t (Key_t, rest)) -> + return (Typed (Compare Key_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> + return (Typed (Compare Timestamp_key, Item_t (Int_t Int64, rest))) + (* comparators *) + | Prim (_, "eq", []), Item_t (Int_t Int64, rest) -> + return (Typed (Eq, Item_t (Bool_t, rest))) + | Prim (_, "neq", []), Item_t (Int_t Int64, rest) -> + return (Typed (Neq, Item_t (Bool_t, rest))) + | Prim (_, "lt", []), Item_t (Int_t Int64, rest) -> + return (Typed (Lt, Item_t (Bool_t, rest))) + | Prim (_, "gt", []), Item_t (Int_t Int64, rest) -> + return (Typed (Gt, Item_t (Bool_t, rest))) + | Prim (_, "le", []), Item_t (Int_t Int64, rest) -> + return (Typed (Le, Item_t (Bool_t, rest))) + | Prim (_, "ge", []), Item_t (Int_t Int64, rest) -> + return (Typed (Ge, Item_t (Bool_t, rest))) + (* casts *) + | Prim (loc, "checked_cast", [ t ]), stack_ty -> + parse_ty t >>=? fun (Ex ty) -> begin match ty, stack_ty with + | Int_t kt, Item_t (Int_t kf, rest) -> + return (Typed (Checked_int_of_int (kf, kt, loc), Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack_ty)) + end + | Prim (loc, "cast", [ t ]), stack_ty -> + parse_ty t >>=? fun (Ex ty) -> begin match ty,stack_ty with + | Int_t kt, Item_t (Int_t kf, rest) -> + return (Typed (Int_of_int (kf, kt), Item_t (Int_t kt, rest))) + | Float_t, Item_t (Int_t kf, rest) -> + return (Typed (Float_of_int kf, Item_t (Float_t, rest))) + | Int_t kt, Item_t (Float_t, rest) -> + return (Typed (Int_of_float kt, Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack_ty)) + end + (* protocol *) + | Prim (_, "manager", []), Item_t (Contract_t _, rest) -> + return (Typed (Manager, Item_t (Key_t, rest))) + | Prim (loc, "transfer_funds", []), + Item_t (p, Item_t (Tez_t, Item_t (Contract_t (cp, cr), Item_t (storage, Empty_t)))) -> + check_item_ty p cp loc 1 >>=? fun (Eq _) -> + begin match storage_type with + | Some storage_type -> + check_item_ty storage storage_type loc 3 >>=? fun (Eq _) -> + return (Typed (Transfer_funds (storage, loc), Item_t (cr, Item_t (storage, Empty_t)))) + | None -> + fail (Transfer_in_lambda loc) + end + | Prim (_, "create_account", []), + Item_t (Key_t, Item_t (Option_t Key_t, Item_t (Bool_t, Item_t (Tez_t, rest)))) -> + return (Typed (Create_account, Item_t (Contract_t (Void_t, Void_t), rest))) + | Prim (loc, "create_contract", []), + Item_t (Key_t, Item_t (Option_t Key_t, Item_t (Bool_t, Item_t (Tez_t, + Item_t (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), Pair_t (r, gr)), + Item_t (ginit, rest)))))) -> + check_item_ty gp gr loc 5 >>=? fun (Eq _) -> + check_item_ty ginit gp loc 6 >>=? fun (Eq _) -> + return (Typed (Create_contract (gp, p, r), + Item_t (Contract_t (p, r), rest))) + | Prim (_, "now", []), rest -> + return (Typed (Now, Item_t (Timestamp_t, rest))) + | Prim (_, "amount", []), rest -> + return (Typed (Amount, Item_t (Tez_t, rest))) + | Prim (_, "balance", []), rest -> + return (Typed (Balance, Item_t (Tez_t, rest))) + | Prim (_, "check_signature", []), Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> + return (Typed (Check_signature, Item_t (Bool_t, rest))) + | Prim (_, "h", []), Item_t (t, rest) -> + return (Typed (H t, Item_t (String_t, rest))) + | Prim (_, "steps_to_quota", []), rest -> + return (Typed (Steps_to_quota, Item_t (Int_t Uint32, rest))) + | Prim (_, "source", [ ta; tb ]), rest -> + parse_ty ta >>=? fun (Ex ta) -> + parse_ty tb >>=? fun (Ex tb) -> + return (Typed (Source (ta, tb), Item_t (Contract_t (ta, tb), rest))) + (* Primitive parsing errors *) + | Prim (loc, ("drop" | "dup" | "swap" | "some" + | "pair" | "car" | "cdr" | "cons" + | "mem" | "update" | "iter" | "map" | "reduce" + | "get" | "ref" | "deref" + | "set" | "exec" | "fail" | "nop" + | "concat" | "add" | "sub" + | "mul" | "floor" | "ceil" | "inf" + | "nan" | "isnan" | "nanan" + | "div" | "mod" | "or" | "and" | "xor" + | "not" | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" + | "abs" | "neg" | "lsl" | "lsr" + | "compare" | "eq" | "neq" + | "lt" | "gt" | "le" | "ge" + | "manager" | "transfer_funds" | "create_account" + | "create_contract" | "now" | "amount" | "balance" + | "check_signature" | "h" | "steps_to_quota" + as name), (_ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 0, List.length l)) + | Prim (loc, ( "push" | "none" | "left" | "right" | "nil" + | "empty_set" | "dip" | "checked_cast" | "cast" | "loop" + as name), ([] | _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 1, List.length l)) + | Prim (loc, ("if_none" | "if_left" | "if_cons" + | "empty_map" | "if" | "source" + as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 2, List.length l)) + | Prim (loc, "lambda", ([] | [ _ ] | [ _; _ ] | _ :: _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, "lambda", 3, List.length l)) + (* Stack errors *) + | Prim (loc, ("add" | "sub" | "mul" | "div" | "mod" + | "and" | "or" | "xor" | "lsl" | "lsr" + | "concat" | "compare" + | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" as name), []), + Item_t (ta, Item_t (tb, _)) -> + fail (Undefined_binop (loc, name, Ty ta, Ty tb)) + | Prim (loc, ("neg" | "abs" | "not" | "floor" | "ceil" + | "isnan" | "nanan" | "eq" + | "neq" | "lt" | "gt" | "le" | "ge" as name), []), + Item_t (t, _) -> + fail (Undefined_unop (loc, name, Ty t)) + | Prim (loc, ("reduce" | "update"), []), _ -> + fail (Bad_stack (loc, 3, Stack_ty stack_ty)) + | Prim (loc, "create_contract", []), _ -> + fail (Bad_stack (loc, 6, Stack_ty stack_ty)) + | Prim (loc, "create_account", []), _ -> + fail (Bad_stack (loc, 4, Stack_ty stack_ty)) + | Prim (loc, "transfer_funds", []), _ -> + fail (Bad_stack (loc, 3, Stack_ty stack_ty)) + | Prim (loc, ("drop" | "dup" | "car" | "cdr" | "some" | "h" | "dip" + | "if_none" | "left" | "right" | "if_left" | "if" + | "loop" | "if_cons" | "ref" | "deref" | "manager" + | "neg" | "abs" | "not" | "floor" | "ceil" | "isnan" | "nanan" + | "eq" | "neq" | "lt" | "gt" | "le" | "ge"), _), _ -> + fail (Bad_stack (loc, 1, Stack_ty stack_ty)) + | Prim (loc, ("swap" | "pair" | "cons" | "set" | "incr" | "decr" + | "map" | "iter" | "get" | "mem" | "exec" + | "check_signature" | "add" | "sub" | "mul" + | "div" | "mod" | "and" | "or" | "xor" + | "lsl" | "lsr" | "concat" + | "checked_abs" | "checked_neg" | "checked_add" + | "checked_sub" | "checked_mul" | "compare"), _), _ -> + fail (Bad_stack (loc, 2, Stack_ty stack_ty)) + (* Generic parsing errors *) + | Prim (loc, prim, _), _ -> + fail @@ Invalid_primitive (loc, Instr, prim) + | (Float (loc, _) | Int (loc, _) | String (loc, _)), _ -> + fail @@ Invalid_expression_kind loc + +and parse_contract + : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> + (arg, ret) typed_contract tzresult Lwt.t + = fun ctxt arg ret loc contract -> + Contract.exists ctxt contract >>=? function + | false -> fail (Invalid_contract (loc, contract)) + | true -> + trace + (Invalid_contract (loc, contract)) @@ + Contract.get_script ctxt contract >>=? function + | No_script -> + (Lwt.return + (ty_eq arg Void_t >>? fun (Eq _) -> + ty_eq ret Void_t >>? fun (Eq _) -> + let contract : (arg, ret) typed_contract = + (arg, ret, contract) in + ok contract)) + | Script { code = { arg_type; ret_type} } -> + parse_ty arg_type >>=? fun (Ex targ) -> + parse_ty ret_type >>=? fun (Ex tret) -> + trace + (Invalid_contract (loc, contract)) + (Lwt.return + (ty_eq targ arg >>? fun (Eq _) -> + ty_eq tret ret >>? fun (Eq _) -> + let contract : (arg, ret) typed_contract = + (arg, ret, contract) in + ok contract)) + +let unparse_comparable_ty + : type a. a comparable_ty -> Script.expr = function + | Int_key Int8 -> Prim (-1, "int8", []) + | Int_key Int16 -> Prim (-1, "int16", []) + | Int_key Int32 -> Prim (-1, "int32", []) + | Int_key Int64 -> Prim (-1, "int64", []) + | Int_key Uint8 -> Prim (-1, "uint8", []) + | Int_key Uint16 -> Prim (-1, "uint16", []) + | Int_key Uint32 -> Prim (-1, "uint32", []) + | Int_key Uint64 -> Prim (-1, "uint64", []) + | String_key -> Prim (-1, "string", []) + | Float_key -> Prim (-1, "float", []) + | Tez_key -> Prim (-1, "tez", []) + | Bool_key -> Prim (-1, "bool", []) + | Key_key -> Prim (-1, "key", []) + | Timestamp_key -> Prim (-1, "timestamp", []) + +let rec unparse_ty + : type a. a ty -> Script.expr = function + | Void_t -> Prim (-1, "void", []) + | Int_t Int8 -> Prim (-1, "int8", []) + | Int_t Int16 -> Prim (-1, "int16", []) + | Int_t Int32 -> Prim (-1, "int32", []) + | Int_t Int64 -> Prim (-1, "int64", []) + | Int_t Uint8 -> Prim (-1, "uint8", []) + | Int_t Uint16 -> Prim (-1, "uint16", []) + | Int_t Uint32 -> Prim (-1, "uint32", []) + | Int_t Uint64 -> Prim (-1, "uint64", []) + | String_t -> Prim (-1, "string", []) + | Float_t -> Prim (-1, "float", []) + | Tez_t -> Prim (-1, "tez", []) + | Bool_t -> Prim (-1, "bool", []) + | Key_t -> Prim (-1, "key", []) + | Timestamp_t -> Prim (-1, "timestamp", []) + | Signature_t -> Prim (-1, "signature", []) + | Contract_t (utl, utr) -> + let tl = unparse_ty utl in + let tr = unparse_ty utr in + Prim (-1, "contract", [ tl; tr ]) + | Pair_t (utl, utr) -> + let tl = unparse_ty utl in + let tr = unparse_ty utr in + Prim (-1, "pair", [ tl; tr ]) + | Union_t (utl, utr) -> + let tl = unparse_ty utl in + let tr = unparse_ty utr in + Prim (-1, "union", [ tl; tr ]) + | Lambda_t (uta, utr) -> + let ta = unparse_ty uta in + let tr = unparse_ty utr in + Prim (-1, "lambda", [ ta; tr ]) + | Ref_t ut -> + let t = unparse_ty ut in + Prim (-1, "ref", [ t ]) + | Option_t ut -> + let t = unparse_ty ut in + Prim (-1, "option", [ t ]) + | List_t ut -> + let t = unparse_ty ut in + Prim (-1, "list", [ t ]) + | Set_t ut -> + let t = unparse_comparable_ty ut in + Prim (-1, "set", [ t ]) + | Map_t (uta, utr) -> + let ta = unparse_comparable_ty uta in + let tr = unparse_ty utr in + Prim (-1, "map", [ ta; tr ]) + +let rec unparse_untagged_data + : type a. a ty -> a -> Script.expr + = fun ty a -> match ty, a with + | Void_t, () -> + Prim (-1, "void", []) + | Int_t k, v -> + Int (-1, Int64.to_string (to_int64 k v)) + | String_t, s -> + String (-1, s) + | Float_t, f -> + Float (-1, string_of_float f) + | Bool_t, true -> + Prim (-1, "true", []) + | Bool_t, false -> + Prim (-1, "false", []) + | Timestamp_t, t -> + String (-1, Timestamp.to_notation t) + | Contract_t _, (_, _, c) -> + String (-1, Contract.to_b48check c) + | Signature_t, s -> + let text = + Hex_encode.hex_encode + (MBytes.to_string (Data_encoding.Binary.to_bytes Ed25519.signature_encoding s)) in + String (-1, text) + | Tez_t, v -> + String (-1, Tez.to_string v) + | Key_t, k -> + String (-1, Ed25519.Public_key_hash.to_b48check k) + | Pair_t (tl, tr), (l, r) -> + let l = unparse_untagged_data tl l in + let r = unparse_untagged_data tr r in + Prim (-1, "pair", [ l; r ]) + | Union_t (tl, _), L l -> + let l = unparse_untagged_data tl l in + Prim (-1, "left", [ l ]) + | Union_t (_, tr), R r -> + let r = unparse_untagged_data tr r in + Prim (-1, "right", [ r ]) + | Ref_t t, { contents } -> + let contents = unparse_untagged_data t contents in + Prim (-1, "ref", [ contents ]) + | Option_t t, Some v -> + let v = unparse_untagged_data t v in + Prim (-1, "some", [ v ]) + | Option_t _, None -> + Prim (-1, "none", []) + | List_t t, items -> + let items = List.map (unparse_untagged_data t) items in + Prim (-1, "list", items) + | Set_t t, ({ contents = items }, _) -> + let t = ty_of_comparable_ty t in + let items = List.map (unparse_untagged_data t) items in + Prim (-1, "set", items) + | Map_t (kt, vt), ({ contents = items }, _) -> + let kt = ty_of_comparable_ty kt in + let items = + List.map (fun (k, v) -> + Prim (-1, "item", + [ unparse_untagged_data kt k; + unparse_untagged_data vt v ])) + items in + Prim (-1, "map", items) + | Lambda_t _, Lam (_, original_code) -> + original_code + +let rec unparse_tagged_data + : type a. a ty -> a -> Script.expr + = fun ty a -> match ty, a with + | Void_t, () -> + Prim (-1, "void", []) + | Int_t k, v -> + Prim (-1, string_of_int_kind k, [ String (-1, Int64.to_string (to_int64 k v))]) + | String_t, s -> + Prim (-1, "string", [ String (-1, s) ]) + | Float_t, f -> + Prim (-1, "float", [ String (-1, string_of_float f) ]) + | Bool_t, true -> + Prim (-1, "bool", [ Prim (-1, "true", []) ]) + | Bool_t, false -> + Prim (-1, "bool", [ Prim (-1, "false", []) ]) + | Timestamp_t, t -> + Prim (-1, "timestamp", [ String (-1, Timestamp.to_notation t) ]) + | Contract_t (ta, tr), (_, _, c) -> + let ta = unparse_ty ta in + let tr = unparse_ty tr in + Prim (-1, "contract", [ ta; tr; String (-1, Contract.to_b48check c) ]) + | Signature_t, s -> + let text = + Hex_encode.hex_encode + (MBytes.to_string (Data_encoding.Binary.to_bytes Ed25519.signature_encoding s)) in + Prim (-1, "signature", [ String (-1, text) ]) + | Tez_t, v -> + Prim (-1, "tez", [ String (-1, Tez.to_string v) ]) + | Key_t, k -> + Prim (-1, "key", [ String (-1, Ed25519.Public_key_hash.to_b48check k)]) + | Pair_t (tl, tr), (l, r) -> + let l = unparse_untagged_data tl l in + let r = unparse_untagged_data tr r in + let tl = unparse_ty tl in + let tr = unparse_ty tr in + Prim (-1, "pair", [ tl; tr; l; r ]) + | Union_t (tl, tr), L l -> + let l = unparse_tagged_data tl l in + let tr = unparse_ty tr in + Prim (-1, "left", [ l; tr ]) + | Union_t (tl, tr), R r -> + let r = unparse_tagged_data tr r in + let tl = unparse_ty tl in + Prim (-1, "right", [ tl; r ]) + | Ref_t t, { contents } -> + let contents = unparse_tagged_data t contents in + Prim (-1, "ref", [ contents ]) + | Option_t t, Some v -> + let v = unparse_tagged_data t v in + Prim (-1, "some", [ v ]) + | Option_t t, None -> + let t = unparse_ty t in + Prim (-1, "none", [ t ]) + | List_t t, items -> + let items = List.map (unparse_untagged_data t) items in + let t = unparse_ty t in + Prim (-1, "list", t :: items) + | Set_t t, ({ contents = items }, _) -> + let t = ty_of_comparable_ty t in + let items = List.map (unparse_untagged_data t) items in + let t = unparse_ty t in + Prim (-1, "set", t :: items) + | Map_t (kt, vt), ({ contents = items }, _) -> + let kt = ty_of_comparable_ty kt in + let items = + List.map (fun (k, v) -> + Prim (-1, "item", + [ unparse_untagged_data kt k; + unparse_untagged_data vt v ])) + items in + let kt = unparse_ty kt in + let vt = unparse_ty vt in + Prim (-1, "map", kt :: vt :: items) + | Lambda_t (ta, tr), Lam (_, original_code) -> + let ta = unparse_ty ta in + let tr = unparse_ty tr in + Prim (-1, "lambda", [ ta; tr; original_code ]) + +type ex_script = Ex : ('a, 'b, 'c) script -> ex_script + +let parse_script + : context -> Script.storage -> Script.code -> ex_script tzresult Lwt.t + = fun ctxt { storage; storage_type } { code; arg_type; ret_type } -> + parse_ty arg_type >>=? fun (Ex arg_type) -> + parse_ty ret_type >>=? fun (Ex ret_type) -> + parse_ty storage_type >>=? fun (Ex storage_type) -> + let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in + let ret_type_full = Pair_t (ret_type, storage_type) in + parse_untagged_data ctxt storage_type storage >>=? fun storage -> + parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun code -> + return (Ex { code; arg_type; ret_type; storage; storage_type }) + +let typecheck_code + : context -> Script.code -> unit tzresult Lwt.t + = fun ctxt { code; arg_type; ret_type; storage_type } -> + parse_ty arg_type >>=? fun (Ex arg_type) -> + parse_ty ret_type >>=? fun (Ex ret_type) -> + parse_ty storage_type >>=? fun (Ex storage_type) -> + let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in + let ret_type_full = Pair_t (ret_type, storage_type) in + parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun _ -> + return () diff --git a/src/proto/bootstrap/script_parser.mli b/src/proto/bootstrap/script_parser.mli new file mode 100644 index 000000000..26780d219 --- /dev/null +++ b/src/proto/bootstrap/script_parser.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Contract_repr + +(** The node position in the AST in prefix order *) +type location = int +val location_encoding : location Data_encoding.t + +(** The three possible parsing contexts *) +type parse_context = Type | Constant | Instr + +(** The primitive on which an error happened *) +type parse_symbol = parse_context * string + +(** Errors (only used as result in the error monad) *) +exception Invalid_arity of location * parse_symbol * int * int +exception Unknown_primitive of location * parse_symbol +exception Comparable_type_expected of location +exception Invalid_push of location +exception Invalid_node of location * parse_context +exception Invalid_constant of location * string + +(** An association from script AST nodes to original expression nodes. + Nodes are represented by their indexes in expression trees and + script AST in prefix order, the root being 0. In expression nodes, + all constants count for 1, as do a primitive applcation or a + sequence. In AST nodes, all constructors count for 1, except for + all type contructors and the seq instruction constructor which are + omitted. *) +type code_map = (int * int) list + +(** parse a script expression as code, may return a [Parse_error] *) +val parse_code: Script_ir.node -> (script_instr * code_map) result + +(** parse a script expression as typed data, may return a [Parse_error] *) +val parse_data: Script_ir.node -> (script_data_ty * script_data * code_map) result + +(** parse a script expression as a type, may return a [Parse_error] *) +val parse_data_type: Script_ir.node -> (script_data_ty * code_map) result diff --git a/src/proto/bootstrap/script_repr.ml b/src/proto/bootstrap/script_repr.ml new file mode 100644 index 000000000..25abc8007 --- /dev/null +++ b/src/proto/bootstrap/script_repr.ml @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +(* Tezos protocol "bootstrap" - untyped script representation *) + +type location = int + +let location_encoding = + let open Data_encoding in + def + "scriptLocation" @@ + describe + ~title: + "Script location" + ~description: + "The location of a node in a script (code, data or type) \ + as its index in the expression tree in prefix order, with \ + zero being the root and adding one for every basic node, \ + sequence and primitive application." @@ + int31 + +type expr = (* TODO: turn the location into an alpha ? *) + | Int of location * string + | Float of location * string + | String of location * string + | Prim of location * string * expr list + | Seq of location * expr list + +let expr_encoding = + let open Data_encoding in + let int_encoding = + obj1 (req "int" string) in + let float_encoding = + obj1 (req "float" string) in + let string_encoding = + obj1 (req "string" string) in + let prim_encoding expr_encoding = + obj2 (req "prim" string) (opt "args" @@ list expr_encoding) in + let seq_encoding expr_encoding = + list expr_encoding in + mu "tezosScriptExpression" (fun expr_encoding -> + describe + ~title: "Script expression (data, type or code)" @@ + union ~tag_size:`Int8 + [ case ~tag:0 int_encoding + (function Int (_, v) -> Some v | _ -> None) + (fun v -> Int (-1, v)) ; + case ~tag:1 float_encoding + (function Float (_, v) -> Some v | _ -> None) + (fun v -> Float (-1, v)) ; + case ~tag:2 string_encoding + (function String (_, v) -> Some v | _ -> None) + (fun v -> String (-1, v)) ; + case ~tag:3 (prim_encoding expr_encoding) + (function + | Prim (_, v, []) -> Some (v, None) + | Prim (_, v, args) -> Some (v, Some args) + | _ -> None) + (function + | (prim, None) -> Prim (-1, prim, []) + | (prim, Some args) -> Prim (-1, prim, args)) ; + case ~tag:4 (seq_encoding expr_encoding) + (function Seq (_, v) -> Some v | _ -> None) + (fun args -> Seq (-1, args)) ]) + +let update_locations ir = + let rec update_locations i = function + | Int (_, v) -> (Int (i, v), succ i) + | Float (_, v) -> (Float (i, v), succ i) + | String (_, v) -> (String (i, v), succ i) + | Prim (_, name, args) -> + let (nargs, ni) = + List.fold_left (fun (nargs, ni) arg -> + let narg, ni = update_locations ni arg in + (narg :: nargs, ni)) + ([], succ i) args in + (Prim (i, name, List.rev nargs), ni) + | Seq (_, args) -> + let (nargs, ni) = + List.fold_left (fun (nargs, ni) arg -> + let narg, ni = update_locations ni arg in + (narg :: nargs, ni)) + ([], succ i) args in + (Seq (i, List.rev nargs), ni) in + fst (update_locations 0 ir) + +let expr_encoding = + Data_encoding.conv + (fun to_write -> to_write) + (fun just_read -> update_locations just_read) + expr_encoding + +type code = + { code : expr ; + arg_type : expr ; + ret_type : expr ; + storage_type : expr } + +type storage = + { storage : expr ; + storage_type : expr } + +let storage_cost _ = Tez_repr.of_cents_exn 50L (* FIXME *) +let code_cost _ = Tez_repr.of_cents_exn 50L (* FIXME *) + +open Data_encoding + +let storage_encoding = + conv + (fun { storage ; storage_type } -> (storage, storage_type)) + (fun (storage, storage_type) -> { storage ; storage_type }) + (obj2 + (req "storage" expr_encoding) + (req "storageType" expr_encoding)) + +let code_encoding = + conv + (fun { code; arg_type; ret_type; storage_type } -> + (code, arg_type, ret_type, storage_type)) + (fun (code, arg_type, ret_type, storage_type) -> + { code; arg_type; ret_type; storage_type }) + (obj4 + (req "code" expr_encoding) + (req "argType" expr_encoding) + (req "retType" expr_encoding) + (req "storageType" expr_encoding)) + +let hash_expr data = + let bytes = Data_encoding.Binary.to_bytes expr_encoding data in + Script_expr_hash.(hash_bytes [ bytes ] |> to_b48check) + +type t = + | No_script + | Script of { + code: code ; + storage: storage ; + } + +let encoding = + let open Data_encoding in + union ~tag_size:`Int8 [ + case ~tag:0 empty + (function No_script -> Some () | _ -> None) + (fun () -> No_script) ; + case ~tag:1 + (obj2 + (req "code" code_encoding) + (req "storage" storage_encoding)) + (function Script { code ; storage } -> Some (code, storage) | _ -> None) + (fun (code, storage) -> Script { code ; storage }) + ] diff --git a/src/proto/bootstrap/script_repr.mli b/src/proto/bootstrap/script_repr.mli new file mode 100644 index 000000000..ae1936bea --- /dev/null +++ b/src/proto/bootstrap/script_repr.mli @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos protocol 1234abc1212 - untyped script representation *) + +type location = + int + +type expr = + | Int of location * string + | Float of location * string + | String of location * string + | Prim of location * string * expr list + | Seq of location * expr list + +type code = + { code : expr ; + arg_type : expr ; + ret_type : expr ; + storage_type : expr } + +type storage = + { storage : expr ; + storage_type : expr } + +type t = + | No_script + | Script of { + code: code ; + storage: storage ; + } + +val location_encoding : location Data_encoding.t +val expr_encoding : expr Data_encoding.t +val storage_encoding : storage Data_encoding.t +val code_encoding : code Data_encoding.t +val encoding : t Data_encoding.t + +val storage_cost : storage -> Tez_repr.tez +val code_cost : code -> Tez_repr.tez + +val hash_expr : expr -> string diff --git a/src/proto/bootstrap/script_typed_ir.ml b/src/proto/bootstrap/script_typed_ir.ml new file mode 100644 index 000000000..f884a84d8 --- /dev/null +++ b/src/proto/bootstrap/script_typed_ir.ml @@ -0,0 +1,321 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context +open Script_int + +type ('arg, 'ret, 'storage) script = + { code : (((Tez.t, 'arg) pair, 'storage) pair, ('ret, 'storage) pair) lambda ; + arg_type : 'arg ty ; + ret_type : 'ret ty ; + storage : 'storage ; + storage_type : 'storage ty } + +(* ---- Auxiliary types -----------------------------------------------------*) + +and ('a, 'b) pair = 'a * 'b + +and ('a, 'b) union = L of 'a | R of 'b + +and end_of_stack = unit + +and ('arg, 'ret) lambda = + Lam of ('arg * end_of_stack, 'ret * end_of_stack) instr * Script.expr + +and ('arg, 'ret) typed_contract = + 'arg ty * 'ret ty * Contract.t + +and 'ty comparable_ty = + | Int_key : ('s, 'l) int_kind -> ('s, 'l) int_val comparable_ty + | String_key : string comparable_ty + | Float_key : float comparable_ty + | Tez_key : Tez.t comparable_ty + | Bool_key : bool comparable_ty + | Key_key : public_key_hash comparable_ty + | Timestamp_key : Timestamp.t comparable_ty + +and 'ty ty = + | Void_t : unit ty + | Int_t : ('s, 'l) int_kind -> ('s, 'l) int_val ty + | Signature_t : signature ty + | String_t : string ty + | Float_t : float ty + | Tez_t : Tez.t ty + | Key_t : public_key_hash ty + | Timestamp_t : Timestamp.t ty + | Bool_t : bool ty + | Pair_t : 'a ty * 'b ty -> ('a, 'b) pair ty + | Union_t : 'a ty * 'b ty -> ('a, 'b) union ty + | Lambda_t : 'arg ty * 'ret ty -> ('arg, 'ret) lambda ty + | Option_t : 'v ty -> 'v option ty + | Ref_t : 'v ty -> 'v ref ty + | List_t : 'v ty -> 'v list ty + | Set_t : 'v comparable_ty -> 'v set ty + | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty + | Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty + +and 'a set = + 'a list ref * 'a comparable_ty (* FIXME: ok, this is bad *) + +and ('a, 'b) map = + ('a * 'b) list ref * 'a comparable_ty (* FIXME: we'll have to do better *) + +(* ---- Instructions --------------------------------------------------------*) + +(* The low-level, typed instructions, as a GADT whose parameters + encode the typing rules. The eft parameter is the typed shape of + the stack before the instruction, the right one the shape + after. Any program whose construction is accepted by OCaml's + type-checker is guaranteed to be type-safe. Overloadings of the + concrete syntax are already resolved in this representation, either + by using different constructors or type witness parameters. *) +and ('bef, 'aft) instr = + (* stack ops *) + | Drop : + (_ * 'rest, 'rest) instr + | Dup : + ('top * 'rest, 'top * ('top * 'rest)) instr + | Swap : + ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr + | Const : 'ty -> + ('rest, ('ty * 'rest)) instr + (* pairs *) + | Cons_pair : + (('car * ('cdr * 'rest)), (('car, 'cdr) pair * 'rest)) instr + | Car : + (('car, _) pair * 'rest, 'car * 'rest) instr + | Cdr : + ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr + (* options *) + | Cons_some : + ('v * 'rest, 'v option * 'rest) instr + | Cons_none : 'a ty -> + ('rest, 'a option * 'rest) instr + | If_none : ('bef, 'aft) instr * ('a * 'bef, 'aft) instr -> + ('a option * 'bef, 'aft) instr + (* unions *) + | Left : + ('l * 'rest, (('l, 'r) union * 'rest)) instr + | Right : + ('r * 'rest, (('l, 'r) union * 'rest)) instr + | If_left : ('l * 'bef, 'aft) instr * ('r * 'bef, 'aft) instr -> + (('l, 'r) union * 'bef, 'aft) instr + (* lists *) + | Cons_list : + ('a * ('a list * 'rest), ('a list * 'rest)) instr + | Nil : + ('rest, ('a list * 'rest)) instr + | If_cons : ('a * ('a list * 'bef), 'aft) instr * ('bef, 'aft) instr -> + ('a list * 'bef, 'aft) instr + | List_iter : + (('param, unit) lambda * ('param list * 'rest), 'rest) instr + | List_map : + (('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr + | List_reduce : + (('param * 'res, 'res) lambda * + ('param list * ('res * 'rest)), 'res * 'rest) instr + (* sets *) + | Empty_set : 'a comparable_ty -> + ('rest, 'a set * 'rest) instr + | Set_iter : + (('param, unit) lambda * ('param set * 'rest), 'rest) instr + | Set_map : 'ret comparable_ty -> + (('param, 'ret) lambda * ('param set * 'rest), 'ret set * 'rest) instr + | Set_reduce : + (('param * 'res, 'res) lambda * + ('param set * ('res * 'rest)), 'res * 'rest) instr + | Set_mem : + ('elt * ('elt set * 'rest), bool * 'rest) instr + | Set_update : + ('elt * (bool * ('elt set * 'rest)), 'rest) instr + (* maps *) + | Empty_map : 'a comparable_ty * 'v ty -> + ('rest, ('a, 'v) map * 'rest) instr + | Map_iter : + (('a * 'v, unit) lambda * (('a, 'v) map * 'rest), 'rest) instr + | Map_map : + (('a * 'v, 'r) lambda * (('a, 'v) map * 'rest), ('a, 'r) map * 'rest) instr + | Map_reduce : + ((('a * 'v) * 'res, 'res) lambda * + (('a, 'v) map * ('res * 'rest)), 'res * 'rest) instr + | Map_mem : + ('a * (('a, 'v) map * 'rest), bool * 'rest) instr + | Map_get : + ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr + | Map_update : + ('a * ('v option * (('a, 'v) map * 'rest)), 'rest) instr + (* reference cells *) + | Ref : + ('v * 'rest, 'v ref * 'rest) instr + | Deref : + ('v ref * 'rest, 'v * 'rest) instr + | Set : + ('v ref * ('v * 'rest), 'rest) instr + (* string operations *) + | Concat : + (string * (string * 'rest), string * 'rest) instr + (* timestamp operations *) + | Add_period_to_timestamp : + (float * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr + | Add_seconds_to_timestamp : (unsigned, 'l) int_kind * Script.location -> + ((unsigned, 'l) int_val * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr + | Add_timestamp_to_period : + (Timestamp.t * (float * 'rest), Timestamp.t * 'rest) instr + | Add_timestamp_to_seconds : (unsigned, 'l) int_kind * Script.location -> + (Timestamp.t * ((unsigned, 'l) int_val * 'rest), Timestamp.t * 'rest) instr + (* currency operations *) + | Add_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Sub_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Mul_tez : (unsigned, 'l) int_kind -> + (Tez.t * ((unsigned, 'l) int_val * 'rest), Tez.t * 'rest) instr + | Mul_tez' : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * (Tez.t * 'rest), Tez.t * 'rest) instr + (* float operations *) + | Neg_float : + (float * 'rest, float * 'rest) instr + | Abs_float : + (float * 'rest, float * 'rest) instr + | Add_float : + (float * (float * 'rest), float * 'rest) instr + | Sub_float : + (float * (float * 'rest), float * 'rest) instr + | Mul_float : + (float * (float * 'rest), float * 'rest) instr + | Div_float : + (float * (float * 'rest), float * 'rest) instr + | Mod_float : + (float * (float * 'rest), float * 'rest) instr + | Floor : + (float * 'rest, float * 'rest) instr + | Ceil : + (float * 'rest, float * 'rest) instr + | Inf : + ('rest, float * 'rest) instr + | NaN : + ('rest, float * 'rest) instr + | IsNaN : + (float * 'rest, bool * 'rest) instr + | NaNaN : Script.location -> + (float * 'rest, 'rest) instr + (* boolean operations *) + | Or : + (bool * (bool * 'rest), bool * 'rest) instr + | And : + (bool * (bool * 'rest), bool * 'rest) instr + | Xor : + (bool * (bool * 'rest), bool * 'rest) instr + | Not : + (bool * 'rest, bool * 'rest) instr + (* integer operations *) + | Checked_neg_int : (signed, 'l) int_kind * Script.location -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Checked_abs_int : (signed, 'l) int_kind * Script.location -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Checked_add_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Checked_sub_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Checked_mul_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Neg_int : (signed, 'l) int_kind -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Abs_int : (signed, 'l) int_kind -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Add_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Sub_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Mul_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Div_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Mod_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Lsl_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Lsr_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Or_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | And_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Xor_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Not_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr + (* control *) + | Seq : ('bef, 'trans) instr * ('trans, 'aft) instr -> + ('bef, 'aft) instr + | If : ('bef, 'aft) instr * ('bef, 'aft) instr -> + (bool * 'bef, 'aft) instr + | Loop : ('rest, bool * 'rest) instr -> + (bool * 'rest, 'rest) instr + | Dip : ('bef, 'aft) instr -> + ('top * 'bef, 'top * 'aft) instr + | Exec : + ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Lambda : ('arg, 'ret) lambda -> + ('rest, ('arg, 'ret) lambda * 'rest) instr + | Fail : Script.location -> + ('rest, 'rest) instr + | Nop : + ('rest, 'rest) instr + (* comparison *) + | Compare : 'a comparable_ty -> + ('a * ('a * 'rest), (signed, sixtyfour) int_val * 'rest) instr + (* comparators *) + | Eq : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Neq : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Lt : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Gt : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Le : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Ge : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + (* casts *) + | Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind -> + (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr + | Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind * Script.location -> + (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr + | Int_of_float : ('st, 'lt) int_kind -> + (float * 'rest, ('st, 'lt) int_val * 'rest) instr + | Float_of_int : ('sf, 'lf) int_kind -> + (('sf, 'lf) int_val * 'rest, float * 'rest) instr + (* protocol *) + | Manager : + (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr + | Transfer_funds : 'sto ty * Script.location -> + ('arg * (Tez.t * (('arg, 'ret) typed_contract * ('sto * end_of_stack))), 'ret * ('sto * end_of_stack)) instr + | Create_account : + (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), + (unit, unit) typed_contract * 'rest) instr + | Create_contract : 'g ty * 'p ty * 'r ty -> + (public_key_hash * (public_key_hash option * (bool * (Tez.t * + (((Tez.t * 'p) * 'g, 'r * 'g) lambda * ('g * 'rest))))), + ('p, 'r) typed_contract * 'rest) instr + | Now : + ('rest, Timestamp.t * 'rest) instr + | Balance : + ('rest, Tez.t * 'rest) instr + | Check_signature : + (public_key_hash * ((signature * string) * 'rest), bool * 'rest) instr + | H : 'a ty -> + ('a * 'rest, string * 'rest) instr + | Steps_to_quota : + ('rest, (unsigned, thirtytwo) int_val * 'rest) instr + | Source : 'p ty * 'r ty -> + ('rest, ('p, 'r) typed_contract * 'rest) instr + | Amount : + ('rest, Tez.t * 'rest) instr diff --git a/src/proto/bootstrap/script_typed_ir.mli b/src/proto/bootstrap/script_typed_ir.mli new file mode 100644 index 000000000..7af163b26 --- /dev/null +++ b/src/proto/bootstrap/script_typed_ir.mli @@ -0,0 +1,321 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context +open Script_int + +type ('arg, 'ret, 'storage) script = + { code : (((Tez.t, 'arg) pair, 'storage) pair, ('ret, 'storage) pair) lambda ; + arg_type : 'arg ty ; + ret_type : 'ret ty ; + storage : 'storage ; + storage_type : 'storage ty } + +(* ---- Auxiliary types -----------------------------------------------------*) + +and ('a, 'b) pair = 'a * 'b + +and ('a, 'b) union = L of 'a | R of 'b + +and end_of_stack = unit + +and ('arg, 'ret) lambda = + Lam of ('arg * end_of_stack, 'ret * end_of_stack) instr * Script.expr + +and ('arg, 'ret) typed_contract = + 'arg ty * 'ret ty * Contract.t + +and 'ty comparable_ty = + | Int_key : ('s, 'l) int_kind -> ('s, 'l) int_val comparable_ty + | String_key : string comparable_ty + | Float_key : float comparable_ty + | Tez_key : Tez.t comparable_ty + | Bool_key : bool comparable_ty + | Key_key : public_key_hash comparable_ty + | Timestamp_key : Time.t comparable_ty + +and 'ty ty = + | Void_t : unit ty + | Int_t : ('s, 'l) int_kind -> ('s, 'l) int_val ty + | Signature_t : signature ty + | String_t : string ty + | Float_t : float ty + | Tez_t : Tez.t ty + | Key_t : public_key_hash ty + | Timestamp_t : Time.t ty + | Bool_t : bool ty + | Pair_t : 'a ty * 'b ty -> ('a, 'b) pair ty + | Union_t : 'a ty * 'b ty -> ('a, 'b) union ty + | Lambda_t : 'arg ty * 'ret ty -> ('arg, 'ret) lambda ty + | Option_t : 'v ty -> 'v option ty + | Ref_t : 'v ty -> 'v ref ty + | List_t : 'v ty -> 'v list ty + | Set_t : 'v comparable_ty -> 'v set ty + | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty + | Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty + +and 'a set = + 'a list ref * 'a comparable_ty (* FIXME: ok, this is bad *) + +and ('a, 'b) map = + ('a * 'b) list ref * 'a comparable_ty (* FIXME: we'll have to do better *) + +(* ---- Instructions --------------------------------------------------------*) + +(* The low-level, typed instructions, as a GADT whose parameters + encode the typing rules. The eft parameter is the typed shape of + the stack before the instruction, the right one the shape + after. Any program whose construction is accepted by OCaml's + type-checker is guaranteed to be type-safe. Overloadings of the + concrete syntax are already resolved in this representation, either + by using different constructors or type witness parameters. *) +and ('bef, 'aft) instr = + (* stack ops *) + | Drop : + (_ * 'rest, 'rest) instr + | Dup : + ('top * 'rest, 'top * ('top * 'rest)) instr + | Swap : + ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr + | Const : 'ty -> + ('rest, ('ty * 'rest)) instr + (* pairs *) + | Cons_pair : + (('car * ('cdr * 'rest)), (('car, 'cdr) pair * 'rest)) instr + | Car : + (('car, _) pair * 'rest, 'car * 'rest) instr + | Cdr : + ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr + (* options *) + | Cons_some : + ('v * 'rest, 'v option * 'rest) instr + | Cons_none : 'a ty -> + ('rest, 'a option * 'rest) instr + | If_none : ('bef, 'aft) instr * ('a * 'bef, 'aft) instr -> + ('a option * 'bef, 'aft) instr + (* unions *) + | Left : + ('l * 'rest, (('l, 'r) union * 'rest)) instr + | Right : + ('r * 'rest, (('l, 'r) union * 'rest)) instr + | If_left : ('l * 'bef, 'aft) instr * ('r * 'bef, 'aft) instr -> + (('l, 'r) union * 'bef, 'aft) instr + (* lists *) + | Cons_list : + ('a * ('a list * 'rest), ('a list * 'rest)) instr + | Nil : + ('rest, ('a list * 'rest)) instr + | If_cons : ('a * ('a list * 'bef), 'aft) instr * ('bef, 'aft) instr -> + ('a list * 'bef, 'aft) instr + | List_iter : + (('param, unit) lambda * ('param list * 'rest), 'rest) instr + | List_map : + (('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr + | List_reduce : + (('param * 'res, 'res) lambda * + ('param list * ('res * 'rest)), 'res * 'rest) instr + (* sets *) + | Empty_set : 'a comparable_ty -> + ('rest, 'a set * 'rest) instr + | Set_iter : + (('param, unit) lambda * ('param set * 'rest), 'rest) instr + | Set_map : 'ret comparable_ty -> + (('param, 'ret) lambda * ('param set * 'rest), 'ret set * 'rest) instr + | Set_reduce : + (('param * 'res, 'res) lambda * + ('param set * ('res * 'rest)), 'res * 'rest) instr + | Set_mem : + ('elt * ('elt set * 'rest), bool * 'rest) instr + | Set_update : + ('elt * (bool * ('elt set * 'rest)), 'rest) instr + (* maps *) + | Empty_map : 'a comparable_ty * 'v ty -> + ('rest, ('a, 'v) map * 'rest) instr + | Map_iter : + (('a * 'v, unit) lambda * (('a, 'v) map * 'rest), 'rest) instr + | Map_map : + (('a * 'v, 'r) lambda * (('a, 'v) map * 'rest), ('a, 'r) map * 'rest) instr + | Map_reduce : + ((('a * 'v) * 'res, 'res) lambda * + (('a, 'v) map * ('res * 'rest)), 'res * 'rest) instr + | Map_mem : + ('a * (('a, 'v) map * 'rest), bool * 'rest) instr + | Map_get : + ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr + | Map_update : + ('a * ('v option * (('a, 'v) map * 'rest)), 'rest) instr + (* reference cells *) + | Ref : + ('v * 'rest, 'v ref * 'rest) instr + | Deref : + ('v ref * 'rest, 'v * 'rest) instr + | Set : + ('v ref * ('v * 'rest), 'rest) instr + (* string operations *) + | Concat : + (string * (string * 'rest), string * 'rest) instr + (* timestamp operations *) + | Add_period_to_timestamp : + (float * (Time.t * 'rest), Time.t * 'rest) instr + | Add_seconds_to_timestamp : (unsigned, 'l) int_kind * Script.location -> + ((unsigned, 'l) int_val * (Time.t * 'rest), Time.t * 'rest) instr + | Add_timestamp_to_period : + (Time.t * (float * 'rest), Time.t * 'rest) instr + | Add_timestamp_to_seconds : (unsigned, 'l) int_kind * Script.location -> + (Time.t * ((unsigned, 'l) int_val * 'rest), Time.t * 'rest) instr + (* currency operations *) + | Add_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Sub_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Mul_tez : (unsigned, 'l) int_kind -> + (Tez.t * ((unsigned, 'l) int_val * 'rest), Tez.t * 'rest) instr + | Mul_tez' : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * (Tez.t * 'rest), Tez.t * 'rest) instr + (* float operations *) + | Neg_float : + (float * 'rest, float * 'rest) instr + | Abs_float : + (float * 'rest, float * 'rest) instr + | Add_float : + (float * (float * 'rest), float * 'rest) instr + | Sub_float : + (float * (float * 'rest), float * 'rest) instr + | Mul_float : + (float * (float * 'rest), float * 'rest) instr + | Div_float : + (float * (float * 'rest), float * 'rest) instr + | Mod_float : + (float * (float * 'rest), float * 'rest) instr + | Floor : + (float * 'rest, float * 'rest) instr + | Ceil : + (float * 'rest, float * 'rest) instr + | Inf : + ('rest, float * 'rest) instr + | NaN : + ('rest, float * 'rest) instr + | IsNaN : + (float * 'rest, bool * 'rest) instr + | NaNaN : Script.location -> + (float * 'rest, 'rest) instr + (* boolean operations *) + | Or : + (bool * (bool * 'rest), bool * 'rest) instr + | And : + (bool * (bool * 'rest), bool * 'rest) instr + | Xor : + (bool * (bool * 'rest), bool * 'rest) instr + | Not : + (bool * 'rest, bool * 'rest) instr + (* integer operations *) + | Checked_neg_int : (signed, 'l) int_kind * Script.location -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Checked_abs_int : (signed, 'l) int_kind * Script.location -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Checked_add_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Checked_sub_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Checked_mul_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Neg_int : (signed, 'l) int_kind -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Abs_int : (signed, 'l) int_kind -> + ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr + | Add_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Sub_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Mul_int : ('s, 'l) int_kind -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Div_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Mod_int : ('s, 'l) int_kind * Script.location -> + (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr + | Lsl_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Lsr_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Or_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | And_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Xor_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * ((unsigned, 'l) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr + | Not_int : (unsigned, 'l) int_kind -> + ((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr + (* control *) + | Seq : ('bef, 'trans) instr * ('trans, 'aft) instr -> + ('bef, 'aft) instr + | If : ('bef, 'aft) instr * ('bef, 'aft) instr -> + (bool * 'bef, 'aft) instr + | Loop : ('rest, bool * 'rest) instr -> + (bool * 'rest, 'rest) instr + | Dip : ('bef, 'aft) instr -> + ('top * 'bef, 'top * 'aft) instr + | Exec : + ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Lambda : ('arg, 'ret) lambda -> + ('rest, ('arg, 'ret) lambda * 'rest) instr + | Fail : Script.location -> + ('rest, 'rest) instr + | Nop : + ('rest, 'rest) instr + (* comparison *) + | Compare : 'a comparable_ty -> + ('a * ('a * 'rest), (signed, sixtyfour) int_val * 'rest) instr + (* comparators *) + | Eq : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Neq : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Lt : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Gt : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Le : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + | Ge : + ((signed, sixtyfour) int_val * 'rest, bool * 'rest) instr + (* casts *) + | Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind -> + (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr + | Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind * Script.location -> + (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr + | Int_of_float : ('st, 'lt) int_kind -> + (float * 'rest, ('st, 'lt) int_val * 'rest) instr + | Float_of_int : ('sf, 'lf) int_kind -> + (('sf, 'lf) int_val * 'rest, float * 'rest) instr + (* protocol *) + | Manager : + (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr + | Transfer_funds : 'sto ty * Script.location -> + ('arg * (Tez.t * (('arg, 'ret) typed_contract * ('sto * end_of_stack))), 'ret * ('sto * end_of_stack)) instr + | Create_account : + (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), + (unit, unit) typed_contract * 'rest) instr + | Create_contract : 'g ty * 'p ty * 'r ty -> + (public_key_hash * (public_key_hash option * (bool * (Tez.t * + (((Tez.t * 'p) * 'g, 'r * 'g) lambda * ('g * 'rest))))), + ('p, 'r) typed_contract * 'rest) instr + | Now : + ('rest, Time.t * 'rest) instr + | Balance : + ('rest, Tez.t * 'rest) instr + | Check_signature : + (public_key_hash * ((signature * string) * 'rest), bool * 'rest) instr + | H : 'a ty -> + ('a * 'rest, string * 'rest) instr + | Steps_to_quota : + ('rest, (unsigned, thirtytwo) int_val * 'rest) instr + | Source : 'p ty * 'r ty -> + ('rest, ('p, 'r) typed_contract * 'rest) instr + | Amount : + ('rest, Tez.t * 'rest) instr diff --git a/src/proto/bootstrap/seed_repr.ml b/src/proto/bootstrap/seed_repr.ml new file mode 100644 index 000000000..c006b3d8b --- /dev/null +++ b/src/proto/bootstrap/seed_repr.ml @@ -0,0 +1,107 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Random number generation *) + +open Tezos_hash + +type seed = B of State_hash.t +type t = T of State_hash.t +type sequence = S of State_hash.t +type nonce = MBytes.t + +let nonce_encoding = Data_encoding.bytes + +let init = "1234567890123456789012" +let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000') + +let state_hash_encoding = + let open Data_encoding in + conv + State_hash.to_bytes + State_hash.of_bytes + (Fixed.bytes Nonce_hash.size) + +let seed_encoding = + let open Data_encoding in + conv + (fun (B b) -> b) + (fun b -> B b) + state_hash_encoding + +let empty = B (State_hash.hash_bytes [MBytes.of_string init]) + +let nonce (B state) nonce = + B (State_hash.hash_bytes ( [State_hash.to_bytes state; nonce] )) + +let initialize_new (B state) append = + T (State_hash.hash_bytes + (State_hash.to_bytes state :: zero_bytes :: append )) + +let xor_higher_bits i b = + let higher = MBytes.get_int32 b 0 in + let r = Int32.logxor higher i in + let res = MBytes.copy b in + MBytes.set_int32 res 0 r; + res + +let sequence (T state) n = + State_hash.to_bytes state + |> xor_higher_bits n + |> (fun b -> S (State_hash.hash_bytes [b])) + +let take (S state) = + let b = State_hash.to_bytes state in + let h = State_hash.hash_bytes [b] in + (State_hash.to_bytes h, S h) + +let take_int32 s bound = + if Compare.Int32.(bound <= 0l) + then invalid_arg "Seed_repr.take_int32" (* FIXME *) + else + let rec loop s = + let bytes, s = take s in + let r = Int32.abs (MBytes.get_int32 bytes 0) in + let drop_if_over = + Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in + if Compare.Int32.(r >= drop_if_over) + then loop s + else + let v = Int32.rem r bound in + v, s + in + loop s + +type error += Unexpected_nonce_length + +let make_nonce nonce = + if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) + then error Unexpected_nonce_length + else ok nonce + +let hash nonce = Nonce_hash.hash_bytes [nonce] + +let check_hash nonce hash = + Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length) + && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash + +let nonce_hash_key_part = Nonce_hash.to_path + +let initial_nonce_0 = + hash + (MBytes.of_string (String.make Constants_repr.nonce_length '\000')) + +let initial_seed_0 = B (State_hash.hash_bytes []) +let initial_seed_1 = + nonce initial_seed_0 + (MBytes.of_string (String.make Constants_repr.nonce_length '\000')) +let initial_seed_2 = + nonce initial_seed_1 + (MBytes.of_string (String.make Constants_repr.nonce_length '\000')) + diff --git a/src/proto/bootstrap/seed_repr.mli b/src/proto/bootstrap/seed_repr.mli new file mode 100644 index 000000000..bbb572dc8 --- /dev/null +++ b/src/proto/bootstrap/seed_repr.mli @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash + +(** Tezos Protocol Implementation - Random number generation + + This is not expected to be a good cryptographic random number + generator. In particular this is supposed to be used in situations + where the seed is a globaly known information. + + The only expected property is: It should be difficult to find a + seed such that the generated sequence is a given one. *) + + +(** {2 Random Generation} ****************************************************) + +(** The state of the random number generator *) +type t + +(** A random seed, to derive random sequences from *) +type seed + +(** A random sequence, to derive random values from *) +type sequence + +(** [initialize_new state ident] returns a new generator *) +val initialize_new : seed -> MBytes.t list -> t + +(** [sequence state n] prepares the n-th sequence of a state *) +val sequence : t -> int32 -> sequence + +(** Generates the next random value in the sequence *) +val take : sequence -> MBytes.t * sequence + +(** Generates the next random value as a bounded [int32] *) +val take_int32 : sequence -> int32 -> int32 * sequence + +(** {2 Predefined seeds} *****************************************************) + +val empty : seed +val initial_seed_0 : seed +val initial_seed_1 : seed +val initial_seed_2 : seed + +(** {2 Entropy} **************************************************************) + +(** A nonce for adding entropy to the generator *) +type nonce + +(** Add entropy to the seed generator *) +val nonce : seed -> nonce -> seed + +(** Use a byte sequence as a nonce *) +val make_nonce : MBytes.t -> nonce tzresult + +(** Compute the has of a nonce *) +val hash : nonce -> Nonce_hash.t + +(** [check_hash nonce hash] is true if the nonce correspond to the hash *) +val check_hash : nonce -> Nonce_hash.t -> bool + +(** For using nonce hashes as keys in the hierarchical database *) +val nonce_hash_key_part : Nonce_hash.t -> string list + +(** {2 Predefined nonce} *****************************************************) + +val initial_nonce_0 : Nonce_hash.t + +(** {2 Serializers} **********************************************************) + +val nonce_encoding : nonce Data_encoding.t +val seed_encoding : seed Data_encoding.t diff --git a/src/proto/bootstrap/seed_storage.ml b/src/proto/bootstrap/seed_storage.ml new file mode 100644 index 000000000..b0cfb7c32 --- /dev/null +++ b/src/proto/bootstrap/seed_storage.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += + | Precomputed_seed + | Invalid_cycle + +let compute_for_cycle c cycle = + begin + begin + match Cycle_repr.pred cycle with + | None -> fail Precomputed_seed + | Some previous_cycle -> return previous_cycle + end >>=? fun previous_cycle -> + begin + match Cycle_repr.pred previous_cycle with + | None -> fail Precomputed_seed + | Some pprevious_cycle -> + match Cycle_repr.pred pprevious_cycle with + | None -> fail Precomputed_seed + | Some revealed_cycle -> return revealed_cycle + end >>=? fun revealed_cycle -> + begin + let levels = Level_storage.levels_in_cycle c revealed_cycle in + let combine (c, random_seed) level = + Storage.Seed.Nonce.get c level >>=? function + | Revealed nonce -> + return (c, Seed_repr.nonce random_seed nonce) + | Unrevealed _ -> + return (c, random_seed) + in + Storage.Seed.For_cycle.get c previous_cycle >>=? fun seed -> + fold_left_s combine (c, seed) levels + end >>=? fun (c, seed) -> + Storage.Seed.For_cycle.init c cycle seed >>=? fun c -> + return c + end >>= function + | Error [Precomputed_seed] -> return c + | c -> Lwt.return c + +let for_cycle c cycle = + Level_storage.current c >>=? fun current_level -> + let current_cycle = current_level.cycle in + let next_cycle = (Level_storage.succ c current_level).cycle in + fail_unless + Cycle_repr.(cycle = current_cycle || cycle = next_cycle) + Invalid_cycle >>=? fun () -> + Storage.Seed.For_cycle.get c cycle + +let clear_cycle c cycle = + Storage.Seed.For_cycle.delete c cycle + +let init c = + Storage.Seed.For_cycle.init c + Cycle_repr.root + Seed_repr.initial_seed_0 >>=? fun c -> + Storage.Seed.For_cycle.init c + Cycle_repr.(succ root) + Seed_repr.initial_seed_1 >>=? fun c -> + Storage.Seed.For_cycle.init c + Cycle_repr.(succ (succ root)) + Seed_repr.initial_seed_2 diff --git a/src/proto/bootstrap/seed_storage.mli b/src/proto/bootstrap/seed_storage.mli new file mode 100644 index 000000000..2cb7a6963 --- /dev/null +++ b/src/proto/bootstrap/seed_storage.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += + | Precomputed_seed + | Invalid_cycle + +val init: + Storage.t -> Storage.t tzresult Lwt.t + +val compute_for_cycle: + Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + +val for_cycle: Storage.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + +val clear_cycle: + Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml new file mode 100644 index 000000000..1dc100cfd --- /dev/null +++ b/src/proto/bootstrap/services.ml @@ -0,0 +1,533 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Data_encoding +open Tezos_context + +let error_encoding = + let open Data_encoding in + describe + ~description: + "The full list of error is available with \ + the global RPC `/errors`" + (conv + (fun exn -> `A (List.map json_of_error exn)) + (function `A exns -> List.map error_of_json exns | _ -> []) + json) + +let wrap_tzerror encoding = + let open Data_encoding in + union [ + case + (obj1 (req "ok" encoding)) + (function Ok x -> Some x | _ -> None) + (fun x -> Ok x) ; + case + (obj1 (req "error" error_encoding)) + (function Error x -> Some x | _ -> None) + (fun x -> Error x) ; + ] + +module Constants = struct + + let cycle_length custom_root = + RPC.service + ~description: "Cycle length" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "cycle length" int32) + RPC.Path.(custom_root / "constants" / "cycle_length") + + let voting_period_length custom_root = + RPC.service + ~description: "Length of the voting period" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "voting period length" int32) + RPC.Path.(custom_root / "constants" / "voting_period_length") + + let time_before_reward custom_root = + RPC.service + ~description: "Time before reward" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "time before reward" Period.encoding) + RPC.Path.(custom_root / "constants" / "time_before_reward") + + let time_between_slots custom_root = + RPC.service + ~description: "Time between slots" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "time between slots" Period.encoding) + RPC.Path.(custom_root / "constants" / "time_between_slots") + + let first_free_mining_slot custom_root = + RPC.service + ~description: "First free mining slot" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "first free mining slot" int32) + RPC.Path.(custom_root / "constants" / "first_free_mining_slot") + + let max_signing_slot custom_root = + RPC.service + ~description: "Max signing slot" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "max signing slot" int31) + RPC.Path.(custom_root / "constants" / "max_signing_slot") + + let instructions_per_transaction custom_root = + RPC.service + ~description: "Instructions per transaction" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "instructions per transaction" int31) + RPC.Path.(custom_root / "constants" / "instructions_per_transaction") + + let proof_of_work_threshold custom_root = + RPC.service + ~description: "Stamp threshold" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "proof_of_work threshold" int31) + RPC.Path.(custom_root / "constants" / "proof_of_work_threshold") + + let errors custom_root = + RPC.service + ~description: "Schema for all the RPC errors from this protocol version" + ~input: empty + ~output: json_schema + RPC.Path.(custom_root / "constants" / "errors") + + let bootstrap custom_root = + RPC.service + ~description: "Hardcoded predefined keys and contract" + ~input: empty + ~output: (list Bootstrap.account_encoding) + RPC.Path.(custom_root / "constants" / "bootstrap_keys") + +end + +module Context = struct + + let level custom_root = + RPC.service + ~description: "Detailled level information for the current block" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "detailled level info" Level.encoding) + RPC.Path.(custom_root / "context" / "level") + + let next_level custom_root = + RPC.service + ~description: "Detailled level information for the next block" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "detailled level info" Level.encoding) + RPC.Path.(custom_root / "context" / "next_level") + + module Nonce = struct + + type nonce_info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + let nonce_encoding = + union [ + case + (obj1 (req "nonce" Nonce.encoding)) + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce) ; + case + (obj1 (req "hash" Nonce_hash.encoding)) + (function Missing nonce -> Some nonce | _ -> None) + (fun nonce -> Missing nonce) ; + case + empty + (function Forgotten -> Some () | _ -> None) + (fun () -> Forgotten) ; + ] + + let get custom_root = + RPC.service + ~description: "Info about the nonce of a previous block." + ~input: empty + ~output: (wrap_tzerror nonce_encoding) + RPC.Path.(custom_root / "context" / "nonce" /: Raw_level.arg) + + let hash custom_root = + RPC.service + ~description: "Hash of the current block's nonce." + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "nonce hash" Nonce_hash.encoding) + RPC.Path.(custom_root / "context" / "nonce") + + end + + module Key = struct + + let public_key_hash_arg = + let construct = Ed25519.Public_key_hash.to_b48check in + let destruct hash = + match Ed25519.Public_key_hash.of_b48check hash with + | exception _ -> Error "Cannot parse public key hash" + | public_key_hash -> Ok public_key_hash in + RPC.Arg.make + ~descr:"A public key hash" + ~name: "public_key_hash" + ~construct + ~destruct + + let pk_encoding = + (obj2 + (req "hash" Ed25519.public_key_hash_encoding) + (req "public_key" Ed25519.public_key_encoding)) + + let list custom_root = + RPC.service + ~description: "List the known public keys" + ~input: empty + ~output: (wrap_tzerror @@ list pk_encoding) + RPC.Path.(custom_root / "context" / "keys") + + let get custom_root = + RPC.service + ~description: "Fetch the stored public key" + ~input: empty + ~output: (wrap_tzerror @@ pk_encoding) + RPC.Path.(custom_root / "context" / "keys" /: public_key_hash_arg ) + + end + + (*-- Contracts ---------------------------------------------------------------*) + + module Contract = struct + + let balance custom_root = + RPC.service + ~description: "Access the balance of a contract." + ~input: empty + ~output: (wrap_tzerror Tez.encoding) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "balance") + + let manager custom_root = + RPC.service + ~description: "Access the manager of a contract." + ~input: empty + ~output: (wrap_tzerror Ed25519.public_key_hash_encoding) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "manager") + + let delegate custom_root = + RPC.service + ~description: "Access the delegate of a contract, if any." + ~input: empty + ~output: (wrap_tzerror (option Ed25519.public_key_hash_encoding)) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "delegate") + + let counter custom_root = + RPC.service + ~description: "Access the counter of a contract, if any." + ~input: empty + ~output: (wrap_tzerror int32) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "counter") + + let spendable custom_root = + RPC.service + ~description: "Tells if the contract funds can be spent by the manager." + ~input: empty + ~output: (wrap_tzerror bool) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "spendable") + + let delegatable custom_root = + RPC.service + ~description: "Tells if the contract delegate can be changed." + ~input: empty + ~output: (wrap_tzerror bool) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "delegatable") + + let script custom_root = + RPC.service + ~description: "Access the code and data of the contract." + ~input: empty + ~output: (wrap_tzerror Script.encoding) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "script") + + let assets custom_root = + RPC.service + ~description: "Access the assets of the contract." + ~input: empty + ~output: (wrap_tzerror Asset.Map.encoding) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "assets") + + type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + script: Script.t ; + assets: Asset.Map.t ; + counter: int32 ; + } + + let get custom_root = + RPC.service + ~description: "Access the complete status of a contract." + ~input: empty + ~output: + (wrap_tzerror @@ + conv + (fun {manager;balance;spendable;delegate;script;assets;counter} -> + (manager,balance,spendable,delegate,script,assets,counter)) + (fun (manager,balance,spendable,delegate,script,assets,counter) -> + {manager;balance;spendable;delegate;script;assets;counter}) @@ + obj7 + (req "manager" Ed25519.public_key_hash_encoding) + (req "balance" Tez.encoding) + (req "spendable" bool) + (req "delegate" @@ obj2 + (req "setable" bool) + (opt "value" Ed25519.public_key_hash_encoding)) + (dft "script" Script.encoding No_script) + (req "assets" Asset.Map.encoding) + (req "counter" int32)) + RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg) + + let list custom_root = + RPC.service + ~description: + "All existing contracts (including non-empty default contracts)." + ~input: empty + ~output: (wrap_tzerror @@ list Contract.encoding) + RPC.Path.(custom_root / "context" / "contracts") + + end + +end + +(*-- Helpers ----------------------------------------------------------------*) + +module Helpers = struct + + let minimal_timestamp custom_root = + RPC.service + ~description: "Minimal timestamp for the next block." + ~input: (obj1 (opt "priority" int31)) + ~output: (wrap_tzerror @@ + obj1 (req "timestamp" Timestamp.encoding)) + RPC.Path.(custom_root / "helpers" / "minimal_timestamp") + + let typecheck_code custom_root = + RPC.service + ~description: "Typecheck a piece of code in the current context" + ~input: Script.code_encoding + ~output: (wrap_tzerror empty) + RPC.Path.(custom_root / "helpers" / "typecheck_code") + + let level custom_root = + RPC.service + ~description: "..." + ~input: (obj1 + (opt "offset" int32)) + ~output: (wrap_tzerror @@ + describe ~title: "block level and cycle information" Level.encoding) + RPC.Path.(custom_root / "helpers" / "level" /: Raw_level.arg) + + let levels custom_root = + RPC.service + ~description: "Levels of a cycle" + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "levels of a cycle" (list Level.encoding)) + RPC.Path.(custom_root / "helpers" / "levels" /: Cycle.arg) + + module Rights = struct + + let slots_range_encoding = + (obj3 + (opt "max_priority" int31) + (opt "first_level" Raw_level.encoding) + (opt "last_level" Raw_level.encoding)) + + let slot_encoding = + (obj3 + (req "level" Raw_level.encoding) + (req "priority" int31) + (opt "timestamp" Timestamp.encoding)) + + let mining_rights custom_root = + RPC.service + ~description: + "List gelegates allowed to mine for the next level, \ + ordered by priority." + ~input: (obj1 (opt "max_priority" int31)) + ~output: (wrap_tzerror @@ + obj2 + (req "level" Raw_level.encoding) + (req "mining_rights" + (list + (obj2 + (req "delegate" Ed25519.public_key_hash_encoding) + (req "timestamp" Timestamp.encoding))))) + RPC.Path.(custom_root / "helpers" / "rights" / "mining") + + let mining_rights_for_level custom_root = + RPC.service + ~description: + "List delegate allowed to mine for a given level, \ + ordered by priority." + ~input: (obj1 (opt "max_priority" int31)) + ~output: (wrap_tzerror @@ + obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.public_key_hash_encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "mining" / "level" /: Raw_level.arg ) + + let mining_levels custom_root = + RPC.service + ~description: + "List level for which we might computed mining rights." + ~input: empty + ~output: (wrap_tzerror @@ + obj1 (req "levels" (list Raw_level.encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "mining" / "level" ) + + let mining_rights_for_delegate custom_root = + RPC.service + ~description: "Future mining rights for a given delegate." + ~input: slots_range_encoding + ~output: (wrap_tzerror (Data_encoding.list slot_encoding)) + RPC.Path.(custom_root / "helpers" / "rights" + / "mining" / "delegate" /: Context.Key.public_key_hash_arg ) + + let mining_delegates custom_root = + RPC.service + ~description: + "List delegates with mining rights." + ~input: empty + ~output: (wrap_tzerror @@ + obj1 (req "delegates" + (list Ed25519.public_key_hash_encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "mining" / "delegate" ) + + let endorsement_rights custom_root = + RPC.service + ~description: + "List delegates allowed to endorse for the current block." + ~input: (obj1 (opt "max_priority" int31)) + ~output: (wrap_tzerror @@ + obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.public_key_hash_encoding))) + RPC.Path.(custom_root / "helpers" / "rights" / "endorsement") + + let endorsement_rights_for_level custom_root = + RPC.service + ~description: + "List delegates allowed to endorse blocks for a given level." + ~input: (obj1 (opt "max_priority" int31)) + ~output: (wrap_tzerror @@ + obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.public_key_hash_encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "endorsement" / "level" /: Raw_level.arg ) + + let endorsement_levels custom_root = + RPC.service + ~description: + "List level for which we might computed endorsement rights." + ~input: empty + ~output: (wrap_tzerror @@ + obj1 (req "levels" (list Raw_level.encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "endorsement" / "level" ) + + let endorsement_rights_for_delegate custom_root = + RPC.service + ~description: "Compute endorsement rights for a given delegate." + ~input: slots_range_encoding + ~output: (wrap_tzerror @@ Data_encoding.list slot_encoding) + RPC.Path.(custom_root / "helpers" / "rights" + / "endorsement" / "delegate" /: Context.Key.public_key_hash_arg ) + + let endorsement_delegates custom_root = + RPC.service + ~description: + "List delegates with endorsement rights." + ~input: empty + ~output: (wrap_tzerror @@ + obj1 (req "delegates" + (list Ed25519.public_key_hash_encoding))) + RPC.Path.(custom_root / "helpers" / "rights" + / "endorsement" / "delegate" ) + + end + + module Forge = struct + + let operations custom_root = + RPC.service + ~description:"Forge an operation" + ~input: Operation.unsigned_operation_encoding + ~output: + (wrap_tzerror @@ + (obj2 + (req "operation" @@ + describe ~title: "hex encoded operation" bytes) + (opt "contracts" @@ + describe ~title: "new contracts" (list Contract.encoding)))) + RPC.Path.(custom_root / "helpers" / "forge" / "operations" ) + + let block_header custom_root = + RPC.service + ~description: "Forge a block header" + ~input: + (obj9 + (req "net_id" Updater.net_id_encoding) + (req "predecessor" Block_hash.encoding) + (req "timestamp" Timestamp.encoding) + (req "fitness" Fitness.encoding) + (req "operations" (list Operation_hash.encoding)) + (req "level" Raw_level.encoding) + (req "priority" int31) + (req "nonce_hash" Nonce_hash.encoding) + (req "proof_of_work_nonce" + (Fixed.bytes Tezos_context.Constants.proof_of_work_nonce_size))) + ~output: (wrap_tzerror bytes) + RPC.Path.(custom_root / "helpers" / "forge" / "block_header") + + end + + module Parse = struct + + let operations custom_root = + RPC.service + ~description:"Parse an operation" + ~input: + (obj3 + (req "shell" Updater.shell_operation_encoding) + (req "proto" + (describe ~title: "hex encoded operation" bytes)) + (opt "check_signature" bool)) + ~output: (wrap_tzerror Operation.proto_operation_encoding) + RPC.Path.(custom_root / "helpers" / "parse" / "operations" ) + + end + +end diff --git a/src/proto/bootstrap/services_registration.ml b/src/proto/bootstrap/services_registration.ml new file mode 100644 index 000000000..fc3165822 --- /dev/null +++ b/src/proto/bootstrap/services_registration.ml @@ -0,0 +1,425 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_context + +let rpc_services = ref (RPC.empty : Context.t RPC.directory) +let register0 s f = + rpc_services := + RPC.register !rpc_services (s RPC.Path.root) + (fun ctxt () -> + ( Tezos_context.init ctxt >>=? fun ctxt -> + f ctxt ) >>= RPC.Answer.return) +let register1 s f = + rpc_services := + RPC.register !rpc_services (s RPC.Path.root) + (fun ctxt arg -> + ( Tezos_context.init ctxt >>=? fun ctxt -> + f ctxt arg ) >>= RPC.Answer.return) +let register2 s f = + rpc_services := + RPC.register !rpc_services (s RPC.Path.root) + (fun (ctxt, arg1) arg2 -> + ( Tezos_context.init ctxt >>=? fun ctxt -> + f ctxt arg1 arg2 ) >>= RPC.Answer.return) +let register1_noctxt s f = + rpc_services := + RPC.register !rpc_services (s RPC.Path.root) + (fun _ arg -> f arg >>= RPC.Answer.return) + +(*-- Constants ---------------------------------------------------------------*) + +let cycle_length ctxt = + return @@ Constants.cycle_length ctxt + +let () = register0 Services.Constants.cycle_length cycle_length + +let voting_period_length ctxt = + return @@ Constants.voting_period_length ctxt + +let () = + register0 + Services.Constants.voting_period_length + voting_period_length + +let time_before_reward ctxt = + return @@ Constants.time_before_reward ctxt + +let () = register0 Services.Constants.time_before_reward time_before_reward + +let time_between_slots ctxt = + return @@ Constants.time_between_slots ctxt + +let () = register0 Services.Constants.time_between_slots time_between_slots + +let first_free_mining_slot ctxt = + return @@ Constants.first_free_mining_slot ctxt + +let () = + register0 Services.Constants.first_free_mining_slot first_free_mining_slot + +let max_signing_slot ctxt = + return @@ Constants.max_signing_slot ctxt + +let () = register0 Services.Constants.max_signing_slot max_signing_slot + +let instructions_per_transaction ctxt = + return @@ Constants.instructions_per_transaction ctxt + +let () = + register0 + Services.Constants.instructions_per_transaction instructions_per_transaction + +let proof_of_work_threshold ctxt = + return @@ Constants.proof_of_work_threshold ctxt + +let () = register0 Services.Constants.proof_of_work_threshold proof_of_work_threshold + +let () = + register1_noctxt Services.Constants.errors + (fun () -> + Lwt.return (Data_encoding.Json.(schema (error_encoding ())))) + +let () = + register1_noctxt Services.Constants.bootstrap + (fun () -> Lwt.return Bootstrap.accounts) + +(*-- Context -----------------------------------------------------------------*) + +let level ctxt = + Level.current ctxt >>=? fun level -> + match Level.pred ctxt level with + | None -> fail (Apply.Internal_error "unexpected level in context") + | Some level -> return level + +let () = register0 Services.Context.level level + +let next_level ctxt = + Level.current ctxt + +let () = register0 Services.Context.next_level next_level + +(*-- Context.Nonce -----------------------------------------------------------*) + +let nonce ctxt raw_level () = + let level = Level.from_raw ctxt raw_level in + Nonce.get ctxt level >>= function + | Ok (Revealed nonce) -> return (Services.Context.Nonce.Revealed nonce) + | Ok (Unrevealed { nonce_hash }) -> + return (Services.Context.Nonce.Missing nonce_hash) + | Error _ -> return Services.Context.Nonce.Forgotten + +let () = register2 Services.Context.Nonce.get nonce + +let nonce_hash ctxt = + level ctxt >>=? fun level -> + Nonce.get ctxt level >>=? function + | Unrevealed { nonce_hash } -> return nonce_hash + | _ -> assert false + +let () = register0 Services.Context.Nonce.hash nonce_hash + +(*-- Context.Key -------------------------------------------------------------*) + +let get_key ctxt hash () = + Public_key.get ctxt hash >>=? fun pk -> + return (hash, pk) + +let () = register2 Services.Context.Key.get get_key +let () = register0 Services.Context.Key.list Public_key.list + +(*-- Context.Contract --------------------------------------------------------*) + +let () = + register0 Services.Context.Contract.list Contract.list + +let () = + let register2 s f = + rpc_services := + RPC.register !rpc_services (s RPC.Path.root) + (fun (ctxt, contract) arg -> + ( Tezos_context.init ctxt >>=? fun ctxt -> + Contract.exists ctxt contract >>=? function + | true -> f ctxt contract arg + | false -> raise Not_found ) >>= RPC.Answer.return) in + let register2' s f = register2 s (fun ctxt a1 () -> f ctxt a1) in + register2' Services.Context.Contract.balance Contract.get_balance ; + register2' Services.Context.Contract.manager Contract.get_manager ; + register2' Services.Context.Contract.delegate Contract.get_delegate_opt ; + register2' Services.Context.Contract.counter Contract.get_counter ; + register2' Services.Context.Contract.spendable Contract.is_spendable ; + register2' Services.Context.Contract.delegatable Contract.is_delegatable ; + register2' Services.Context.Contract.script Contract.get_script ; + register2' Services.Context.Contract.assets Contract.get_assets ; + register2' Services.Context.Contract.get (fun ctxt contract -> + Contract.get_balance ctxt contract >>=? fun balance -> + Contract.get_manager ctxt contract >>=? fun manager -> + Contract.get_delegate_opt ctxt contract >>=? fun delegate -> + Contract.get_counter ctxt contract >>=? fun counter -> + Contract.is_delegatable ctxt contract >>=? fun delegatable -> + Contract.is_spendable ctxt contract >>=? fun spendable -> + Contract.get_script ctxt contract >>=? fun script -> + Contract.get_assets ctxt contract >>=? fun assets -> + return { Services.Context.Contract.manager ; balance ; + spendable ; delegate = (delegatable, delegate) ; + script ; assets ; counter }) ; + () + +(*-- Helpers -----------------------------------------------------------------*) + +let minimal_timestamp ctxt prio = + let prio = match prio with None -> 0l | Some p -> Int32.of_int p in + Mining.minimal_time ctxt prio + +let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp + +let () = + register1 Services.Helpers.typecheck_code + Script_ir_translator.typecheck_code + +let compute_level ctxt raw offset = + return (Level.from_raw ctxt ?offset raw) + +let () = register2 Services.Helpers.level compute_level + +let levels ctxt cycle () = + return (Level.levels_in_cycle ctxt cycle) + +let () = register2 Services.Helpers.levels levels + + +(*-- Helpers.Rights ----------------------------------------------------------*) + +let default_max_mining_priority ctxt arg = + let default = Constants.first_free_mining_slot ctxt in + match arg with + | None -> Int32.mul 2l default + | Some m -> Int32.of_int m + +let mining_rights ctxt level max = + let max = Int32.to_int (default_max_mining_priority ctxt max) in + Mining.mining_priorities ctxt level >>=? fun contract_list -> + let rec loop l n = + match n with + | 0 -> return [] + | n -> + let Misc.LCons (h, t) = l in + t () >>=? fun t -> + loop t (pred n) >>=? fun t -> + return (h :: t) + in + loop contract_list max >>=? fun prio -> + return (level.level, prio) + +let () = + register1 Services.Helpers.Rights.mining_rights + (fun ctxt max -> + Level.current ctxt >>=? fun level -> + mining_rights ctxt level max >>=? fun (raw_level, slots) -> + begin + Lwt_list.filter_map_p (fun x -> x) @@ + List.mapi + (fun prio c -> + Mining.minimal_time + ctxt (Int32.of_int prio) >>= function + | Error _ -> Lwt.return None + | Ok timestamp -> Lwt.return (Some (c, timestamp))) + slots + end >>= fun timed_slots -> + return (raw_level, timed_slots)) + +let () = + register2 Services.Helpers.Rights.mining_rights_for_level + (fun ctxt raw_level max -> + let level = Level.from_raw ctxt raw_level in + mining_rights ctxt level max) + +let mining_rights_for_delegate + ctxt contract (max_priority, min_level, max_level) = + let max_priority = default_max_mining_priority ctxt max_priority in + Level.current ctxt >>=? fun current_level -> + let max_level = + match max_level with + | None -> + Level.last_level_in_cycle ctxt @@ + Cycle.succ current_level.cycle + | Some l -> Level.from_raw ctxt l in + let min_level = match min_level with + | None -> current_level + | Some l -> Level.from_raw ctxt l in + let rec loop level = + if Level.(>) level max_level + then return [] + else + loop (Level.succ ctxt level) >>=? fun t -> + Mining.first_mining_priorities + ctxt ~max_priority contract level >>=? fun priorities -> + let raw_level = level.level in + Lwt_list.map_p + (fun priority -> + Mining.minimal_time ctxt priority >>= function + | Ok time -> Lwt.return (raw_level, Int32.to_int priority, Some time) + | Error _ -> Lwt.return (raw_level, Int32.to_int priority, None)) + priorities >>= fun priorities -> + return (priorities @ t) + in + loop min_level + +let () = + register2 Services.Helpers.Rights.mining_rights_for_delegate + mining_rights_for_delegate + +let default_max_endorsement_priority ctxt arg = + let default = Constants.max_signing_slot ctxt in + match arg with + | None -> default + | Some m -> m + +let endorsement_rights ctxt level max = + let max = default_max_endorsement_priority ctxt max in + Mining.endorsement_priorities ctxt level >>=? fun contract_list -> + let rec loop l n = + match n with + | 0 -> return [] + | n -> + let Misc.LCons (h, t) = l in + t () >>=? fun t -> + loop t (pred n) >>=? fun t -> + return (h :: t) + in + loop contract_list max >>=? fun prio -> + return (level.level, prio) + +let () = + register1 Services.Helpers.Rights.endorsement_rights + (fun ctxt max -> + Level.current ctxt >>=? fun level -> + endorsement_rights ctxt (Level.succ ctxt level) max) ; + register2 Services.Helpers.Rights.endorsement_rights_for_level + (fun ctxt raw_level max -> + let level = Level.from_raw ctxt raw_level in + endorsement_rights ctxt level max) + +let endorsement_rights_for_delegate + ctxt contract (max_priority, min_level, max_level) = + let max_priority = + Int32.of_int @@ + default_max_endorsement_priority ctxt max_priority in + Level.current ctxt >>=? fun current_level -> + let max_level = + match max_level with + | None -> + Level.last_level_in_cycle ctxt @@ + Cycle.succ (Cycle.succ current_level.cycle) + | Some l -> Level.from_raw ctxt l in + let min_level = match min_level with + | None -> Level.succ ctxt current_level + | Some l -> Level.from_raw ctxt l in + let rec loop level = + if Level.(>) level max_level + then return [] + else + loop (Level.succ ctxt level) >>=? fun t -> + Mining.first_endorsement_slots + ctxt ~max_priority contract level >>=? fun slots -> + let raw_level = level.level in + let slots = + List.rev_map + (fun slot -> (raw_level, Int32.to_int slot, None)) + slots in + return (List.rev_append slots t) + in + loop min_level + +let () = + register2 Services.Helpers.Rights.endorsement_rights_for_delegate + endorsement_rights_for_delegate + +(*-- Helpers.Forge -----------------------------------------------------------*) + +let operation_public_key ctxt = function + | None -> return None + | Some public_key -> + let hash = Ed25519.hash public_key in + Public_key.get_option ctxt hash >>=? function + | None -> return (Some public_key) + | Some _ -> return None + +let get_contracts ctxt op = + match op with + | Anonymous_operations _ + | Sourced_operations (Delegate_operations _) -> return (ctxt, None) + | Sourced_operations (Manager_operations { operations }) -> + fold_left_s + (fun (ctxt, contracts) operation -> + match operation with + | Origination { manager ; delegate ; script ; + spendable ; delegatable ; credit } -> + Contract.originate ctxt + ~balance:credit ~manager ~delegate + ~spendable ~delegatable ~script >>=? fun (ctxt, contract) -> + return (ctxt, contract :: contracts) + | _ -> return (ctxt, contracts)) + (ctxt, []) operations >>=? fun (ctxt, contracts) -> + match contracts with + | [] -> return (ctxt, None) + | _ -> return (ctxt, Some (List.rev contracts)) + +let forge_operations ctxt (shell, proto) = + get_contracts ctxt proto >>=? fun (_ctxt, contracts) -> + return (Operation.forge shell proto, contracts) + +let () = register1 Services.Helpers.Forge.operations forge_operations + +let forge_block_header _ctxt + (net_id, predecessor, timestamp, fitness, operations, + raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = + let priority = Int32.of_int priority in + let mining_slot = (raw_level, priority) in + return (Block.forge_header + { net_id ; predecessor ; timestamp ; fitness ; operations } + { mining_slot ; seed_nonce_hash ; proof_of_work_nonce }) + +let () = register1 Services.Helpers.Forge.block_header forge_block_header + +(*-- Helpers.Parse -----------------------------------------------------------*) + +let dummy_hash = Operation_hash.hash_bytes [] + +let check_signature ctxt signature shell contents = + match contents with + | Anonymous_operations _ -> return () + | Sourced_operations (Manager_operations op) -> + begin + match op.public_key with + | Some key -> return key + | None -> + Contract.get_manager ctxt op.source >>=? fun manager -> + Public_key.get ctxt manager + end >>=? fun public_key -> + Operation.check_signature public_key + { signature ; shell ; contents ; hash = dummy_hash } + | Sourced_operations (Delegate_operations { source }) -> + Operation.check_signature source + { signature ; shell ; contents ; hash = dummy_hash } + +let parse_operations ctxt (shell, bytes, check) = + Operation.parse_proto bytes >>=? fun (proto, signature) -> + begin + match check with + | Some true -> check_signature ctxt signature shell proto + | Some false | None -> return () + end >>=? fun () -> + return proto + +let () = register1 Services.Helpers.Parse.operations parse_operations + +(*****) + +let rpc_services = !rpc_services diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml new file mode 100644 index 000000000..9dfed0a9a --- /dev/null +++ b/src/proto/bootstrap/storage.ml @@ -0,0 +1,517 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_hash +open Storage_functors + +let version = "v1" +let sandboxed_key = [ version ; "sandboxed" ] +let prevalidation_key = [ version ; "prevalidation" ] + +type t = Storage_functors.context + +type error += Invalid_sandbox_parameter of string + +let get_sandboxed c = + Context.get c sandboxed_key >>= function + | None -> return None + | Some json -> + match Data_encoding.Json.from_string (MBytes.to_string json) with + | Error err -> fail (Invalid_sandbox_parameter err) + | Ok json -> return (Some json) + +let set_sandboxed c json = + Context.set c sandboxed_key + (MBytes.of_string (Data_encoding.Json.to_string json)) + +let prepare (c : Context.t) : t tzresult Lwt.t = + get_sandboxed c >>=? fun sandbox -> + Constants_repr.read sandbox >>=? function constants -> + return (c, constants) +let recover (c, _ : t) : Context.t = c + +let get_prevalidation (c, _ : t) = + Context.get c prevalidation_key >>= function + | None -> Lwt.return false + | Some _ -> Lwt.return true +let set_prevalidation (c, constants : t) = + Context.set c prevalidation_key (MBytes.of_string "prevalidation") >>= fun c -> + Lwt.return (c, constants) + + +let constants : t -> _ = snd + +module Key = struct + + let store_root tail = version :: "store" :: tail + + let current_level = store_root ["level"] + let current_timestamp = store_root ["timestamp"] + let current_fitness = store_root ["fitness"] + + let global_counter = store_root ["global_counter"] + + let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"] + let rewards = store_root ["rewards"] + + module Roll = struct + let store_root l = store_root ("rolls" :: l) + let next = store_root [ "next" ] + let limbo = store_root [ "limbo" ] + let roll_store roll l = + store_root @@ Int32.to_string (Roll_repr.to_int32 roll) :: l + let successor r = roll_store r ["successor"] + let owner r = roll_store r ["owner"] + end + + module Cycle = struct + let store_root l = store_root ("cycles" :: l) + let cycle_store c l = + store_root @@ Int32.to_string (Cycle_repr.to_int32 c) :: l + let last_roll c = cycle_store c [ "last_roll" ] + let random_seed c = cycle_store c [ "random_seed" ] + let reward_date c = cycle_store c [ "reward_date" ] + let roll_owner (c, r) = + cycle_store c [ "roll_owners" ; Int32.to_string (Roll_repr.to_int32 r)] + let unrevealed_nonce_hash l = + let c = l.Level_repr.cycle in + cycle_store c [ "unrevealed_nonce_hash" ; + Int32.to_string l.Level_repr.cycle_position ] + end + + module Contract = struct + let store_root l = store_root ("contracts" :: l) + let set = store_root ["set"] + let contract_store c l = + store_root @@ + match c with + | Contract_repr.Default k -> + "pubkey" :: Ed25519.hash_path k @ l + | Contract_repr.Hash h -> + "generic" :: Contract_hash.to_path h @ l + let roll_list c = contract_store c ["roll_list"] + let change c = contract_store c ["change"] + let balance c = contract_store c ["balance"] + let assets c = contract_store c ["assets"] + let manager c = contract_store c ["manager"] + let spendable c = contract_store c ["spendable"] + let delegatable c = contract_store c ["delegatable"] + let delegate c = contract_store c ["delegate"] + let counter c = contract_store c ["counter"] + let code c = contract_store c ["code"] + let storage c = contract_store c ["storage"] + end + + module Vote = struct + let store_root l = store_root ("votes" :: l) + let period_kind = store_root ["current_period_kind"] + let quorum = store_root ["current_quorum"] + let proposition = store_root ["current_proposition"] + let proposals = store_root ["proposals"] + let ballots = store_root ["ballots"] + let listings_size = store_root ["listings_size"] + let listings = store_root ["listings"] + end + +end + +(** Global *) + +module Current_level = + Make_single_data_storage(struct + type value = Raw_level_repr.t + let name = "level" + let key = Key.current_level + let encoding = Raw_level_repr.encoding + end) + +module Current_timestamp = + Make_single_data_storage(struct + type value = Time_repr.t + let name = "timestamp" + let key = Key.current_timestamp + let encoding = Time_repr.encoding + end) + +module Current_fitness = + Make_single_data_storage(struct + type value = int64 + let name = "fitness" + let key = Key.current_fitness + let encoding = Data_encoding.int64 + end) + +(** Rolls *) + +module Roll = struct + + module Next = + Make_single_data_storage(struct + type value = Roll_repr.t + let name = "next fresh roll" + let key = Key.Roll.next + let encoding = Roll_repr.encoding + end) + + module Limbo = + Make_single_optional_data_storage(struct + type value = Roll_repr.t + let name = "limbo" + let key = Key.Roll.limbo + let encoding = Roll_repr.encoding + end) + + module Last_for_cycle = + Make_indexed_data_storage(struct + type key = Cycle_repr.t + type value = Roll_repr.t + let name = "last roll for current cycle" + let key = Key.Cycle.last_roll + let encoding = Roll_repr.encoding + end) + + module Successor = + Make_indexed_optional_data_storage(struct + type key = Roll_repr.t + type value = Roll_repr.t + let name = "roll successor" + let key = Key.Roll.successor + let encoding = Roll_repr.encoding + end) + + module Owner = + Make_indexed_data_storage(struct + type key = Roll_repr.t + type value = Contract_repr.t + let name = "roll owner" + let key = Key.Roll.owner + let encoding = Contract_repr.encoding + end) + + module Owner_for_cycle = + Make_indexed_data_storage(struct + type key = Cycle_repr.t * Roll_repr.t + type value = Ed25519.public_key_hash + let name = "roll owner for current cycle" + let key = Key.Cycle.roll_owner + let encoding = Ed25519.public_key_hash_encoding + end) + + module Contract_roll_list = + Make_indexed_optional_data_storage(struct + type key = Contract_repr.t + type value = Roll_repr.t + let name = "contract roll list" + let key = Key.Contract.roll_list + let encoding = Roll_repr.encoding + end) + + module Contract_change = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Tez_repr.t + let name = "contract change" + let key = Key.Contract.change + let encoding = Tez_repr.encoding + end) + +end + +(** Contracts handling *) + +module Contract = struct + + module Global_counter = + Make_single_data_storage(struct + type value = int32 + let name = "global counter" + let key = Key.global_counter + let encoding = Data_encoding.int32 + end) + + module Set = + Make_data_set_storage(struct + type value = Contract_repr.t + let name = "contract set" + let key = Key.Contract.set + let encoding = Contract_repr.encoding + end) + + module Balance = + Make_indexed_data_storage( + struct + type key = Contract_repr.t + type value = Tez_repr.t + let name = "contract balance" + let key = Key.Contract.balance + let encoding = Tez_repr.encoding + end) + + module Assets = + Make_indexed_data_storage( + struct + type key = Contract_repr.t + type value = Asset_repr.Map.t + let name = "contract assets" + let key = Key.Contract.assets + let encoding = Asset_repr.Map.encoding + end) + + module Manager = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Ed25519.public_key_hash + let name = "contract manager" + let key = Key.Contract.manager + let encoding = Ed25519.public_key_hash_encoding + end) + + module Spendable = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = bool + let name = "contract spendable" + let key = Key.Contract.spendable + let encoding = Data_encoding.bool + end) + + module Delegatable = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = bool + let name = "contract delegatable" + let key = Key.Contract.delegatable + let encoding = Data_encoding.bool + end) + + module Delegate = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Ed25519.public_key_hash + let name = "contract delegate" + let key = Key.Contract.delegate + let encoding = Ed25519.public_key_hash_encoding + end) + + module Counter = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Int32.t + let name = "contract counter" + let key = Key.Contract.counter + let encoding = Data_encoding.int32 + end) + + module Code = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Script_repr.code + let name = "contract code" + let key = Key.Contract.code + let encoding = Script_repr.code_encoding + end) + + module Storage = + Make_indexed_data_storage(struct + type key = Contract_repr.t + type value = Script_repr.storage + let name = "contract storage" + let key = Key.Contract.storage + let encoding = Script_repr.storage_encoding + end) + +end + +(** Votes **) + +module Vote = struct + + module Current_period_kind = + Make_single_data_storage(struct + type value = Voting_period_repr.kind + let name = "current period kind" + let key = Key.Vote.period_kind + let encoding = Voting_period_repr.kind_encoding + end) + + module Current_quorum = + Make_single_data_storage(struct + type value = int32 + let name = "current quorum" + let key = Key.Vote.quorum + let encoding = Data_encoding.int32 + end) + + module Current_proposal = + Make_single_data_storage(struct + type value = Protocol_hash.t + let name = "current proposal" + let key = Key.Vote.proposition + let encoding = Protocol_hash.encoding + end) + + module Listings_size = + Make_single_data_storage(struct + type value = int32 + let name = "listing size" + let key = Key.Vote.listings_size + let encoding = Data_encoding.int32 + end) + + module Listings = + Make_iterable_data_storage (Ed25519.Public_key_hash) + (struct + type value = int32 + let key = Key.Vote.listings + let name = "listings" + let encoding = Data_encoding.int32 + end) + + module Proposals = + Make_data_set_storage + (struct + type value = Protocol_hash.t * Ed25519.public_key_hash + let name = "proposals" + let encoding = + Data_encoding.tup2 + Protocol_hash.encoding Ed25519.Public_key_hash.encoding + let key = Key.Vote.proposals + end) + + module Ballots = + Make_iterable_data_storage (Ed25519.Public_key_hash) + (struct + type value = Vote_repr.ballot + let key = Key.Vote.ballots + let name = "ballot" + let encoding = Vote_repr.ballot_encoding + end) + +end + +(** Keys *) + +module Public_key = + Make_iterable_data_storage (Ed25519.Public_key_hash) + (struct + type value = Ed25519.public_key + let key = ["public_keys"] + let name = "public keys" + let encoding = Ed25519.public_key_encoding + end) + +(** Seed *) + +module Seed = struct + + type nonce_status = + | Unrevealed of { + nonce_hash: Tezos_hash.Nonce_hash.t ; + delegate_to_reward: Ed25519.public_key_hash ; + reward_amount: Tez_repr.t ; + } + | Revealed of Seed_repr.nonce + + module Nonce = + Make_indexed_data_storage(struct + type key = Level_repr.level + type value = nonce_status + let name = "unrevealed nonce hash" + let key = Key.Cycle.unrevealed_nonce_hash + let encoding = + let open Data_encoding in + union [ + case ~tag:0 + (tup3 + Nonce_hash.encoding + Ed25519.Public_key_hash.encoding + Tez_repr.encoding + ) + (function + | Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount } -> + Some (nonce_hash, delegate_to_reward, reward_amount) + | _ -> None) + (fun (nonce_hash, delegate_to_reward, reward_amount) -> + Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ; + case ~tag:1 + Seed_repr.nonce_encoding + (function + | Revealed nonce -> Some nonce + | _ -> None) + (fun nonce -> Revealed nonce) + ] + end) + + module For_cycle = + Make_indexed_data_storage(struct + type key = Cycle_repr.t + type value = Seed_repr.seed + let name = "cycle random seed" + let key = Key.Cycle.random_seed + let encoding = Seed_repr.seed_encoding + end) + +end + +(** Rewards *) + +module Rewards = struct + + module Next = + Make_single_data_storage(struct + type value = Cycle_repr.t + let name = "reward cycle" + let key = Key.next_cycle_to_be_rewarded + let encoding = Cycle_repr.encoding + end) + + module Date = + Make_indexed_data_storage(struct + type key = Cycle_repr.t + type value = Time_repr.t + let name = "reward timestamp" + let key = Key.Cycle.reward_date + let encoding = Time_repr.encoding + end) + + module Amount = + Raw_make_iterable_data_storage(struct + type t = Ed25519.public_key_hash * Cycle_repr.t + let prefix = Key.rewards + let length = Ed25519.Public_key_hash.path_len + 1 + let to_path (pkh, c) = + Ed25519.Public_key_hash.to_path pkh @ + [Int32.to_string (Cycle_repr.to_int32 c)] + let of_path p = + match List.rev p with + | [] -> assert false + | cycle :: rev_pkh -> + (Ed25519.Public_key_hash.of_path (List.rev rev_pkh), + Cycle_repr.of_int32_exn @@ Int32.of_string cycle) + let compare (pkh1, c1) (pkh2, c2) = + let cmp1 = Ed25519.Public_key_hash.compare pkh1 pkh2 in + if Compare.Int.(cmp1 = 0) then Cycle_repr.compare c1 c2 + else cmp1 + end)(struct + type value = Tez_repr.t + let name = "level miner contract" + let encoding = Tez_repr.encoding + end) + +end + +let get_genesis_block (c, _) = Context.get_genesis_block c +let get_genesis_time (c, _) = Context.get_genesis_time c + +let activate (c, constants) h = + Updater.activate c h >>= fun c -> Lwt.return (c, constants) +let fork_test_network (c, constants) = + Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants) +let set_test_protocol (c, constants) h = + Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants) diff --git a/src/proto/bootstrap/storage.mli b/src/proto/bootstrap/storage.mli new file mode 100644 index 000000000..e96da9d93 --- /dev/null +++ b/src/proto/bootstrap/storage.mli @@ -0,0 +1,274 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Typed storage accessors + + This module hides the hierarchical (key x value) database under + pre-allocated typed accessors for all persistent entities of the + tezos context. + + This interface enforces no invariant on the contents of the + database. Its goal is to centralize all accessors in order to have + a complete view over the database contents and avoid key + collisions. *) + + +(** {1 Abstract Context} *****************************************************) + +(** Abstract view of the database *) +type t + +(** Rerieves the state of the database and gives its abstract view *) +val prepare : Context.t -> t tzresult Lwt.t + +(** Returns the state of the database resulting of operations on its + abstract view *) +val recover : t -> Context.t + +val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t +val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t + +val get_prevalidation : t -> bool Lwt.t +val set_prevalidation : t -> t Lwt.t + +val constants : t -> Constants_repr.constants + +(** {1 Entity Accessors} *****************************************************) + +open Storage_sigs + +(** The level of the current block *) +module Current_level : Single_data_storage + with type value = Raw_level_repr.t + and type context := t + +(** The level of the current block *) +module Current_timestamp : Single_data_storage + with type value = Time.t + and type context := t + +(** The fitness of the current block, which is the number of ancestor + blocks in the chain as an [int64] *) +module Current_fitness : Single_data_storage + with type value = int64 + and type context := t + +module Roll : sig + + (** Storage from this submodule must only be accessed through the + module `Roll`. *) + + module Owner : Indexed_data_storage + with type key = Roll_repr.t + and type value = Contract_repr.t + and type context := t + + module Last_for_cycle : Indexed_data_storage + with type key = Cycle_repr.t + and type value = Roll_repr.t + and type context := t + + module Owner_for_cycle : Indexed_data_storage + with type key = Cycle_repr.t * Roll_repr.t + and type value = Ed25519.public_key_hash + and type context := t + + (** The next roll to be allocated. *) + module Next : Single_data_storage + with type value = Roll_repr.t + and type context := t + + (** Rolls linked lists represent both account owned and free rolls. + All rolls belongs either to the limbo list or to an owned list. *) + module Successor : Indexed_optional_data_storage + with type key = Roll_repr.t + and type value = Roll_repr.t + and type context := t + + module Limbo : Single_optional_data_storage + with type value = Roll_repr.t + and type context := t + + module Contract_roll_list : Indexed_optional_data_storage + with type key = Contract_repr.t + and type value = Roll_repr.t + and type context := t + + (** The tez of a contract that are not assigned to rolls *) + module Contract_change : Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type context := t + +end + +module Contract : sig + + (** Storage from this submodule must only be accessed through the + module `Contract`. *) + + module Global_counter : sig + val get : t -> int32 tzresult Lwt.t + val set : t -> int32 -> t tzresult Lwt.t + val init : t -> int32 -> t tzresult Lwt.t + end + + (** The domain of alive contracts *) + module Set : Data_set_storage + with type value = Contract_repr.t + and type context := t + + (** All the tez possesed by a contract, including rolls and change *) + module Balance : Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type context := t + + module Assets : Indexed_data_storage + with type key = Contract_repr.t + and type value = Asset_repr.Map.t + and type context := t + + (** The manager of a contract *) + module Manager : Indexed_data_storage + with type key = Contract_repr.t + and type value = Ed25519.public_key_hash + and type context := t + + (** The delegate of a contract, if any. *) + module Delegate : Indexed_data_storage + with type key = Contract_repr.t + and type value = Ed25519.public_key_hash + and type context := t + + module Spendable : Indexed_data_storage + with type key = Contract_repr.t + and type value = bool + and type context := t + + module Delegatable : Indexed_data_storage + with type key = Contract_repr.t + and type value = bool + and type context := t + + module Counter : Indexed_data_storage + with type key = Contract_repr.t + and type value = int32 + and type context := t + + module Code : Indexed_data_storage + with type key = Contract_repr.t + and type value = Script_repr.code + and type context := t + + module Storage : Indexed_data_storage + with type key = Contract_repr.t + and type value = Script_repr.storage + and type context := t + +end + +(** Votes *) + +module Vote : sig + + module Current_period_kind : Single_data_storage + with type value = Voting_period_repr.kind + and type context := t + + module Current_quorum : Single_data_storage + with type value = int32 (* in centile of percentage *) + and type context := t + + module Current_proposal : Single_data_storage + with type value = Protocol_hash.t + and type context := t + + module Listings_size : Single_data_storage + with type value = int32 (* total number of rolls in the listing. *) + and type context := t + + module Listings : Iterable_data_storage + with type key = Ed25519.public_key_hash + and type value = int32 (* number of rolls for the key. *) + and type context := t + + module Proposals : Data_set_storage + with type value = Protocol_hash.t * Ed25519.public_key_hash + and type context := t + + module Ballots : Iterable_data_storage + with type key = Ed25519.public_key_hash + and type value = Vote_repr.ballot + and type context := t + +end + + +(** Keys *) + +module Public_key : Iterable_data_storage + with type key = Ed25519.public_key_hash + and type value = Ed25519.public_key + and type context := t + +(** Seed *) + +module Seed : sig + + (** Storage from this submodule must only be accessed through the + module `Seed`. *) + + type nonce_status = + | Unrevealed of { + nonce_hash: Tezos_hash.Nonce_hash.t ; + delegate_to_reward: Ed25519.public_key_hash ; + reward_amount: Tez_repr.t ; + } + | Revealed of Seed_repr.nonce + + module Nonce : Indexed_data_storage + with type key = Level_repr.t + and type value = nonce_status + and type context := t + + module For_cycle : sig + val init : t -> Cycle_repr.t -> Seed_repr.seed -> t tzresult Lwt.t + val get : t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + val delete : t -> Cycle_repr.t -> t tzresult Lwt.t + end + +end + +(** Rewards *) + +module Rewards : sig + + module Next : Single_data_storage + with type value = Cycle_repr.t + and type context := t + + module Date : Indexed_data_storage + with type key = Cycle_repr.t + and type value = Time.t + and type context := t + + module Amount : Iterable_data_storage + with type key = Ed25519.public_key_hash * Cycle_repr.t + and type value = Tez_repr.t + and type context := t + +end + +val get_genesis_time: t -> Time.t Lwt.t +val get_genesis_block: t -> Block_hash.t Lwt.t + +val activate: t -> Protocol_hash.t -> t Lwt.t +val set_test_protocol: t -> Protocol_hash.t -> t Lwt.t +val fork_test_network: t -> t Lwt.t diff --git a/src/proto/bootstrap/storage_functors.ml b/src/proto/bootstrap/storage_functors.ml new file mode 100644 index 000000000..1bbf874d7 --- /dev/null +++ b/src/proto/bootstrap/storage_functors.ml @@ -0,0 +1,354 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Typed storage accessor builders *) + +open Misc + +type context = Context.t * Constants_repr.constants + +(*-- Errors ------------------------------------------------------------------*) + +type error += Storage_error of string + +let () = + let open Data_encoding in + register_error_kind `Permanent + ~id:"storageError" + ~title: "Storage error (fatal internal error)" + ~description: + "An error that should never happen unless something \ + has been deleted or corrupted in the database" + ~pp:(fun ppf msg -> + Format.fprintf ppf "@[Storage error:@ %a@]" + pp_print_paragraph msg) + (obj1 (req "msg" string)) + (function Storage_error msg -> Some msg | _ -> None) + (fun msg -> Storage_error msg) + +(*-- Generic data accessor ---------------------------------------------------*) + +module type Raw_data_description = sig + type key + type value + val name : string + val key : key -> string list + val of_bytes : MBytes.t -> value tzresult + val to_bytes : value -> MBytes.t +end + +module Make_raw_data_storage (P : Raw_data_description) = struct + + type key = P.key + type value = P.value + + let key k = P.key k + + let key_to_string l = String.concat "/" (key l) + + let get (c, _) k = + Context.get c (key k) >>= function + | None -> + let msg = + "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | Some bytes -> + Lwt.return (P.of_bytes bytes) + + let mem (c, _) k = Context.mem c (key k) + + let get_option (c, _) k = + Context.get c (key k) >>= function + | None -> return None + | Some bytes -> + Lwt.return (P.of_bytes bytes >|? fun v -> Some v) + + (* Verify that the key is present before modifying *) + let set (c, x) k v = + let key = key k in + Context.get c key >>= function + | None -> + let msg = + "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | Some old -> + let bytes = P.to_bytes v in + if MBytes.(old = bytes) then + return (c, x) + else + Context.set c key (P.to_bytes v) >>= fun c -> + return (c, x) + + (* Verify that the key is not present before inserting *) + let init (c, x) k v = + let key = key k in + Context.get c key >>= + function + | Some _ -> + let msg + = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | None -> + Context.set c key (P.to_bytes v) >>= fun c -> + return (c, x) + + (* Does not verify that the key is present or not *) + let init_set (c, x) k v = + Context.set c (key k) (P.to_bytes v) >>= fun c -> return (c, x) + + (* Verify that the key is present before deleting *) + let delete (c, x) k = + let key = key k in + Context.get c key >>= function + | Some _ -> + Context.del c key >>= fun c -> + return (c, x) + | None -> + let msg = + "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + + (* Do not verify before deleting *) + let remove (c, x) k = + Context.del c (key k) >>= fun c -> Lwt.return (c, x) + +end + +(*-- Indexed data accessor ---------------------------------------------------*) + +module type Data_description = sig + type value + val name : string + val encoding : value Data_encoding.t +end + +module type Indexed_data_description = sig + type key + val key : key -> string list + include Data_description +end + +module Make_indexed_data_storage (P : Indexed_data_description) = + Make_raw_data_storage(struct + include P + + let of_bytes b = + match Data_encoding.Binary.of_bytes P.encoding b with + | None -> + let msg = + "cannot deserialize " ^ P.name ^ " value" in + error (Storage_error msg) + | Some v -> Ok v + let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v + end) + +module Make_indexed_optional_data_storage (P : Indexed_data_description) = struct + module Raw = Make_indexed_data_storage(P) + type key = P.key + type value = P.value + let get = Raw.get_option + let mem = Raw.mem + let set c k r = + match r with + | None -> Raw.remove c k >>= fun c -> return c + | Some r -> Raw.init_set c k r +end + +(*-- Single data accessor ----------------------------------------------------*) + +module type Single_data_description = sig + val key : string list + include Data_description +end + +module Make_single_data_storage (P : Single_data_description) = struct + module Single_desc = struct + type value = P.value + type key = unit + let encoding = P.encoding + let name = P.name + let key () = P.key + end + include Make_indexed_data_storage(Single_desc) + let get c = get c () + let mem c = mem c () + let get_option c = get_option c () + let set c r = set c () r + let init c r = init c () r + let init_set c r = init_set c () r + let remove c = remove c () + let delete c = delete c () +end + +module Make_single_optional_data_storage (P : Single_data_description) = struct + module Raw = Make_single_data_storage (P) + type value = P.value + let get = Raw.get_option + let mem = Raw.mem + let set c r = + match r with + | None -> Raw.remove c >>= fun c -> return c + | Some r -> Raw.init_set c r +end + +(*-- Data set (set of homogeneous data under a key prefix) -------------------*) + +module Make_data_set_storage (P : Single_data_description) = struct + + module Key = struct + include Hash.Make_SHA256(struct + let name = P.name + let title = ("A " ^ P.name ^ "key") + let prefix = None + end) + let prefix = P.key + let length = path_len + end + + module HashTbl = + Persist.MakePersistentMap(Context)(Key)(Persist.RawValue) + + type value = P.value + + let serial v = + let data = Data_encoding.Binary.to_bytes P.encoding v in + Key.hash_bytes [data], data + + let unserial b = + match Data_encoding.Binary.of_bytes P.encoding b with + | None -> + let msg = + "cannot deserialize " ^ P.name ^ " value" in + error (Storage_error msg) + | Some v -> Ok v + + let add (c, x) v = + let hash, data = serial v in + HashTbl.mem c hash >>= function + | true -> return (c, x) + | false -> HashTbl.set c hash data >>= fun c -> return (c, x) + + let del (c, x) v = + let hash, _ = serial v in + HashTbl.mem c hash >>= function + | false -> return (c, x) + | true -> HashTbl.del c hash >>= fun c -> return (c, x) + + let mem (c, _) v = + let hash, _ = serial v in + HashTbl.mem c hash >>= fun v -> + return v + + let elements (c, _) = + HashTbl.bindings c >>= fun elts -> + map_s (fun (_, data) -> Lwt.return (unserial data)) elts + + let fold (c, _) init ~f = + HashTbl.fold c (ok init) + ~f:(fun _ data acc -> + match acc with + | Error _ -> Lwt.return acc + | Ok acc -> + match unserial data with + | Error _ as err -> Lwt.return err + | Ok data -> + f data acc >>= fun acc -> + return acc) + + let clear (c, x) = + HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c -> + return (c, x) + +end + +module Raw_make_iterable_data_storage + (K: Persist.KEY) + (P: Data_description) = struct + + type key = K.t + type value = P.value + + module HashTbl = + Persist.MakePersistentMap(Context)(K)(struct + type t = P.value + let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b + let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v + end) + + let key_to_string k = String.concat "/" (K.to_path k) + + let get (c, _) k = + HashTbl.get c k >>= function + | None -> + let msg = + "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | Some v -> + return v + + let mem (c, _) k = HashTbl.mem c k + + let get_option (c, _) k = + HashTbl.get c k >>= function + | None -> return None + | Some v -> return (Some v) + + (* Verify that the key is present before modifying *) + let set (c, x) k v = + HashTbl.get c k >>= function + | None -> + let msg = + "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | Some _ -> + HashTbl.set c k v >>= fun c -> + return (c, x) + + (* Verify that the key is not present before inserting *) + let init (c, x) k v = + HashTbl.get c k >>= + function + | Some _ -> + let msg + = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | None -> + HashTbl.set c k v >>= fun c -> + return (c, x) + + (* Does not verify that the key is present or not *) + let init_set (c, x) k v = HashTbl.set c k v >>= fun c -> return (c, x) + + (* Verify that the key is present before deleting *) + let delete (c, x) k = + HashTbl.get c k >>= function + | Some _ -> + HashTbl.del c k >>= fun c -> + return (c, x) + | None -> + let msg = + "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + + (* Do not verify before deleting *) + let remove (c, x) k = + HashTbl.del c k >>= fun c -> Lwt.return (c, x) + + let clear (c, x) = HashTbl.clear c >>= fun c -> Lwt.return (c, x) + let fold (c, _) x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc) + let iter (c, _) ~f = HashTbl.fold c () ~f:(fun k v () -> f k v) + +end + +module Make_iterable_data_storage (H: HASH) (P: Single_data_description) = + Raw_make_iterable_data_storage(struct + include H + let prefix = P.key + let length = path_len + end)(P) diff --git a/src/proto/bootstrap/storage_functors.mli b/src/proto/bootstrap/storage_functors.mli new file mode 100644 index 000000000..52341b87d --- /dev/null +++ b/src/proto/bootstrap/storage_functors.mli @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Typed storage accessor builders + + This module hides the hierarchical (key x value) database under + three kinds of typed data accessors (single typed data, homgeneous + indexed data and homgeneous data set). *) + + +type context = Context.t * Constants_repr.constants + +open Storage_sigs + +(** {1 Errors} ****************************************************************) + +(** An internal storage error that should not happen *) +type error += Storage_error of string + +(** {1 Data Accessor Parameters} *********************************************) + +(** Description of a single data typed accessor. *) +module type Data_description = sig + (** The OCaml type of value contents *) + type value + + (** A name (only used for error messages) *) + val name : string + + (** The serialization format *) + val encoding : value Data_encoding.t +end + +module type Single_data_description = sig + + (** The concrete key in the hierarchical database *) + val key : string list + + include Data_description + +end + +(** Describes how to map abstract OCaml types for some (key x value) + pair to the concrete path in the hierarchical database structure + and the serialization format. *) +module type Indexed_data_description = sig + + (** The OCaml type for keys *) + type key + + (** How to produce a concrete key from an abstract one *) + val key : key -> string list + + include Data_description + +end + +(** {1 Data Accessor Builders} ***********************************************) + +(** Single data typed accessor builder *) +module Make_single_data_storage (P : Single_data_description) : + Single_data_storage with type value = P.value + and type context := context + +module Make_single_optional_data_storage (P : Single_data_description) : + Single_optional_data_storage with type value = P.value + and type context := context + +(** Indexed data accessor builder *) +module Make_indexed_data_storage (P : Indexed_data_description) : + Indexed_data_storage with type key = P. key + and type value = P.value + and type context := context + +module Make_indexed_optional_data_storage (P : Indexed_data_description) : + Indexed_optional_data_storage with type key = P. key + and type value = P.value + and type context := context + +(** Data set builder (set of homogeneous data under a key prefix) *) +module Make_data_set_storage (P : Single_data_description) : + Data_set_storage with type value = P.value + and type context := context + +module Make_iterable_data_storage (H : HASH) (P: Single_data_description) : + Iterable_data_storage with type key = H.t + and type value = P.value + and type context := context + +module Raw_make_iterable_data_storage (K: Persist.KEY) (P: Data_description) : + Iterable_data_storage with type key = K.t + and type value = P.value + and type context := context + diff --git a/src/proto/bootstrap/storage_helpers.mli b/src/proto/bootstrap/storage_helpers.mli new file mode 100644 index 000000000..c836faf2f --- /dev/null +++ b/src/proto/bootstrap/storage_helpers.mli @@ -0,0 +1,229 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Typed storage accessor builders + + This module hides the hierarchical (key x value) database under + three kinds of typed data accessors (single typed data, homgeneous + indexed data and homgeneous data set). *) + +type context = Context.t * Constants.constants + + +(** {1 Errors} ****************************************************************) + +(** An internal storage error that should not happen *) +type error += Storage_error of string + +(** {1 Data Accessor Signatures} *********************************************) + +(** The generic signature of a single data accessor (a single value + bound to a specific key in the hierarchical (key x value) + database). *) +module type Minimal_single_data_storage = sig + + (** The type of the value *) + type value + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails *) + val get : context -> value tzresult Lwt.t + + (** Tells if the data is already defined *) + val mem : context -> bool Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error} + if the value does not exists *) + val set : context -> value -> context tzresult Lwt.t + +end + +module type Single_data_storage = sig + + include Minimal_single_data_storage + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails *) + val get_option : context -> value option tzresult Lwt.t + + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error} if the bucket exists *) + val init : context -> value -> context tzresult Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error} if the + bucket does not exists *) + val delete : context -> context tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists *) + val init_set : context -> value -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if the + bucket does not exists *) + val remove : context -> context Lwt.t + +end + +module type Minimal_indexed_data_storage = sig + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Retrieve a value from the storage bucket at a given key ; + returns a {!Storage_error} if the key is not set or if the + deserialisation fails *) + val get : context -> key -> value tzresult Lwt.t + + (** Tells if a given key is already bound to a storage bucket *) + val mem : context -> key -> bool Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error} if + the value does not exists *) + val set : context -> key -> value -> context tzresult Lwt.t + +end + +(** The generic signature of indexed data accessors (a set of values + of the same type indexed by keys of the same form in the + hierarchical (key x value) database). *) +module type Indexed_data_storage = sig + + include Minimal_indexed_data_storage + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set an error if the + deserialisation fails *) + val get_option : context -> key -> value option tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error} if the bucket exists *) + val init : context -> key -> value -> context tzresult Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error} if the bucket does not exists *) + val delete : context -> key -> context tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists *) + val init_set : context -> key -> value -> context tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists *) + val remove : context -> key -> context Lwt.t + +end + +(** An extension of [Indexed_data_storage] that allows iterations + over the element of the database *) +module type Iterable_data_storage = sig + + include Indexed_data_storage + + (** Iter over all elements in the storage *) + val iter : context -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t + val fold : context -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Removes all elements in the storage *) + val clear : context -> context Lwt.t + +end + +(** The generic signature of a data set accessor (a set of values + bound to a specific key prefix in the hierarchical (key x value) + database). Values are equal if their serializations are. *) +module type Data_set_storage = sig + + (** The type of values *) + type value + + (** Tells if a value is a member of the set *) + val mem : context -> value -> bool tzresult Lwt.t + + (** Adds a value is a member of the set *) + val add : context -> value -> context tzresult Lwt.t + + (** Removes a value of the set ; does nothing if not a member *) + val del : context -> value -> context tzresult Lwt.t + + (** Returns the elements of the set, deserialized in a list in no + particular order ; returns a {!Storage_error} if a + deserialization error occurs *) + val elements : context -> value list tzresult Lwt.t + + (** Removes all elements in the set *) + val clear : context -> context tzresult Lwt.t +end + +(** {1 Data Accessor Parameters} *********************************************) + +(** Description of a single data typed accessor. *) +module type Single_data_description = sig + (** The OCaml type of value contents *) + type value + + (** The concrete key in the hierarchical database *) + val key : string list + + (** A name (only used for error messages) *) + val name : string + + (** The serialization format *) + val encoding : value Data_encoding.t +end + +(** Describes how to map abstract OCaml types for some (key x value) + pair to the concrete path in the hierarchical database structure + and the serialization format. *) +module type Indexed_data_description = sig + + (** The OCaml type for keys *) + type key + + (** The OCaml type of value contents *) + type value + + (** A name (only used for error messages) *) + val name : string + + (** How to produce a concrete key from an abstract one *) + val key : key -> string list + + (** The serialization format *) + val encoding : value Data_encoding.t +end + +(** {1 Data Accessor Builders} ***********************************************) + +(** Single data typed accessor builder *) +module Make_single_data_storage (P : Single_data_description) : + Single_data_storage with type value = P.value + +module Make_single_option_data_storage (P : Single_data_description) : + Minimal_single_data_storage with type value = P.value option + +(** Indexed data accessor builder *) +module Make_indexed_data_storage (P : Indexed_data_description) : + Indexed_data_storage with type key = P. key and type value = P.value + +module Make_indexed_option_data_storage (P : Indexed_data_description) : + Minimal_indexed_data_storage with type key = P. key + and type value = P.value option + +(** Data set builder (set of homogeneous data under a key prefix) *) +module Make_data_set_storage (P : Single_data_description) : + Data_set_storage with type value = P.value + +module Make_iterable_data_storage (H : HASH) (P: Single_data_description) : + Iterable_data_storage with type key = H.t and type value = P.value diff --git a/src/proto/bootstrap/storage_sigs.ml b/src/proto/bootstrap/storage_sigs.ml new file mode 100644 index 000000000..53ee16eaf --- /dev/null +++ b/src/proto/bootstrap/storage_sigs.ml @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** {1 Entity Accessor Signatures} ****************************************) + +module type Single_optional_data_storage = sig + type context + type value + val get : context -> value option tzresult Lwt.t + val mem : context -> bool Lwt.t + val set : context -> value option -> context tzresult Lwt.t +end + +(** The generic signature of a single data accessor (a single value + bound to a specific key in the hierarchical (key x value) + database). *) +module type Single_data_storage = sig + + type context + + (** The type of the value *) + type value + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails *) + val get : context -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails *) + val get_option : context -> value option tzresult Lwt.t + + (** Tells if the data is already defined *) + val mem : context -> bool Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error} + if the value does not exists *) + val set : context -> value -> context tzresult Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error} if the bucket exists *) + val init : context -> value -> context tzresult Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error} if the + bucket does not exists *) + val delete : context -> context tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists *) + val init_set : context -> value -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if the + bucket does not exists *) + val remove : context -> context Lwt.t + +end + +module type Indexed_optional_data_storage = sig + type context + type key + type value + val get : context -> key -> value option tzresult Lwt.t + val mem : context -> key -> bool Lwt.t + val set : context -> key -> value option -> context tzresult Lwt.t +end + +(** The generic signature of indexed data accessors (a set of values + of the same type indexed by keys of the same form in the + hierarchical (key x value) database). *) +module type Indexed_data_storage = sig + + type context + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Retrieve a value from the storage bucket at a given key ; + returns a {!Storage_error} if the key is not set or if the + deserialisation fails *) + val get : context -> key -> value tzresult Lwt.t + + (** Tells if a given key is already bound to a storage bucket *) + val mem : context -> key -> bool Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set an error if the + deserialisation fails *) + val get_option : context -> key -> value option tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error} if + the value does not exists *) + val set : context -> key -> value -> context tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error} if the bucket exists *) + val init : context -> key -> value -> context tzresult Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error} if the bucket does not exists *) + val delete : context -> key -> context tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists *) + val init_set : context -> key -> value -> context tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists *) + val remove : context -> key -> context Lwt.t + +end + +module type Iterable_data_storage = sig + include Indexed_data_storage + val iter : context -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t + val fold : context -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val clear : context -> context Lwt.t +end + +(** The generic signature of a data set accessor (a set of values + bound to a specific key prefix in the hierarchical (key x value) + database). *) +module type Data_set_storage = sig + + type context + + (** The type of values *) + type value + + (** Tells if a value is a member of the set *) + val mem : context -> value -> bool tzresult Lwt.t + + (** Adds a value is a member of the set *) + val add : context -> value -> context tzresult Lwt.t + + (** Removes a value of the set ; does nothing if not a member *) + val del : context -> value -> context tzresult Lwt.t + + (** Returns the elements of the set, deserialized in a list in no + particular order ; returns a {!Storage_helpers.Storage_error} if + a deserialization error occurs *) + val elements : context -> value list tzresult Lwt.t + + val fold : + context -> 'a -> f:(value -> 'a -> 'a Lwt.t) -> 'a tzresult Lwt.t + + (** Removes all elements in the set *) + val clear : context -> context tzresult Lwt.t +end diff --git a/src/proto/bootstrap/tez_repr.ml b/src/proto/bootstrap/tez_repr.ml new file mode 100644 index 000000000..38576fa10 --- /dev/null +++ b/src/proto/bootstrap/tez_repr.ml @@ -0,0 +1,14 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Qty_repr.Make (struct let id="tez" end) + +type t = qty +type tez = qty + diff --git a/src/proto/bootstrap/tez_repr.mli b/src/proto/bootstrap/tez_repr.mli new file mode 100644 index 000000000..328993d84 --- /dev/null +++ b/src/proto/bootstrap/tez_repr.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type tez = t + +include (Qty_repr.S with type qty := t) diff --git a/src/proto/bootstrap/tezos_context.ml b/src/proto/bootstrap/tezos_context.ml new file mode 100644 index 000000000..d387a0819 --- /dev/null +++ b/src/proto/bootstrap/tezos_context.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = Storage.t +type context = t + +module type BASIC_DATA = sig + type t + include Compare.S with type t := t + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit +end + +module Tez = Tez_repr +module Period = Period_repr +module Timestamp = struct + include Time_repr + let get_current = Storage.Current_timestamp.get + let set_current = Storage.Current_timestamp.set +end + + +include Operation_repr +module Operation = Operation_repr +module Block = Block_repr +module Vote = struct + include Vote_repr + include Vote_storage +end +module Raw_level = Raw_level_repr +module Cycle = Cycle_repr +module Script_int = Script_int_repr +module Script = Script_repr + +type public_key = Ed25519.public_key +type public_key_hash = Ed25519.public_key_hash +type secret_key = Ed25519.secret_key +type signature = Ed25519.signature + +include Tezos_hash + +module Constants = struct + include Constants_repr + let cycle_length c = + let constants = Storage.constants c in + constants.cycle_length + let voting_period_length c = + let constants = Storage.constants c in + constants.voting_period_length + let time_before_reward c = + let constants = Storage.constants c in + constants.time_before_reward + let time_between_slots c = + let constants = Storage.constants c in + constants.time_between_slots + let first_free_mining_slot c = + let constants = Storage.constants c in + constants.first_free_mining_slot + let max_signing_slot c = + let constants = Storage.constants c in + constants.max_signing_slot + let instructions_per_transaction c = + let constants = Storage.constants c in + constants.instructions_per_transaction + let proof_of_work_threshold c = + let constants = Storage.constants c in + constants.proof_of_work_threshold +end + +module Public_key = struct + + let get = Storage.Public_key.get + let get_option = Storage.Public_key.get_option + let set = Storage.Public_key.init_set + let remove = Storage.Public_key.remove + + let list ctxt = + Storage.Public_key.fold ctxt [] ~f:(fun pk_h pk acc -> + Lwt.return @@ (pk_h, pk) :: acc) >>= fun res -> + return res + +end + +module Voting_period = Voting_period_repr + +module Level = struct + include Level_repr + include Level_storage +end +module Contract = struct + include Contract_repr + include Contract_storage +end +module Roll = struct + include Roll_repr + include Roll_storage +end +module Nonce = Nonce_storage +module Seed = struct + include Seed_repr + include Seed_storage +end +module Bootstrap = Bootstrap_storage +module Reward = Reward_storage + +module Fitness = struct + + include Fitness_repr + include Fitness + type t = fitness + include Fitness_storage + +end + +module Asset = Asset_repr + +let init = Init_storage.may_initialize +let finalize c = return (Storage.recover c) +let configure_sandbox = Init_storage.configure_sandbox +let get_prevalidation = Storage.get_prevalidation +let set_prevalidation = Storage.set_prevalidation + +let activate = Storage.activate +let fork_test_network = Storage.fork_test_network +let set_test_protocol = Storage.set_test_protocol diff --git a/src/proto/bootstrap/tezos_context.mli b/src/proto/bootstrap/tezos_context.mli new file mode 100644 index 000000000..ad0eb8fe9 --- /dev/null +++ b/src/proto/bootstrap/tezos_context.mli @@ -0,0 +1,594 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type BASIC_DATA = sig + type t + include Compare.S with type t := t + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit +end + +type t +type context = t + +module Contract_hash = Tezos_hash.Contract_hash +module Contract_hash_set = Tezos_hash.Contract_hash_set +module Contract_hash_map = Tezos_hash.Contract_hash_map + +module Nonce_hash = Tezos_hash.Nonce_hash +module Nonce_hash_set = Tezos_hash.Nonce_hash_set +module Nonce_hash_map = Tezos_hash.Nonce_hash_map + +type public_key = Ed25519.public_key +type public_key_hash = Ed25519.public_key_hash +type secret_key = Ed25519.secret_key +type signature = Ed25519.signature + +module Tez : sig + + include BASIC_DATA + type tez = t + + val zero: tez + val ( - ) : tez -> tez -> tez option + val ( -? ) : tez -> tez -> tez tzresult + val ( +? ) : tez -> tez -> tez tzresult + val ( *? ) : tez -> int64 -> tez tzresult + val ( / ) : tez -> int64 -> tez + + val of_string: string -> tez option + val to_string: tez -> string + + val of_cents: int64 -> tez option + val to_cents: tez -> int64 + +end + +module Period : sig + + include BASIC_DATA + type period = t + + val of_seconds: int64 -> period tzresult + val mult: int32 -> period -> period tzresult + +end + +module Timestamp : sig + + include BASIC_DATA with type t = Time.t + type time = t + val (+?) : time -> Period.t -> time tzresult + + val of_notation: string -> time option + val to_notation: time -> string + + val of_seconds: string -> time option + val to_seconds: time -> string + + val set_current: context -> Time.t -> context tzresult Lwt.t + val get_current: context -> Time.t tzresult Lwt.t + +end + +module Raw_level : sig + + include BASIC_DATA + type raw_level = t + val arg: raw_level RPC.Arg.arg + + val root: raw_level + val succ: raw_level -> raw_level + val pred: raw_level -> raw_level option + +end + +module Cycle : sig + + include BASIC_DATA + type cycle = t + val arg: cycle RPC.Arg.arg + + val root: cycle + val succ: cycle -> cycle + val pred: cycle -> cycle option + +end + +module Script_int : module type of Script_int_repr + +module Script : sig + + type location = int + + type expr = + | Int of location * string + | Float of location * string + | String of location * string + | Prim of location * string * expr list + | Seq of location * expr list + + type code = { + code: expr ; + arg_type: expr ; + ret_type: expr ; + storage_type: expr ; + } + + type storage = { + storage: expr ; + storage_type: expr ; + } + + type t = + | No_script + | Script of { + code: code ; + storage: storage ; + } + + val location_encoding: location Data_encoding.t + val expr_encoding: expr Data_encoding.t + val storage_encoding: storage Data_encoding.t + val code_encoding: code Data_encoding.t + val encoding: t Data_encoding.t + + val storage_cost: storage -> Tez.t + val code_cost: code -> Tez.t + + val hash_expr: expr -> string + +end + +module Asset : sig + type t + type asset = t + val encoding: asset Data_encoding.t + module Map : sig + type t + val encoding: t Data_encoding.t + end +end + +module Bootstrap : sig + type account = { + public_key_hash: public_key_hash ; + public_key: public_key ; + secret_key: secret_key ; + } + val accounts: account list + val account_encoding: account Data_encoding.t +end + +module Constants : sig + + val proof_of_work_nonce_size: int + val mining_reward: Tez.t + val endorsement_reward: Tez.t + val max_number_of_operations: int + val nonce_length: int + val seed_nonce_revelation_tip: Tez.t + val origination_burn: Tez.t + val mining_bond_cost: Tez.t + val endorsement_bond_cost: Tez.t + + val cycle_length: context -> int32 + val voting_period_length: context -> int32 + val time_before_reward: context -> Period.t + val time_between_slots: context -> Period.t + val first_free_mining_slot: context -> int32 + val max_signing_slot: context -> int + val instructions_per_transaction: context -> int + val proof_of_work_threshold: context -> int + +end + +module Public_key : sig + + val get: + context -> public_key_hash -> public_key tzresult Lwt.t + val get_option: + context -> public_key_hash -> public_key option tzresult Lwt.t + val set: + context -> public_key_hash -> public_key -> context tzresult Lwt.t + val remove: + context -> public_key_hash -> context Lwt.t + + val list: + context -> (public_key_hash * public_key) list tzresult Lwt.t + +end + +module Voting_period : sig + + include BASIC_DATA + type voting_period = t + val arg: voting_period RPC.Arg.arg + + val root: voting_period + val succ: voting_period -> voting_period + + type kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + val kind_encoding: kind Data_encoding.encoding + +end + +module Level : sig + + type t = private { + level: Raw_level.t ; + cycle: Cycle.t ; + cycle_position: int32 ; + voting_period: Voting_period.t ; + voting_period_position: int32 ; + } + include BASIC_DATA with type t := t + type level = t + + val root: level + + val succ: context -> level -> level + val pred: context -> level -> level option + + val from_raw: context -> ?offset:int32 -> Raw_level.t -> level + + val diff: level -> level -> int32 + + val current: context -> level tzresult Lwt.t + val increment_current: context -> context tzresult Lwt.t + + val last_level_in_cycle: context -> Cycle.t -> level + val levels_in_cycle: context -> Cycle.t -> level list + +end + +module Fitness : sig + + include (module type of Fitness) + type t = fitness + + val get: context -> fitness tzresult Lwt.t + val increase: context -> context tzresult Lwt.t + + val raw_get: context -> int64 tzresult Lwt.t + val raw_read: fitness -> int64 tzresult Lwt.t + +end + +module Nonce : sig + + type t + type nonce = t + val encoding: nonce Data_encoding.t + + val record_hash: + context -> public_key_hash -> Tez.t -> Nonce_hash.t -> + context tzresult Lwt.t + + val reveal: + context -> Level.t -> nonce -> + (context * public_key_hash * Tez.t) tzresult Lwt.t + + type status = + | Unrevealed of { + nonce_hash: Nonce_hash.t ; + delegate_to_reward: public_key_hash ; + reward_amount: Tez.t ; + } + | Revealed of nonce + + val get: context -> Level.t -> status tzresult Lwt.t + + val of_bytes: MBytes.t -> nonce tzresult + val hash: nonce -> Nonce_hash.t + val check_hash: nonce -> Nonce_hash.t -> bool + +end + +module Seed : sig + + val compute_for_cycle: context -> Cycle.t -> context tzresult Lwt.t + val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t + +end + +module Contract : sig + + include BASIC_DATA + type contract = t + val arg: contract RPC.Arg.arg + + val to_b48check: contract -> string + val of_b48check: string -> contract tzresult + + val default_contract: public_key_hash -> contract + val is_default: contract -> public_key_hash option + + val exists: context -> contract -> bool tzresult Lwt.t + val list: context -> contract list tzresult Lwt.t + + type descr = { + manager: public_key_hash ; + delegate: public_key_hash option ; + spendable: bool ; + delegatable: bool ; + script: Script.t ; + } + val descr_encoding: descr Data_encoding.t + + val get_descr: + context -> contract -> descr tzresult Lwt.t + val get_manager: + context -> contract -> public_key_hash tzresult Lwt.t + val get_delegate: + context -> contract -> public_key_hash tzresult Lwt.t + val get_delegate_opt: + context -> contract -> public_key_hash option tzresult Lwt.t + val is_delegatable: + context -> contract -> bool tzresult Lwt.t + val is_spendable: + context -> contract -> bool tzresult Lwt.t + val get_script: + context -> contract -> Script.t tzresult Lwt.t + + val get_counter: context -> contract -> int32 tzresult Lwt.t + val get_balance: + context -> contract -> Tez.t tzresult Lwt.t + val get_assets: + context -> contract -> Asset.Map.t tzresult Lwt.t + + val set_delegate: + context -> contract -> public_key_hash option -> context tzresult Lwt.t + + type error += + | Initial_amount_too_low + + val originate: + context -> + balance: Tez.t -> + manager: public_key_hash -> + script: Script.t -> + delegate: public_key_hash option -> + spendable: bool -> + delegatable: bool -> (context * contract) tzresult Lwt.t + + type error += Too_low_balance + + val spend: + context -> contract -> Tez.t -> context tzresult Lwt.t + val unconditional_spend: + context -> contract -> Tez.t -> context tzresult Lwt.t + + val credit: + context -> contract -> Tez.t -> context tzresult Lwt.t + val issue: + context -> contract -> + Asset.t -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val update_script_storage: + context -> contract -> Script.expr -> context tzresult Lwt.t + + val increment_counter: + context -> contract -> context tzresult Lwt.t + + val check_counter_increment: + context -> contract -> int32 -> unit tzresult Lwt.t + +end + +module Vote : sig + + type proposal = Protocol_hash.t + + val record_proposal: + context -> Protocol_hash.t -> public_key_hash -> + context tzresult Lwt.t + val get_proposals: + context -> int32 Protocol_hash_map.t tzresult Lwt.t + val clear_proposals: context -> context tzresult Lwt.t + + val froze_listings: context -> context tzresult Lwt.t + val clear_listings: context -> context tzresult Lwt.t + val listing_size: context -> int32 tzresult Lwt.t + val in_listings: context -> public_key_hash -> bool Lwt.t + + type ballot = Yay | Nay | Pass + + type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; + } + + val record_ballot: + context -> public_key_hash -> ballot -> context tzresult Lwt.t + val get_ballots: context -> ballots tzresult Lwt.t + val clear_ballots: context -> context Lwt.t + + val get_current_period_kind: + context -> Voting_period.kind tzresult Lwt.t + val set_current_period_kind: + context -> Voting_period.kind -> context tzresult Lwt.t + + val get_current_quorum: context -> int32 tzresult Lwt.t + val set_current_quorum: context -> int32 -> context tzresult Lwt.t + + val get_current_proposal: + context -> proposal tzresult Lwt.t + val set_current_proposal: + context -> proposal -> context tzresult Lwt.t + val clear_current_proposal: + context -> context tzresult Lwt.t + +end + +type operation = { + hash: Operation_hash.t ; + shell: Updater.shell_operation ; + contents: proto_operation ; + signature: signature option ; +} + +and proto_operation = + | Anonymous_operations of anonymous_operation list + | Sourced_operations of sourced_operations + +and anonymous_operation = + | Seed_nonce_revelation of { + level: Raw_level.t ; + nonce: Nonce.t ; + } + +and sourced_operations = + | Manager_operations of { + source: Contract.t ; + public_key: public_key option ; + fee: Tez.t ; + counter: counter ; + operations: manager_operation list ; + } + | Delegate_operations of { + source: public_key ; + operations: delegate_operation list ; + } + +and manager_operation = + | Transaction of { + amount: Tez.t ; + parameters: Script.expr option ; + destination: Contract.contract ; + } + | Origination of { + manager: public_key_hash ; + delegate: public_key_hash option ; + script: Script.t ; + spendable: bool ; + delegatable: bool ; + credit: Tez.t ; + } + | Issuance of { + asset: Asset.t * public_key_hash ; + amount: Tez.t ; + } + | Delegation of public_key_hash option + +and delegate_operation = + | Endorsement of { + block: Block_hash.t ; + slot: int ; + } + | Proposals of { + period: Voting_period.t ; + proposals: Protocol_hash.t list ; + } + | Ballot of { + period: Voting_period.t ; + proposal: Protocol_hash.t ; + ballot: Vote.ballot ; + } + +and counter = Int32.t + +module Operation : sig + + type error += Cannot_parse_operation + val parse: + Operation_hash.t -> Updater.raw_operation -> operation tzresult + + val parse_proto: + MBytes.t -> (proto_operation * signature option) tzresult Lwt.t + + type error += Invalid_signature + val check_signature: public_key -> operation -> unit tzresult Lwt.t + + val forge: Updater.shell_operation -> proto_operation -> MBytes.t + + val proto_operation_encoding: proto_operation Data_encoding.t + + val unsigned_operation_encoding: + (Updater.shell_operation * proto_operation) Data_encoding.t + + val max_operation_data_length: int + +end + +module Block : sig + + type header = { + shell: Updater.shell_block_header ; + proto: proto_header ; + signature: Ed25519.signature ; + } + + and proto_header = { + mining_slot: mining_slot ; + seed_nonce_hash: Nonce_hash.t ; + proof_of_work_nonce: MBytes.t ; + } + + and mining_slot = Raw_level.t * Int32.t + + val mining_slot_encoding: mining_slot Data_encoding.encoding + + val max_header_length: int + + val parse_header: Updater.raw_block_header -> header tzresult + + val unsigned_header_encoding: + (Updater.shell_block_header * proto_header) Data_encoding.encoding + + val forge_header: + Updater.shell_block_header -> proto_header -> MBytes.t + +end + +module Roll : sig + + val froze_rolls_for_cycle: context -> Cycle.t -> context tzresult Lwt.t + val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t + + val mining_rights_owner: + context -> Level.t -> priority:int32 -> public_key_hash tzresult Lwt.t + + val endorsement_rights_owner: + context -> Level.t -> slot:int -> public_key_hash tzresult Lwt.t + +end + +module Reward : sig + + val record: + context -> public_key_hash -> Cycle.t -> Tez.t -> context tzresult Lwt.t + + val discard: + context -> public_key_hash -> Cycle.t -> Tez.t -> context tzresult Lwt.t + + val set_reward_time_for_cycle: + context -> Cycle.t -> Time.t -> context tzresult Lwt.t + + val pay_due_rewards: context -> context tzresult Lwt.t + +end + +val init: Context.t -> context tzresult Lwt.t +val finalize: context -> Context.t tzresult Lwt.t + +val configure_sandbox: + Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t + +val get_prevalidation: context -> bool Lwt.t +val set_prevalidation: context -> context Lwt.t + +val activate: context -> Protocol_hash.t -> context Lwt.t +val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t +val fork_test_network: context -> context Lwt.t diff --git a/src/proto/bootstrap/tezos_hash.ml b/src/proto/bootstrap/tezos_hash.ml new file mode 100644 index 000000000..1f53b4496 --- /dev/null +++ b/src/proto/bootstrap/tezos_hash.ml @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Prefix = struct + let random_state_hash = Base48.Prefix.protocol_prefix ^ "\001" + let nonce_hash = Base48.Prefix.protocol_prefix ^ "\002" + let script_expr_hash = Base48.Prefix.protocol_prefix ^ "\003" + let proposition_hash = Base48.Prefix.protocol_prefix ^ "\004" + let contract_hash = Base48.Prefix.protocol_prefix ^ "\005" +end + +module State_hash = Hash.Make_SHA256(struct + let name = "random" + let title = "A random generation state" + let prefix = Some Prefix.random_state_hash + end) +module State_hash_set = Hash_set(State_hash) +module State_hash_map = Hash_map(State_hash) + +module Nonce_hash = Hash.Make_SHA256(struct + let name = "cycle_nonce" + let title = "A nonce hash" + let prefix = Some Prefix.nonce_hash + end) +module Nonce_hash_set = Hash_set(Nonce_hash) +module Nonce_hash_map = Hash_map(Nonce_hash) + +module Script_expr_hash = Hash.Make_SHA256(struct + let name = "script_expr" + let title = "A script expression ID" + let prefix = Some Prefix.script_expr_hash + end) +module Script_expr_hash_set = Hash_set(Script_expr_hash) +module Script_expr_hash_map = Hash_map(Script_expr_hash) + +module Contract_hash = Hash.Make_SHA256(struct + let name = "Contract_hash" + let title = "A contract ID" + let prefix = Some Prefix.contract_hash + end) +module Contract_hash_set = Hash_set(Contract_hash) +module Contract_hash_map = Hash_map(Contract_hash) + diff --git a/src/proto/bootstrap/time_repr.ml b/src/proto/bootstrap/time_repr.ml new file mode 100644 index 000000000..12be7e96c --- /dev/null +++ b/src/proto/bootstrap/time_repr.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Time +type time = t + +type error += Timestamp_add of exn + +let of_seconds s = + try Some (of_seconds (Int64.of_string s)) + with _ -> None +let to_seconds s = Int64.to_string (to_seconds s) + +let pp = pp_hum + +let (+?) x y = + (* TODO check overflow *) + try ok (add x (Period_repr.to_seconds y)) + with exn -> Error [Timestamp_add exn] + diff --git a/src/proto/bootstrap/time_repr.mli b/src/proto/bootstrap/time_repr.mli new file mode 100644 index 000000000..03fb842d3 --- /dev/null +++ b/src/proto/bootstrap/time_repr.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include module type of (struct include Time end) +type time = t + +val pp: Format.formatter -> t -> unit +val of_seconds: string -> time option +val to_seconds: time -> string + +val (+?) : time -> Period_repr.t -> time tzresult + diff --git a/src/proto/bootstrap/vote_repr.ml b/src/proto/bootstrap/vote_repr.ml new file mode 100644 index 000000000..ae2d98fdf --- /dev/null +++ b/src/proto/bootstrap/vote_repr.ml @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* a protocol change proposal *) +type proposal = Protocol_hash.t + +(* votes can be for, against or neutral. +Neutral serves to count towards a quorum *) +type ballot = Yay | Nay | Pass + +let ballot_encoding = + let of_int8 = function + | 0 -> Yay + | 1 -> Nay + | 2 -> Pass + | _ -> invalid_arg "ballot_of_int8" + in + let to_int8 = function + | Yay -> 0 + | Nay -> 1 + | Pass -> 2 + in + let open Data_encoding in + (* union *) + splitted + ~binary: (conv to_int8 of_int8 int8) + ~json: (string_enum [ + "yay", Yay ; + "nay", Nay ; + "pass", Pass ; + ]) diff --git a/src/proto/bootstrap/vote_repr.mli b/src/proto/bootstrap/vote_repr.mli new file mode 100644 index 000000000..8b74986cd --- /dev/null +++ b/src/proto/bootstrap/vote_repr.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type proposal = Protocol_hash.t + +type ballot = Yay | Nay | Pass +val ballot_encoding: ballot Data_encoding.t diff --git a/src/proto/bootstrap/vote_storage.ml b/src/proto/bootstrap/vote_storage.ml new file mode 100644 index 000000000..51f886af1 --- /dev/null +++ b/src/proto/bootstrap/vote_storage.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let record_proposal ctxt delegate proposal = + Storage.Vote.Proposals.add ctxt (delegate, proposal) + +let get_proposals ctxt = + Storage.Vote.Proposals.fold ctxt Protocol_hash_map.empty + ~f:(fun (proposal, _delegate) acc -> + let previous = + try Protocol_hash_map.find proposal acc + with Not_found -> 0l in + Lwt.return (Protocol_hash_map.add proposal (Int32.succ previous) acc)) + +let clear_proposals ctxt = + Storage.Vote.Proposals.clear ctxt + +type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; +} + +let record_ballot = Storage.Vote.Ballots.init_set + +let get_ballots ctxt = + Storage.Vote.Ballots.fold ctxt + ~f:(fun delegate ballot (ballots: ballots tzresult) -> + Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> + let count = Int32.add weight in + Lwt.return begin + ballots >>? fun ballots -> + match ballot with + | Yay -> ok { ballots with yay = count ballots.yay } + | Nay -> ok { ballots with nay = count ballots.nay } + | Pass -> ok { ballots with pass = count ballots.pass } + end) + (ok { yay = 0l ; nay = 0l; pass = 0l }) + +let clear_ballots = Storage.Vote.Ballots.clear + +let froze_listings ctxt = + Roll_storage.fold ctxt (ctxt, 0l) + ~f:(fun _roll contract (ctxt, total as acc) -> + Contract_storage.get_delegate_opt ctxt contract >>=? function + | None -> return acc + | Some delegate -> + begin + Storage.Vote.Listings.get_option ctxt delegate >>=? function + | None -> return 0l + | Some count -> return count + end >>=? fun count -> + Storage.Vote.Listings.init_set + ctxt delegate (Int32.succ count) >>=? fun ctxt -> + return (ctxt, Int32.succ total)) >>=? fun (ctxt, total) -> + Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> + return ctxt + +let listing_size = Storage.Vote.Listings_size.get +let in_listings = Storage.Vote.Listings.mem + +let clear_listings ctxt = + Storage.Vote.Listings.clear ctxt >>= fun ctxt -> + Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> + return ctxt + +let get_current_period_kind = Storage.Vote.Current_period_kind.get +let set_current_period_kind = Storage.Vote.Current_period_kind.set + +let get_current_quorum = Storage.Vote.Current_quorum.get +let set_current_quorum = Storage.Vote.Current_quorum.set + +let get_current_proposal = Storage.Vote.Current_proposal.get +let set_current_proposal = Storage.Vote.Current_proposal.set +let clear_current_proposal = Storage.Vote.Current_proposal.delete + +let init ctxt = + Storage.Vote.Current_quorum.init ctxt 80_00l >>=? fun ctxt -> + Storage.Vote.Current_period_kind.init ctxt Proposal >>=? fun ctxt -> + return ctxt diff --git a/src/proto/bootstrap/vote_storage.mli b/src/proto/bootstrap/vote_storage.mli new file mode 100644 index 000000000..28159dacc --- /dev/null +++ b/src/proto/bootstrap/vote_storage.mli @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val record_proposal: + Storage.t -> Protocol_hash.t -> Ed25519.public_key_hash -> + Storage.t tzresult Lwt.t + +val get_proposals: + Storage.t -> int32 Protocol_hash_map.t tzresult Lwt.t + +val clear_proposals: Storage.t -> Storage.t tzresult Lwt.t + +type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; +} + +val record_ballot: + Storage.t -> Ed25519.public_key_hash -> Vote_repr.ballot -> + Storage.t tzresult Lwt.t +val get_ballots: Storage.t -> ballots tzresult Lwt.t +val clear_ballots: Storage.t -> Storage.t Lwt.t + +val froze_listings: Storage.t -> Storage.t tzresult Lwt.t +val clear_listings: Storage.t -> Storage.t tzresult Lwt.t + +val listing_size: Storage.t -> int32 tzresult Lwt.t +val in_listings: + Storage.t -> Ed25519.public_key_hash -> bool Lwt.t + +val get_current_quorum: Storage.t -> int32 tzresult Lwt.t +val set_current_quorum: Storage.t -> int32 -> Storage.t tzresult Lwt.t + +val get_current_period_kind: + Storage.t -> Voting_period_repr.kind tzresult Lwt.t +val set_current_period_kind: + Storage.t -> Voting_period_repr.kind -> Storage.t tzresult Lwt.t + +val get_current_proposal: + Storage.t -> Protocol_hash.t tzresult Lwt.t +val set_current_proposal: + Storage.t -> Protocol_hash.t -> Storage.t tzresult Lwt.t +val clear_current_proposal: Storage.t -> Storage.t tzresult Lwt.t + +val init: Storage.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/bootstrap/voting_period_repr.ml b/src/proto/bootstrap/voting_period_repr.ml new file mode 100644 index 000000000..1db63ad18 --- /dev/null +++ b/src/proto/bootstrap/voting_period_repr.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = int32 +type voting_period = t +include (Compare.Int32 : Compare.S with type t := t) +let encoding = Data_encoding.int32 +let pp ppf level = Format.fprintf ppf "%ld" level +let arg = + let construct voting_period = Int32.to_string voting_period in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse voting period" + | voting_period -> Ok voting_period in + RPC.Arg.make + ~descr:"A voting period" + ~name: "voting_period" + ~construct + ~destruct + +let root = 0l +let succ = Int32.succ + +let to_int32 l = l +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Voting_period_repr.of_int32" + +type kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + +let kind_encoding = + let open Data_encoding in + union ~tag_size:`Int8 [ + case ~tag:0 + (constant "proposal") + (function Proposal -> Some () | _ -> None) + (fun () -> Proposal) ; + case ~tag:1 + (constant "testing_vote") + (function Testing_vote -> Some () | _ -> None) + (fun () -> Testing_vote) ; + case ~tag:2 + (constant "testing") + (function Testing -> Some () | _ -> None) + (fun () -> Testing) ; + case ~tag:3 + (constant "promotion_vote") + (function Promotion_vote -> Some () | _ -> None) + (fun () -> Promotion_vote) ; + ] diff --git a/src/proto/bootstrap/voting_period_repr.mli b/src/proto/bootstrap/voting_period_repr.mli new file mode 100644 index 000000000..248e978ac --- /dev/null +++ b/src/proto/bootstrap/voting_period_repr.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +type voting_period = t +val encoding: voting_period Data_encoding.t +val arg: voting_period RPC.Arg.arg +val pp: Format.formatter -> voting_period -> unit +include Compare.S with type t := voting_period + +val to_int32: voting_period -> int32 +val of_int32_exn: int32 -> voting_period + +val root: voting_period +val succ: voting_period -> voting_period + +type kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + +val kind_encoding: kind Data_encoding.t diff --git a/src/proto/demo/.merlin b/src/proto/demo/.merlin new file mode 100644 index 000000000..28fcf44c1 --- /dev/null +++ b/src/proto/demo/.merlin @@ -0,0 +1,8 @@ +B ../../node/updater/ +B _tzbuild +FLG -nopervasives +FLG -open Proto_environment +FLG -open Hash +FLG -open Local_error_monad +FLG -open Error_monad +FLG -w -40 diff --git a/src/proto/demo/TEZOS_PROTOCOL b/src/proto/demo/TEZOS_PROTOCOL new file mode 100644 index 000000000..49898d3d5 --- /dev/null +++ b/src/proto/demo/TEZOS_PROTOCOL @@ -0,0 +1,6 @@ +hash = "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" +modules = [ + Error ; + Services ; + Main ; +] diff --git a/src/proto/demo/error.ml b/src/proto/demo/error.ml new file mode 100644 index 000000000..ecea154fa --- /dev/null +++ b/src/proto/demo/error.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += Demo_error of int + +let () = + Error_monad.register_error_kind + `Temporary + ~id:"unique.error.id" + ~title:"Short error description" + ~description:"Exhaustive error description" + ~pp:(fun ppf i -> Format.fprintf ppf "Expected demo error: %d." i) + Data_encoding.(obj1 (req "data" int31)) + (function Demo_error x -> Some x | _ -> None) + (fun x -> Demo_error x) + +let demo_error x : unit tzresult Lwt.t = fail (Demo_error x) diff --git a/src/proto/demo/main.ml b/src/proto/demo/main.ml new file mode 100644 index 000000000..81e996ac8 --- /dev/null +++ b/src/proto/demo/main.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type operation = Operation_hash.t +let max_operation_data_length = 42 + +type block_header = unit + +let max_block_header_length = 42 +let max_number_of_operations = 42 + +let parse_block_header _ = Ok () +let parse_operation h _ = Ok h + +let fitness_key = ["v1";"store";"fitness"] + +let get_fitness ctxt = + Context.get ctxt fitness_key >>= function + | None -> Lwt.return 0L + | Some b -> + match Data_encoding.Binary.of_bytes Data_encoding.int64 b with + | None -> Lwt.return 0L + | Some v -> Lwt.return v + +let set_fitness ctxt v = + Context.set ctxt fitness_key @@ + Data_encoding.Binary.to_bytes Data_encoding.int64 v + +let int64_to_bytes i = + let b = MBytes.create 8 in + MBytes.set_int64 b 0 i; + b + +let fitness ctxt = + get_fitness ctxt >|= fun v -> + [ MBytes.of_string "\000" ; + int64_to_bytes v ] + +let increase_fitness ctxt = + get_fitness ctxt >>= fun v -> + set_fitness ctxt (Int64.succ v) >>= fun ctxt -> + Lwt.return ctxt + +let apply ctxt () _operations = + increase_fitness ctxt >>= fun ctxt -> + return ctxt + +let preapply context _block_pred _timestamp _sort operations = + Lwt.return + (Ok + (context, + { Updater.applied = List.map (fun h -> h) operations; + refused = Operation_hash_map.empty; + branch_delayed = Operation_hash_map.empty; + branch_refused = Operation_hash_map.empty; + })) + +let rpc_services = Services.rpc_services + +let configure_sandbox ctxt _ = Lwt.return (Ok ctxt) diff --git a/src/proto/demo/services.ml b/src/proto/demo/services.ml new file mode 100644 index 000000000..daa0bfdc3 --- /dev/null +++ b/src/proto/demo/services.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let error_encoding = + let open Data_encoding in + describe + ~description: + "The full list of error is available with \ + the global RPC `/errors`" + (conv + (fun exn -> `A (List.map json_of_error exn)) + (function `A exns -> List.map error_of_json exns | _ -> []) + json) + +let wrap_tzerror encoding = + let open Data_encoding in + union [ + case + (obj1 (req "ok" encoding)) + (function Ok x -> Some x | _ -> None) + (fun x -> Ok x) ; + case + (obj1 (req "error" error_encoding)) + (function Error x -> Some x | _ -> None) + (fun x -> Error x) ; + ] + +let echo_service custom_root = + RPC.service + ~description: "An dummy echo service" + ~input: Data_encoding.(obj1 (req "msg" string)) + ~output: Data_encoding.(obj1 (req "msg" string)) + RPC.Path.(custom_root / "echo") + +let failing_service custom_root = + RPC.service + ~description: "A failing service" + ~input: Data_encoding.(obj1 (req "arg" int31)) + ~output: (wrap_tzerror Data_encoding.empty) + RPC.Path.(custom_root / "failing") + +let rpc_services : Context.t RPC.directory = + let dir = RPC.empty in + let dir = + RPC.register + dir + (failing_service RPC.Path.root) + (fun _ctxt x -> Error.demo_error x >>= RPC.Answer.return) + in + let dir = + RPC.register + dir + (echo_service RPC.Path.root) + (fun _ctxt x -> RPC.Answer.return x) + in + dir diff --git a/src/proto/environment/RPC.mli b/src/proto/environment/RPC.mli new file mode 100644 index 000000000..e089d4295 --- /dev/null +++ b/src/proto/environment/RPC.mli @@ -0,0 +1,137 @@ +(** View over the RPC service, restricted to types. A protocol + implementation can define a set of remote procedures which are + registered when the protocol is activated via its [rpcs] + function. However, it cannot register new or update existing + procedures afterwards, neither can it see other procedures. *) + +(** Typed path argument. *) +module Arg : sig + + type 'a arg + val make: + ?descr:string -> + name:string -> + destruct:(string -> ('a, string) result) -> + construct:('a -> string) -> + 'a arg + + type descr = { + name: string ; + descr: string option ; + } + val descr: 'a arg -> descr + + val int: int arg + val int32: int32 arg + val int64: int64 arg + val float: float arg + +end + +(** Parametrized path to services. *) +module Path : sig + + type ('prefix, 'params) path + type 'prefix context = ('prefix, 'prefix) path + + val root: 'a context + + val add_suffix: + ('prefix, 'params) path -> string -> ('prefix, 'params) path + val (/): + ('prefix, 'params) path -> string -> ('prefix, 'params) path + + val add_arg: + ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path + val (/:): + ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path + + val prefix: + ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path + + val map: + ('a -> 'b) -> ('b -> 'a) -> ('prefix, 'a) path -> ('prefix, 'b) path + +end + +(** Services. *) +type ('prefix, 'params, 'input, 'output) service + +val service: + ?description: string -> + input: 'input Data_encoding.t -> + output: 'output Data_encoding.t -> + ('prefix, 'params) Path.path -> + ('prefix, 'params, 'input, 'output) service + +module Answer : sig + + (** Return type for service handler *) + type 'a answer = + { code : int ; + body : 'a output ; + } + + and 'a output = + | Empty + | Single of 'a + | Stream of 'a stream + + and 'a stream = { + next: unit -> 'a option Lwt.t ; + shutdown: unit -> unit ; + } + + val ok: 'a -> 'a answer + val return: 'a -> 'a answer Lwt.t + +end + +(** Dispatch tree *) +type 'prefix directory + +val empty: 'prefix directory + +(** Registring handler in service tree. *) +val register: + 'prefix directory -> + ('prefix, 'params, 'input, 'output) service -> + ('params -> 'input -> 'output Answer.answer Lwt.t) -> + 'prefix directory + +(** Registring handler in service tree. Curryfied variant. *) +val register0: + unit directory -> + (unit, unit, 'i, 'o) service -> + ('i -> 'o Answer.answer Lwt.t) -> + unit directory + +val register1: + 'prefix directory -> + ('prefix, unit * 'a, 'i, 'o) service -> + ('a -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register2: + 'prefix directory -> + ('prefix, (unit * 'a) * 'b, 'i, 'o) service -> + ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register3: + 'prefix directory -> + ('prefix, ((unit * 'a) * 'b) * 'c, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register4: + 'prefix directory -> + ('prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory + +val register5: + 'prefix directory -> + ('prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) -> + 'prefix directory diff --git a/src/proto/environment/array.mli b/src/proto/environment/array.mli new file mode 100644 index 000000000..872423df9 --- /dev/null +++ b/src/proto/environment/array.mli @@ -0,0 +1,259 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Array operations. *) + +external length : 'a array -> int = "%array_length" +(** Return the length (number of elements) of the given array. *) + +external get : 'a array -> int -> 'a = "%array_safe_get" +(** [Array.get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [Array.length a - 1]. + You can also write [a.(n)] instead of [Array.get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(Array.length a - 1)]. *) + +external set : 'a array -> int -> 'a -> unit = "%array_safe_set" +(** [Array.set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [Array.set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [Array.length a - 1]. *) + +external make : int -> 'a -> 'a array = "caml_make_vect" +(** [Array.make n x] returns a fresh array of length [n], + initialized with [x]. + All the elements of this new array are initially + physically equal to [x] (in the sense of the [==] predicate). + Consequently, if [x] is mutable, it is shared among all elements + of the array, and modifying [x] through one of the array entries + will modify all other entries at the same time. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the value of [x] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2].*) + +external create : int -> 'a -> 'a array = "caml_make_vect" + [@@ocaml.deprecated "Use Array.make instead."] +(** @deprecated [Array.create] is an alias for {!Array.make}. *) + +external create_float: int -> float array = "caml_make_float_vect" +(** [Array.create_float n] returns a fresh float array of length [n], + with uninitialized data. + @since 4.03 *) + +val make_float: int -> float array + [@@ocaml.deprecated "Use Array.create_float instead."] +(** @deprecated [Array.make_float] is an alias for {!Array.create_float}. *) + +val init : int -> (int -> 'a) -> 'a array +(** [Array.init n f] returns a fresh array of length [n], + with element number [i] initialized to the result of [f i]. + In other terms, [Array.init n f] tabulates the results of [f] + applied to the integers [0] to [n-1]. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the return type of [f] is [float], then the maximum + size is only [Sys.max_array_length / 2].*) + +val make_matrix : int -> int -> 'a -> 'a array array +(** [Array.make_matrix dimx dimy e] returns a two-dimensional array + (an array of arrays) with first dimension [dimx] and + second dimension [dimy]. All the elements of this new matrix + are initially physically equal to [e]. + The element ([x,y]) of a matrix [m] is accessed + with the notation [m.(x).(y)]. + + Raise [Invalid_argument] if [dimx] or [dimy] is negative or + greater than [Sys.max_array_length]. + If the value of [e] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2]. *) + +val create_matrix : int -> int -> 'a -> 'a array array + [@@ocaml.deprecated "Use Array.make_matrix instead."] +(** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) + +val append : 'a array -> 'a array -> 'a array +(** [Array.append v1 v2] returns a fresh array containing the + concatenation of the arrays [v1] and [v2]. *) + +val concat : 'a array list -> 'a array +(** Same as [Array.append], but concatenates a list of arrays. *) + +val sub : 'a array -> int -> int -> 'a array +(** [Array.sub a start len] returns a fresh array of length [len], + containing the elements number [start] to [start + len - 1] + of array [a]. + + Raise [Invalid_argument "Array.sub"] if [start] and [len] do not + designate a valid subarray of [a]; that is, if + [start < 0], or [len < 0], or [start + len > Array.length a]. *) + +val copy : 'a array -> 'a array +(** [Array.copy a] returns a copy of [a], that is, a fresh array + containing the same elements as [a]. *) + +val fill : 'a array -> int -> int -> 'a -> unit +(** [Array.fill a ofs len x] modifies the array [a] in place, + storing [x] in elements number [ofs] to [ofs + len - 1]. + + Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not + designate a valid subarray of [a]. *) + +val blit : 'a array -> int -> 'a array -> int -> int -> unit +(** [Array.blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) + +val to_list : 'a array -> 'a list +(** [Array.to_list a] returns the list of all the elements of [a]. *) + +val of_list : 'a list -> 'a array +(** [Array.of_list l] returns a fresh array containing the elements + of [l]. *) + + +(** {6 Iterators} *) + + +val iter : ('a -> unit) -> 'a array -> unit +(** [Array.iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) + +val iteri : (int -> 'a -> unit) -> 'a array -> unit +(** Same as {!Array.iter}, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) + +val map : ('a -> 'b) -> 'a array -> 'b array +(** [Array.map f a] applies function [f] to all the elements of [a], + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) + +val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array +(** Same as {!Array.map}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a +(** [Array.fold_left f x a] computes + [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) + +val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a +(** [Array.fold_right f a x] computes + [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], + where [n] is the length of the array [a]. *) + + +(** {6 Iterators on two arrays} *) + + +val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit +(** [Array.iter2 f a b] applies function [f] to all the elements of [a] + and [b]. + Raise [Invalid_argument] if the arrays are not the same size. *) + +val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array +(** [Array.map2 f a b] applies function [f] to all the elements of [a] + and [b], and builds an array with the results returned by [f]: + [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. + Raise [Invalid_argument] if the arrays are not the same size. *) + + +(** {6 Array scanning} *) + + +val for_all : ('a -> bool) -> 'a array -> bool +(** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) + +val exists : ('a -> bool) -> 'a array -> bool +(** [Array.exists p [|a1; ...; an|]] checks if at least one element of + the array satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) + +val mem : 'a -> 'a array -> bool +(** [mem a l] is true if and only if [a] is equal + to an element of [l]. *) + +val memq : 'a -> 'a array -> bool +(** Same as {!Array.mem}, but uses physical equality instead of structural + equality to compare array elements. *) + + +(** {6 Sorting} *) + + +val sort : ('a -> 'a -> int) -> 'a array -> unit +(** Sort an array in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see below for a + complete specification). For example, {!Pervasives.compare} is + a suitable comparison function, provided there are no floating-point + NaN values in the data. After calling [Array.sort], the + array is sorted in place in increasing order. + [Array.sort] is guaranteed to run in constant heap space + and (at most) logarithmic stack space. + + The current implementation uses Heap Sort. It runs in constant + stack space. + + Specification of the comparison function: + Let [a] be the array and [cmp] the comparison function. The following + must be true for all x, y, z in a : +- [cmp x y] > 0 if and only if [cmp y x] < 0 +- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 + + When [Array.sort] returns, [a] contains the same elements as before, + reordered in such a way that for all i and j valid indices of [a] : +- [cmp a.(i) a.(j)] >= 0 if and only if i >= j +*) + +val stable_sort : ('a -> 'a -> int) -> 'a array -> unit +(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. + elements that compare equal are kept in their original order) and + not guaranteed to run in constant heap space. + + The current implementation uses Merge Sort. It uses [n/2] + words of heap space, where [n] is the length of the array. + It is usually faster than the current implementation of {!Array.sort}. +*) + +val fast_sort : ('a -> 'a -> int) -> 'a array -> unit +(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster + on typical input. +*) + + +(**/**) +(** {6 Undocumented functions} *) + +(* The following is for system use only. Do not call directly. *) + +external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" +external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" diff --git a/src/proto/environment/base48.mli b/src/proto/environment/base48.mli new file mode 100644 index 000000000..81eaf1df1 --- /dev/null +++ b/src/proto/environment/base48.mli @@ -0,0 +1,15 @@ + +type data = .. + +val decode: ?alphabet:string -> string -> data +val encode: ?alphabet:string -> data -> string + +val register: + prefix:string -> + read:(data -> string option) -> + build:(string -> data) -> + unit + +module Prefix : sig + val protocol_prefix: string +end diff --git a/src/proto/environment/buffer.mli b/src/proto/environment/buffer.mli new file mode 100644 index 000000000..ed379f0ed --- /dev/null +++ b/src/proto/environment/buffer.mli @@ -0,0 +1,123 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* TEZOS CHANGES + + * import version 4.02.1 + * Removed channel functions + +*) + +(** Extensible buffers. + + This module implements buffers that automatically expand + as necessary. It provides accumulative concatenation of strings + in quasi-linear time (instead of quadratic time when strings are + concatenated pairwise). +*) + +type t +(** The abstract type of buffers. *) + +val create : int -> t +(** [create n] returns a fresh buffer, initially empty. + The [n] parameter is the initial size of the internal byte sequence + that holds the buffer contents. That byte sequence is automatically + reallocated when more than [n] characters are stored in the buffer, + but shrinks back to [n] characters when [reset] is called. + For best performance, [n] should be of the same order of magnitude + as the number of characters that are expected to be stored in + the buffer (for instance, 80 for a buffer that holds one output + line). Nothing bad will happen if the buffer grows beyond that + limit, however. In doubt, take [n = 16] for instance. + If [n] is not between 1 and {!Sys.max_string_length}, it will + be clipped to that interval. *) + +val contents : t -> string +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + +val to_bytes : t -> bytes +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + +val sub : t -> int -> int -> string +(** [Buffer.sub b off len] returns (a copy of) the bytes from the + current contents of the buffer [b] starting at offset [off] of + length [len] bytes. May raise [Invalid_argument] if out of bounds + request. The buffer itself is unaffected. *) + +val blit : t -> int -> bytes -> int -> int -> unit +(** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from + the current contents of the buffer [src], starting at offset [srcoff] + to [dst], starting at character [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid + range of [src], or if [dstoff] and [len] do not designate a valid + range of [dst]. + @since 3.11.2 +*) + +val nth : t -> int -> char +(** get the n-th character of the buffer. Raise [Invalid_argument] if + index out of bounds *) + +val length : t -> int +(** Return the number of characters currently contained in the buffer. *) + +val clear : t -> unit +(** Empty the buffer. *) + +val reset : t -> unit +(** Empty the buffer and deallocate the internal byte sequence holding the + buffer contents, replacing it with the initial internal byte sequence + of length [n] that was allocated by {!Buffer.create} [n]. + For long-lived buffers that may have grown a lot, [reset] allows + faster reclamation of the space used by the buffer. *) + +val add_char : t -> char -> unit +(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) + +val add_string : t -> string -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + +val add_bytes : t -> bytes -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + +val add_substring : t -> string -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in string [s] and appends them at the end of the buffer [b]. *) + +val add_subbytes : t -> bytes -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. *) + +val add_substitute : t -> (string -> string) -> string -> unit +(** [add_substitute b f s] appends the string pattern [s] at the end + of the buffer [b] with substitution. + The substitution process looks for variables into + the pattern and substitutes each variable name by its value, as + obtained by applying the mapping [f] to the variable name. Inside the + string pattern, a variable name immediately follows a non-escaped + [$] character and is one of the following: + - a non empty sequence of alphanumeric or [_] characters, + - an arbitrary sequence of characters enclosed by a pair of + matching parentheses or curly brackets. + An escaped [$] character is a [$] that immediately follows a backslash + character; it then stands for a plain [$]. + Raise [Not_found] if the closing character of a parenthesized variable + cannot be found. *) + +val add_buffer : t -> t -> unit +(** [add_buffer b1 b2] appends the current contents of buffer [b2] + at the end of buffer [b1]. [b2] is not modified. *) diff --git a/src/proto/environment/bytes.mli b/src/proto/environment/bytes.mli new file mode 100644 index 000000000..3b03382ce --- /dev/null +++ b/src/proto/environment/bytes.mli @@ -0,0 +1,433 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Byte sequence operations. + + A byte sequence is a mutable data structure that contains a + fixed-length sequence of bytes. Each byte can be indexed in + constant time for reading or writing. + + Given a byte sequence [s] of length [l], we can access each of the + [l] bytes of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + bytes or at the beginning or end of the sequence. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the byte at index [n] is between positions + [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + range of [s] if [len >= 0] and [start] and [start+len] are valid + positions in [s]. + + Byte sequences can be modified in place, for instance via the [set] + and [blit] functions described below. See also strings (module + {!String}), which are almost the same data structure, but cannot be + modified in place. + + Bytes are represented by the OCaml type [char]. + + @since 4.02.0 + *) + +external length : bytes -> int = "%string_length" +(** Return the length (number of bytes) of the argument. *) + +external get : bytes -> int -> char = "%string_safe_get" +(** [get s n] returns the byte at index [n] in argument [s]. + + Raise [Invalid_argument] if [n] not a valid index in [s]. *) + +external set : bytes -> int -> char -> unit = "%string_safe_set" +(** [set s n c] modifies [s] in place, replacing the byte at index [n] + with [c]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. *) + +external create : int -> bytes = "caml_create_string" +(** [create n] returns a new byte sequence of length [n]. The + sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val make : int -> char -> bytes +(** [make n c] returns a new byte sequence of length [n], filled with + the byte [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> bytes +(** [Bytes.init n f] returns a fresh byte sequence of length [n], with + character [i] initialized to the result of [f i] (in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val empty : bytes +(** A byte sequence of size 0. *) + +val copy : bytes -> bytes +(** Return a new byte sequence that contains the same bytes as the + argument. *) + +val of_string : string -> bytes +(** Return a new byte sequence that contains the same bytes as the + given string. *) + +val to_string : bytes -> string +(** Return a new string that contains the same bytes as the given byte + sequence. *) + +val sub : bytes -> int -> int -> bytes +(** [sub s start len] returns a new byte sequence of length [len], + containing the subsequence of [s] that starts at position [start] + and has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val sub_string : bytes -> int -> int -> string +(** Same as [sub] but return a string instead of a byte sequence. *) + +val extend : bytes -> int -> int -> bytes +(** [extend s left right] returns a new byte sequence that contains + the bytes of [s], with [left] uninitialized bytes prepended and + [right] uninitialized bytes appended to it. If [left] or [right] + is negative, then bytes are removed (instead of appended) from + the corresponding side of [s]. + + Raise [Invalid_argument] if the result length is negative or + longer than {!Sys.max_string_length} bytes. *) + +val fill : bytes -> int -> int -> char -> unit +(** [fill s start len c] modifies [s] in place, replacing [len] + characters with [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val blit : bytes -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence + [src], starting at index [srcoff], to sequence [dst], starting at + index [dstoff]. It works correctly even if [src] and [dst] are the + same byte sequence, and the source and destination intervals + overlap. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val blit_string : string -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from string + [src], starting at index [srcoff], to byte sequence [dst], + starting at index [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val concat : bytes -> bytes list -> bytes +(** [concat sep sl] concatenates the list of byte sequences [sl], + inserting the separator byte sequence [sep] between each, and + returns the result as a new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val cat : bytes -> bytes -> bytes +(** [cat s1 s2] concatenates [s1] and [s2] and returns the result + as new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val iter : (char -> unit) -> bytes -> unit +(** [iter f s] applies function [f] in turn to all the bytes of [s]. + It is equivalent to [f (get s 0); f (get s 1); ...; f (get s + (length s - 1)); ()]. *) + +val iteri : (int -> char -> unit) -> bytes -> unit +(** Same as {!Bytes.iter}, but the function is applied to the index of + the byte as first argument and the byte itself as second + argument. *) + +val map : (char -> char) -> bytes -> bytes +(** [map f s] applies function [f] in turn to all the bytes of [s] + (in increasing index order) and stores the resulting bytes in + a new sequence that is returned as the result. *) + +val mapi : (int -> char -> char) -> bytes -> bytes +(** [mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the resulting bytes + in a new sequence that is returned as the result. *) + +val trim : bytes -> bytes +(** Return a copy of the argument, without leading and trailing + whitespace. The bytes regarded as whitespace are the ASCII + characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *) + +val escaped : bytes -> bytes +(** Return a copy of the argument, with special characters represented + by escape sequences, following the lexical conventions of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash and double-quote. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val index : bytes -> char -> int +(** [index s c] returns the index of the first occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : bytes -> char -> int +(** [rindex s c] returns the index of the last occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : bytes -> int -> char -> int +(** [index_from s i c] returns the index of the first occurrence of + byte [c] in [s] after position [i]. [Bytes.index s c] is + equivalent to [Bytes.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + +val rindex_from : bytes -> int -> char -> int +(** [rindex_from s i c] returns the index of the last occurrence of + byte [c] in [s] before position [i+1]. [rindex s c] is equivalent + to [rindex_from s (Bytes.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + +val contains : bytes -> char -> bool +(** [contains s c] tests if byte [c] appears in [s]. *) + +val contains_from : bytes -> int -> char -> bool +(** [contains_from s start c] tests if byte [c] appears in [s] after + position [start]. [contains s c] is equivalent to [contains_from + s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : bytes -> int -> char -> bool +(** [rcontains_from s stop c] tests if byte [c] appears in [s] before + position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.uppercase_ascii instead."] +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val lowercase : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.lowercase_ascii instead."] +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val capitalize : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.capitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to uppercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val uncapitalize : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.uncapitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to lowercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val uppercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) + +val lowercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) + +val capitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to uppercase, + using the US-ASCII character set. + @since 4.03.0 *) + +val uncapitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to lowercase, + using the US-ASCII character set. + @since 4.03.0 *) + +type t = bytes +(** An alias for the type of byte sequences. *) + +val compare: t -> t -> int +(** The comparison function for byte sequences, with the same + specification as {!Pervasives.compare}. Along with the type [t], + this function [compare] allows the module [Bytes] to be passed as + argument to the functors {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equality function for byte sequences. + @since 4.03.0 *) + +(** {4 Unsafe conversions (for advanced users)} + + This section describes unsafe, low-level conversion functions + between [bytes] and [string]. They do not copy the internal data; + used improperly, they can break the immutability invariant on + strings provided by the [-safe-string] option. They are available for + expert library authors, but for most purposes you should use the + always-correct {!Bytes.to_string} and {!Bytes.of_string} instead. +*) + +val unsafe_to_string : bytes -> string +(** Unsafely convert a byte sequence into a string. + + To reason about the use of [unsafe_to_string], it is convenient to + consider an "ownership" discipline. A piece of code that + manipulates some data "owns" it; there are several disjoint ownership + modes, including: + - Unique ownership: the data may be accessed and mutated + - Shared ownership: the data has several owners, that may only + access it, not mutate it. + + Unique ownership is linear: passing the data to another piece of + code means giving up ownership (we cannot write the + data again). A unique owner may decide to make the data shared + (giving up mutation rights on it), but shared data may not become + uniquely-owned again. + + [unsafe_to_string s] can only be used when the caller owns the byte + sequence [s] -- either uniquely or as shared immutable data. The + caller gives up ownership of [s], and gains ownership of the + returned string. + + There are two valid use-cases that respect this ownership + discipline: + + 1. Creating a string by initializing and mutating a byte sequence + that is never changed after initialization is performed. + + {[ +let string_init len f : string = + let s = Bytes.create len in + for i = 0 to len - 1 do Bytes.set s i (f i) done; + Bytes.unsafe_to_string s + ]} + + This function is safe because the byte sequence [s] will never be + accessed or mutated after [unsafe_to_string] is called. The + [string_init] code gives up ownership of [s], and returns the + ownership of the resulting string to its caller. + + Note that it would be unsafe if [s] was passed as an additional + parameter to the function [f] as it could escape this way and be + mutated in the future -- [string_init] would give up ownership of + [s] to pass it to [f], and could not call [unsafe_to_string] + safely. + + We have provided the {!String.init}, {!String.map} and + {!String.mapi} functions to cover most cases of building + new strings. You should prefer those over [to_string] or + [unsafe_to_string] whenever applicable. + + 2. Temporarily giving ownership of a byte sequence to a function + that expects a uniquely owned string and returns ownership back, so + that we can mutate the sequence again after the call ended. + + {[ +let bytes_length (s : bytes) = + String.length (Bytes.unsafe_to_string s) + ]} + + In this use-case, we do not promise that [s] will never be mutated + after the call to [bytes_length s]. The {!String.length} function + temporarily borrows unique ownership of the byte sequence + (and sees it as a [string]), but returns this ownership back to + the caller, which may assume that [s] is still a valid byte + sequence after the call. Note that this is only correct because we + know that {!String.length} does not capture its argument -- it could + escape by a side-channel such as a memoization combinator. + + The caller may not mutate [s] while the string is borrowed (it has + temporarily given up ownership). This affects concurrent programs, + but also higher-order functions: if [String.length] returned + a closure to be called later, [s] should not be mutated until this + closure is fully applied and returns ownership. +*) + +val unsafe_of_string : string -> bytes +(** Unsafely convert a shared string to a byte sequence that should + not be mutated. + + The same ownership discipline that makes [unsafe_to_string] + correct applies to [unsafe_of_string]: you may use it if you were + the owner of the [string] value, and you will own the return + [bytes] in the same mode. + + In practice, unique ownership of string values is extremely + difficult to reason about correctly. You should always assume + strings are shared, never uniquely owned. + + For example, string literals are implicitly shared by the + compiler, so you never uniquely own them. + + {[ +let incorrect = Bytes.unsafe_of_string "hello" +let s = Bytes.of_string "hello" + ]} + + The first declaration is incorrect, because the string literal + ["hello"] could be shared by the compiler with other parts of the + program, and mutating [incorrect] is a bug. You must always use + the second version, which performs a copy and is thus correct. + + Assuming unique ownership of strings that are not string + literals, but are (partly) built from string literals, is also + incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)] + could mutate the shared string ["foo"] -- assuming a rope-like + representation of strings. More generally, functions operating on + strings will assume shared ownership, they do not preserve unique + ownership. It is thus incorrect to assume unique ownership of the + result of [unsafe_of_string]. + + The only case we have reasonable confidence is safe is if the + produced [bytes] is shared -- used as an immutable byte + sequence. This is possibly useful for incremental migration of + low-level programs that manipulate immutable sequences of bytes + (for example {!Marshal.from_bytes}) and previously used the + [string] type for this purpose. +*) + +(**/**) + +(* The following is for system use only. Do not call directly. *) + +external unsafe_get : bytes -> int -> char = "%string_unsafe_get" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" [@@noalloc] +external unsafe_fill : + bytes -> int -> int -> char -> unit = "caml_fill_string" [@@noalloc] diff --git a/src/proto/environment/compare.mli b/src/proto/environment/compare.mli new file mode 100644 index 000000000..e288ddb52 --- /dev/null +++ b/src/proto/environment/compare.mli @@ -0,0 +1,23 @@ + +module type S = sig + type t + val (=) : t -> t -> bool + val (<>) : t -> t -> bool + val (<) : t -> t -> bool + val (<=) : t -> t -> bool + val (>=) : t -> t -> bool + val (>) : t -> t -> bool + val compare : t -> t -> int + val max : t -> t -> t + val min : t -> t -> t +end + +module Char : S with type t = char +module Bool : S with type t = bool +module Int : S with type t = int +module Int32 : S with type t = int32 +module Int64 : S with type t = int64 +module Float : S with type t = float +module String : S with type t = string +module List(P : S) : S with type t = P.t list +module Option(P : S) : S with type t = P.t option diff --git a/src/proto/environment/context.mli b/src/proto/environment/context.mli new file mode 100644 index 000000000..3bf8d08d5 --- /dev/null +++ b/src/proto/environment/context.mli @@ -0,0 +1,9 @@ +(** View over the context store, restricted to types, access and + functional manipulation of an existing context. *) + +open Hash + +include Persist.STORE + +val get_genesis_time: t -> Time.t Lwt.t +val get_genesis_block: t -> Block_hash.t Lwt.t diff --git a/src/proto/environment/data_encoding.mli b/src/proto/environment/data_encoding.mli new file mode 100644 index 000000000..c9fda6c94 --- /dev/null +++ b/src/proto/environment/data_encoding.mli @@ -0,0 +1,232 @@ + +(** In memory JSON data *) +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +type json_schema + +exception No_case_matched +exception Unexpected_tag of int +exception Duplicated_tag of int +exception Invalid_tag of int * [ `Int8 | `Int16 ] +exception Unexpected_enum of string * string list + +type 'a t +type 'a encoding = 'a t + +val classify : 'a encoding -> [ `Fixed of int | `Dynamic | `Variable ] + +val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding + +val null : unit encoding +val empty : unit encoding +val constant : string -> unit encoding +val int8 : int encoding +val int16 : int encoding +val int31 : int encoding +val int32 : int32 encoding +val int64 : int64 encoding +val bool : bool encoding +val string : string encoding +val bytes : MBytes.t encoding +val float : float encoding +val option : 'a encoding -> 'a option encoding +val string_enum : (string * 'a) list -> 'a encoding + +module Fixed : sig + val string : int -> string encoding + val bytes : int -> MBytes.t encoding +end + +module Variable : sig + val string : string encoding + val bytes : MBytes.t encoding + val array : 'a encoding -> 'a array encoding + val list : 'a encoding -> 'a list encoding +end + +val dynamic_size : 'a encoding -> 'a encoding + +val json : json encoding +val json_schema : json_schema encoding + +type 'a field +val req : + ?title:string -> ?description:string -> + string -> 't encoding -> 't field +val opt : + ?title:string -> ?description:string -> + string -> 't encoding -> 't option field +val varopt : + ?title:string -> ?description:string -> + string -> 't encoding -> 't option field +val dft : + ?title:string -> ?description:string -> + string -> 't encoding -> 't -> 't field + +val obj1 : + 'f1 field -> 'f1 encoding +val obj2 : + 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding +val obj3 : + 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding +val obj4 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> + ('f1 * 'f2 * 'f3 * 'f4) encoding +val obj5 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding +val obj6 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding +val obj7 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding +val obj8 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding +val obj9 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding +val obj10 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 'f10 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val tup1 : + 'f1 encoding -> + 'f1 encoding +val tup2 : + 'f1 encoding -> 'f2 encoding -> + ('f1 * 'f2) encoding +val tup3 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> + ('f1 * 'f2 * 'f3) encoding +val tup4 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + ('f1 * 'f2 * 'f3 * 'f4) encoding +val tup5 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding +val tup6 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding +val tup7 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding +val tup8 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding +val tup9 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + 'f9 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding +val tup10 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + 'f9 encoding -> 'f10 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding +val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding + +val array : 'a encoding -> 'a array encoding +val list : 'a encoding -> 'a list encoding + +type 't case +val case : + ?tag:int -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case +val union : + ?tag_size:[ `Int8 | `Int16 ] -> 't case list -> 't encoding + +val describe : + ?title:string -> ?description:string -> + 't encoding ->'t encoding + +val def : string -> 'a encoding -> 'a encoding + +val conv : + ('a -> 'b) -> ('b -> 'a) -> + ?schema:json_schema -> + 'b encoding -> 'a encoding + +val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding + +module Json : sig + + (** Read a JSON document from a string. *) + val from_string : string -> (json, string) result + + (** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) + val to_string : json -> string + + val schema : 'a encoding -> json_schema + val construct : 't encoding -> 't -> json + val destruct : 't encoding -> json -> 't + + (** JSON Error *) + + type path = path_item list + and path_item = + [ `Field of string + (** A field in an object. *) + | `Index of int + (** An index in an array. *) + | `Star + (** Any / every field or index. *) + | `Next + (** The next element after an array. *) ] + + (** Exception raised by destructors, with the location in the original + JSON structure and the specific error. *) + exception Cannot_destruct of (path * exn) + + (** Unexpected kind of data encountered (w/ the expectation). *) + exception Unexpected of string * string + + (** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *) + exception No_case_matched of exn list + + (** Array of unexpected size encountered (w/ the expectation). *) + exception Bad_array_size of int * int + + (** Missing field in an object. *) + exception Missing_field of string + + (** Supernumerary field in an object. *) + exception Unexpected_field of string + + val print_error : + ?print_unknown: (Format.formatter -> exn -> unit) -> + Format.formatter -> exn -> unit + + (** Helpers for writing encoders. *) + val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a + val wrap_error : ('a -> 'b) -> 'a -> 'b + +end + +module Binary : sig + + val length : 'a encoding -> 'a -> int + val read : 'a encoding -> MBytes.t -> int -> int -> (int * 'a) option + val write : 'a encoding -> 'a -> MBytes.t -> int -> int option + val to_bytes : 'a encoding -> 'a -> MBytes.t + val of_bytes : 'a encoding -> MBytes.t -> 'a option + +end diff --git a/src/proto/environment/ed25519.mli b/src/proto/environment/ed25519.mli new file mode 100644 index 000000000..3dc1fa5d0 --- /dev/null +++ b/src/proto/environment/ed25519.mli @@ -0,0 +1,48 @@ +(** Tezos - Ed25519 cryptography *) + + +(** {2 Signature} ************************************************************) + +(** An Ed25519 public key *) +type public_key + +(** An Ed25519 secret key *) +type secret_key + +(** The result of signing a sequence of bytes with a secret key *) +type signature + +(** Signs a sequence of bytes with a secret key *) +val sign : secret_key -> MBytes.t -> signature + +(** Checks a signature *) +val check_signature : public_key -> signature -> MBytes.t -> bool + +(** {2 Hashed public keys for user ID} ***************************************) + +module Public_key_hash : Hash.HASH + +(** A Sha256 hash of an Ed25519 public key for use as an ID *) +type public_key_hash = Public_key_hash.t + +(** Hashes an Ed25519 public key *) +val hash : public_key -> public_key_hash + +(** For using IDs as keys in the database *) +val hash_path : public_key_hash -> string list + +(** ID comparison *) +val equal_hash : public_key_hash -> public_key_hash -> bool + +(** ID comparison *) +val compare_hash : public_key_hash -> public_key_hash -> int + +(** {2 Serializers} **********************************************************) + +val public_key_hash_encoding : public_key_hash Data_encoding.t + +val public_key_encoding : public_key Data_encoding.t + +val secret_key_encoding : secret_key Data_encoding.t + +val signature_encoding : signature Data_encoding.t diff --git a/src/proto/environment/error_monad.mli b/src/proto/environment/error_monad.mli new file mode 100644 index 000000000..973f2d186 --- /dev/null +++ b/src/proto/environment/error_monad.mli @@ -0,0 +1,99 @@ +(** Tezos Protocol Implementation - Error Monad *) + +(** {2 Error classification} *************************************************) + +(** Categories of error *) +type error_category = + [ `Branch (** Errors that may not happen in another context *) + | `Temporary (** Errors that may not happen in a later context *) + | `Permanent (** Errors that will happen no matter the context *) + ] + +(** Custom error handling for economical protocols. *) + +type error = .. + +val pp : Format.formatter -> error -> unit + +(** A JSON error serializer *) +val error_encoding : unit -> error Data_encoding.t +val json_of_error : error -> Data_encoding.json +val error_of_json : Data_encoding.json -> error + +(** For other modules to register specialized error serializers *) +val register_error_kind : + error_category -> + id:string -> title:string -> description:string -> + ?pp:(Format.formatter -> 'err -> unit) -> + 'err Data_encoding.t -> + (error -> 'err option) -> ('err -> error) -> + unit + +(** Classify an error using the registered kinds *) +val classify_errors : error list -> error_category + +(** {2 Monad definition} *****************************************************) + +(** The error monad wrapper type, the error case holds a stack of + error, initialized by the first call to {!fail} and completed by + each call to {!trace} as the stack is rewinded. The most general + error is thus at the top of the error stack, going down to the + specific error that actually caused the failure. *) +type 'a tzresult = ('a, error list) result + +(** A JSON serializer for result of a given type *) +val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding + +(** Sucessful result *) +val ok : 'a -> 'a tzresult + +(** Sucessful return *) +val return : 'a -> 'a tzresult Lwt.t + +(** Erroneous result *) +val error : error -> 'a tzresult + +(** Erroneous return *) +val fail : error -> 'a tzresult Lwt.t + +(** Non-Lwt bind operator *) +val (>>?) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult + +(** Bind operator *) +val (>>=?) : 'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t + +(** Lwt's bind reexported *) +val (>>=) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t +val (>|=) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + +(** To operator *) +val (>>|?) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t + +(** Non-Lwt to operator *) +val (>|?) : 'a tzresult -> ('a -> 'b) -> 'b tzresult + +(** Enrich an error report (or do nothing on a successful result) manually *) +val record_trace : error -> 'a tzresult -> 'a tzresult + +(** Automatically enrich error reporting on stack rewind *) +val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + +(** Erroneous return on failed assertion *) +val fail_unless : bool -> error -> unit tzresult Lwt.t + +(** {2 In-monad list iterators} **********************************************) + +(** A {!List.iter} in the monad *) +val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + +(** A {!List.map} in the monad *) +val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + +(** A {!List.map_filter} in the monad *) +val map_filter_s : ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + +(** A {!List.fold_left} in the monad *) +val fold_left_s : ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t + +(** A {!List.fold_right} in the monad *) +val fold_right_s : ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t diff --git a/src/proto/environment/fitness.mli b/src/proto/environment/fitness.mli new file mode 100644 index 000000000..ac21c6056 --- /dev/null +++ b/src/proto/environment/fitness.mli @@ -0,0 +1,8 @@ + +type fitness = MBytes.t list + +val compare: fitness -> fitness -> int +val pp: Format.formatter -> fitness -> unit +val to_string: fitness -> string + +val encoding: fitness Data_encoding.t diff --git a/src/proto/environment/format.mli b/src/proto/environment/format.mli new file mode 100644 index 000000000..e9a500129 --- /dev/null +++ b/src/proto/environment/format.mli @@ -0,0 +1,306 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* TEZOS CHANGES + + * import version 4.03.0 + * Removed channel functions + * Removed toplevel effect based functions + * Removed deprecated functions + +*) + +(** Pretty printing. + + This module implements a pretty-printing facility to format values + within 'pretty-printing boxes'. The pretty-printer splits lines + at specified break hints, and indents lines according to the box + structure. + + For a gentle introduction to the basics of pretty-printing using + [Format], read + {{:http://caml.inria.fr/resources/doc/guides/format.en.html} + http://caml.inria.fr/resources/doc/guides/format.en.html}. + + You may consider this module as providing an extension to the + [printf] facility to provide automatic line splitting. The addition of + pretty-printing annotations to your regular [printf] formats gives you + fancy indentation and line breaks. + Pretty-printing annotations are described below in the documentation of + the function {!Format.fprintf}. + + You may also use the explicit box management and printing functions + provided by this module. This style is more basic but more verbose + than the [fprintf] concise formats. + + For instance, the sequence + [open_box 0; print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()] + that prints [x = 1] within a pretty-printing box, can be + abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter + [printf "@[x =@ %i@]@." 1]. + + Rule of thumb for casual users of this library: + - use simple boxes (as obtained by [open_box 0]); + - use simple break hints (as obtained by [print_cut ()] that outputs a + simple break hint, or by [print_space ()] that outputs a space + indicating a break hint); + - once a box is opened, display its material with basic printing + functions (e. g. [print_int] and [print_string]); + - when the material for a box has been printed, call [close_box ()] to + close the box; + - at the end of your routine, flush the pretty-printer to display all the + remaining material, e.g. evaluate [print_newline ()]. + + The behaviour of pretty-printing commands is unspecified + if there is no opened pretty-printing box. Each box opened via + one of the [open_] functions below must be closed using [close_box] + for proper formatting. Otherwise, some of the material printed in the + boxes may not be output, or may be formatted incorrectly. + + In case of interactive use, the system closes all opened boxes and + flushes all pending text (as with the [print_newline] function) + after each phrase. Each phrase is therefore executed in the initial + state of the pretty-printer. + + Warning: the material output by the following functions is delayed + in the pretty-printer queue in order to compute the proper line + splitting. Hence, you should not mix calls to the printing functions + of the basic I/O system with calls to the functions of this module: + this could result in some strange output seemingly unrelated with + the evaluation order of printing commands. +*) + +(** {6 Multiple formatted output} *) + +type formatter;; +(** Abstract data corresponding to a pretty-printer (also called a + formatter) and all its machinery. + + Defining new pretty-printers permits unrelated output of material in + parallel on several output channels. + All the parameters of a pretty-printer are local to this pretty-printer: + margin, maximum indentation limit, maximum number of boxes + simultaneously opened, ellipsis, and so on, are specific to + each pretty-printer and may be fixed independently. + Given a [Pervasives.out_channel] output channel [oc], a new formatter + writing to that channel is simply obtained by calling + [formatter_of_out_channel oc]. + Alternatively, the [make_formatter] function allocates a new + formatter with explicit output and flushing functions + (convenient to output material to strings for instance). +*) + +val formatter_of_buffer : Buffer.t -> formatter +(** [formatter_of_buffer b] returns a new formatter writing to + buffer [b]. As usual, the formatter has to be flushed at + the end of pretty printing, using [pp_print_flush] or + [pp_print_newline], to display all the pending material. *) + +val make_formatter : + (string -> int -> int -> unit) -> (unit -> unit) -> formatter +(** [make_formatter out flush] returns a new formatter that writes according + to the output function [out], and the flushing function [flush]. For + instance, a formatter to the [Pervasives.out_channel] [oc] is returned by + [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) + +(** {6 Basic functions to use with formatters} *) + +val pp_open_hbox : formatter -> unit -> unit +val pp_open_vbox : formatter -> int -> unit +val pp_open_hvbox : formatter -> int -> unit +val pp_open_hovbox : formatter -> int -> unit +val pp_open_box : formatter -> int -> unit +val pp_close_box : formatter -> unit -> unit +val pp_open_tag : formatter -> string -> unit +val pp_close_tag : formatter -> unit -> unit +val pp_print_string : formatter -> string -> unit +val pp_print_as : formatter -> int -> string -> unit +val pp_print_int : formatter -> int -> unit +val pp_print_float : formatter -> float -> unit +val pp_print_char : formatter -> char -> unit +val pp_print_bool : formatter -> bool -> unit +val pp_print_break : formatter -> int -> int -> unit +val pp_print_cut : formatter -> unit -> unit +val pp_print_space : formatter -> unit -> unit +val pp_force_newline : formatter -> unit -> unit +val pp_print_flush : formatter -> unit -> unit +val pp_print_newline : formatter -> unit -> unit +val pp_print_if_newline : formatter -> unit -> unit +val pp_set_tags : formatter -> bool -> unit +val pp_set_print_tags : formatter -> bool -> unit +val pp_set_mark_tags : formatter -> bool -> unit +val pp_get_print_tags : formatter -> unit -> bool +val pp_get_mark_tags : formatter -> unit -> bool +val pp_set_margin : formatter -> int -> unit +val pp_get_margin : formatter -> unit -> int +val pp_set_max_indent : formatter -> int -> unit +val pp_get_max_indent : formatter -> unit -> int +val pp_set_max_boxes : formatter -> int -> unit +val pp_get_max_boxes : formatter -> unit -> int +val pp_over_max_boxes : formatter -> unit -> bool +val pp_set_ellipsis_text : formatter -> string -> unit +val pp_get_ellipsis_text : formatter -> unit -> string + +(** {6 Convenience formatting functions.} *) + +val pp_print_list: + ?pp_sep:(formatter -> unit -> unit) -> + (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) +(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l], + using [pp_v] to print each item, and calling [pp_sep] + between items ([pp_sep] defaults to {!pp_print_cut}). + Does nothing on empty lists. + + @since 4.02.0 +*) + +val pp_print_text : formatter -> string -> unit +(** [pp_print_text ppf s] prints [s] with spaces and newlines + respectively printed with {!pp_print_space} and + {!pp_force_newline}. + + @since 4.02.0 +*) + +(** {6 [printf] like functions for pretty-printing.} *) + +val fprintf : formatter -> ('a, formatter, unit) format -> 'a + +(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] + according to the format string [fmt], and outputs the resulting string on + the formatter [ff]. + + The format [fmt] is a character string which contains three types of + objects: plain characters and conversion specifications as specified in + the [Printf] module, and pretty-printing indications specific to the + [Format] module. + + The pretty-printing indication characters are introduced by + a [@] character, and their meanings are: + - [@\[]: open a pretty-printing box. The type and offset of the + box may be optionally specified with the following syntax: + the [<] character, followed by an optional box type indication, + then an optional integer offset, and the closing [>] character. + Box type is one of [h], [v], [hv], [b], or [hov]. + '[h]' stands for an 'horizontal' box, + '[v]' stands for a 'vertical' box, + '[hv]' stands for an 'horizontal-vertical' box, + '[b]' stands for an 'horizontal-or-vertical' box demonstrating indentation, + '[hov]' stands a simple 'horizontal-or-vertical' box. + For instance, [@\[] opens an 'horizontal-or-vertical' + box with indentation 2 as obtained with [open_hovbox 2]. + For more details about boxes, see the various box opening + functions [open_*box]. + - [@\]]: close the most recently opened pretty-printing box. + - [@,]: output a 'cut' break hint, as with [print_cut ()]. + - [@ ]: output a 'space' break hint, as with [print_space ()]. + - [@;]: output a 'full' break hint as with [print_break]. The + [nspaces] and [offset] parameters of the break hint may be + optionally specified with the following syntax: + the [<] character, followed by an integer [nspaces] value, + then an integer [offset], and a closing [>] character. + If no parameters are provided, the good break defaults to a + 'space' break hint. + - [@.]: flush the pretty printer and split the line, as with + [print_newline ()]. + - [@]: print the following item as if it were of length [n]. + Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string. + If [@] is not followed by a conversion specification, + then the following character of the format is printed as if + it were of length [n]. + - [@\{]: open a tag. The name of the tag may be optionally + specified with the following syntax: + the [<] character, followed by an optional string + specification, and the closing [>] character. The string + specification is any character string that does not contain the + closing character ['>']. If omitted, the tag name defaults to the + empty string. + For more details about tags, see the functions [open_tag] and + [close_tag]. + - [@\}]: close the most recently opened tag. + - [@?]: flush the pretty printer as with [print_flush ()]. + This is equivalent to the conversion [%!]. + - [@\n]: force a newline, as with [force_newline ()], not the normal way + of pretty-printing, you should prefer using break hints inside a vertical + box. + + Note: If you need to prevent the interpretation of a [@] character as a + pretty-printing indication, you must escape it with a [%] character. + Old quotation mode [@@] is deprecated since it is not compatible with + formatted input interpretation of character ['@']. + + Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to + [open_box (); print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()]. + It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box. + +*) + +val sprintf : ('a, unit, string) format -> 'a +(** Same as [printf] above, but instead of printing on a formatter, + returns a string containing the result of formatting the arguments. + Note that the pretty-printer queue is flushed at the end of {e each + call} to [sprintf]. + + In case of multiple and related calls to [sprintf] to output + material on a single string, you should consider using [fprintf] + with the predefined formatter [str_formatter] and call + [flush_str_formatter ()] to get the final result. + + Alternatively, you can use [Format.fprintf] with a formatter writing to a + buffer of your own: flushing the formatter and the buffer at the end of + pretty-printing returns the desired string. +*) + +val asprintf : ('a, formatter, unit, string) format4 -> 'a +(** Same as [printf] above, but instead of printing on a formatter, + returns a string containing the result of formatting the arguments. + The type of [asprintf] is general enough to interact nicely with [%a] + conversions. + @since 4.01.0 +*) + +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a +(** Same as [fprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + @since 3.10.0 +*) + +(** Formatted output functions with continuations. *) + +val kfprintf : + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [fprintf] above, but instead of returning immediately, + passes the formatter to its first argument at the end of printing. *) + +val ikfprintf : + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [kfprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + @since 3.12.0 +*) + +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b +(** Same as [sprintf] above, but instead of returning the string, + passes it to the first argument. *) + +val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b +(** Same as [asprintf] above, but instead of returning the string, + passes it to the first argument. + @since 4.03 +*) diff --git a/src/proto/environment/hash.mli b/src/proto/environment/hash.mli new file mode 100644 index 000000000..f7deb5da7 --- /dev/null +++ b/src/proto/environment/hash.mli @@ -0,0 +1,80 @@ +(** Tezos - Manipulation and creation of hashes *) + + +(** {2 Hash Types} ************************************************************) + +(** The signature of an abstract hash type, as produced by functor + {!Make_SHA256}. The {!t} type is abstracted for separating the + various kinds of hashes in the system at typing time. Each type is + equipped with functions to use it as is of as keys in the database + or in memory sets and maps. *) +module type HASH = sig + type t + + val hash_bytes: MBytes.t list -> t + val hash_string: string list -> t + val size: int (* in bytes *) + val compare: t -> t -> int + val equal: t -> t -> bool + val of_raw: string -> t + val to_raw: t -> string + val of_hex: string -> t + val to_hex: t -> string + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string + val to_bytes: t -> MBytes.t + val of_bytes: MBytes.t -> t + val read: MBytes.t -> int -> t + val write: MBytes.t -> int -> t -> unit + val to_path: t -> string list + val of_path: string list -> t + val path_len: int + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit + val pp_short: Format.formatter -> t -> unit + type Base48.data += Hash of t +end + +(** {2 Building Hashes} *******************************************************) + +(** The parameters for creating a new Hash type using + {!Make_SHA256}. Both {!name} and {!title} are only informative, + used in error messages and serializers. *) +module type Name = sig + val name : string + val title : string + val prefix : string option +end + +(** Builds a new Hash type using Sha256. *) +module Make_SHA256 (Name:Name) : HASH + +(** Builds a Set of values of some Hash type. *) +module Hash_set (Hash : HASH) : sig + include Set.S with type elt = Hash.t + val encoding: t Data_encoding.t +end + +(** Builds a Map using some Hash type as keys. *) +module Hash_map (Hash : HASH) : sig + include Map.S with type key = Hash.t + val encoding: 'a Data_encoding.t -> 'a t Data_encoding.t +end + +(** {2 Predefined Hashes } ****************************************************) + +(** Blocks hashes / IDs. *) +module Block_hash : HASH +module Block_hash_set : Set.S with type elt = Block_hash.t +module Block_hash_map : module type of Hash_map (Block_hash) + +(** Operations hashes / IDs. *) +module Operation_hash : HASH +module Operation_hash_set : Set.S with type elt = Operation_hash.t +module Operation_hash_map : module type of Hash_map (Operation_hash) + +(** Protocol versions / source hashes. *) +module Protocol_hash : HASH +module Protocol_hash_set : Set.S with type elt = Protocol_hash.t +module Protocol_hash_map : module type of Hash_map (Protocol_hash) diff --git a/src/proto/environment/hex_encode.mli b/src/proto/environment/hex_encode.mli new file mode 100644 index 000000000..6f0fde127 --- /dev/null +++ b/src/proto/environment/hex_encode.mli @@ -0,0 +1,15 @@ +(** Tezos Utility library - Hexadecimal encoding *) + +(** Parses a sequence of hexadecimal characters pairs as bytes *) +val hex_of_bytes: MBytes.t -> string + +(** Prints a sequence of bytes as hexadecimal characters pairs *) +val bytes_of_hex: string -> MBytes.t + +(** Interprets a sequence of hexadecimal characters pairs representing + bytes as the characters codes of an OCaml string. *) +val hex_decode: string -> string + +(** Formats the codes of the characters of an OCaml string as a + sequence of hexadecimal character pairs. *) +val hex_encode: string -> string diff --git a/src/proto/environment/int32.mli b/src/proto/environment/int32.mli new file mode 100644 index 000000000..249fa23db --- /dev/null +++ b/src/proto/environment/int32.mli @@ -0,0 +1,176 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** 32-bit integers. + + This module provides operations on the type [int32] + of signed 32-bit integers. Unlike the built-in [int] type, + the type [int32] is guaranteed to be exactly 32-bit wide on all + platforms. All arithmetic operations over [int32] are taken + modulo 2{^32}. + + Performance notice: values of type [int32] occupy more memory + space than values of type [int], and arithmetic operations on + [int32] are generally slower than those on [int]. Use [int32] + only when the application requires exact 32-bit arithmetic. *) + +val zero : int32 +(** The 32-bit integer 0. *) + +val one : int32 +(** The 32-bit integer 1. *) + +val minus_one : int32 +(** The 32-bit integer -1. *) + +external neg : int32 -> int32 = "%int32_neg" +(** Unary negation. *) + +external add : int32 -> int32 -> int32 = "%int32_add" +(** Addition. *) + +external sub : int32 -> int32 -> int32 = "%int32_sub" +(** Subtraction. *) + +external mul : int32 -> int32 -> int32 = "%int32_mul" +(** Multiplication. *) + +external div : int32 -> int32 -> int32 = "%int32_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) + +external rem : int32 -> int32 -> int32 = "%int32_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int32.rem x y] satisfies the following property: + [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. + If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) + +val succ : int32 -> int32 +(** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) + +val pred : int32 -> int32 +(** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. *) + +val abs : int32 -> int32 +(** Return the absolute value of its argument. *) + +val max_int : int32 +(** The greatest representable 32-bit integer, 2{^31} - 1. *) + +val min_int : int32 +(** The smallest representable 32-bit integer, -2{^31}. *) + + +external logand : int32 -> int32 -> int32 = "%int32_and" +(** Bitwise logical and. *) + +external logor : int32 -> int32 -> int32 = "%int32_or" +(** Bitwise logical or. *) + +external logxor : int32 -> int32 -> int32 = "%int32_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int32 -> int32 +(** Bitwise logical negation *) + +external shift_left : int32 -> int -> int32 = "%int32_lsl" +(** [Int32.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right : int32 -> int -> int32 = "%int32_asr" +(** [Int32.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" +(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external of_int : int -> int32 = "%int32_of_int" +(** Convert the given integer (type [int]) to a 32-bit integer + (type [int32]). *) + +external to_int : int32 -> int = "%int32_to_int" +(** Convert the given 32-bit integer (type [int32]) to an + integer (type [int]). On 32-bit platforms, the 32-bit integer + is taken modulo 2{^31}, i.e. the high-order bit is lost + during the conversion. On 64-bit platforms, the conversion + is exact. *) + +external of_float : float -> int32 + = "caml_int32_of_float" "caml_int32_of_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given floating-point number to a 32-bit integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) + +external to_float : int32 -> float + = "caml_int32_to_float" "caml_int32_to_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given 32-bit integer to a floating-point number. *) + +external of_string : string -> int32 = "caml_int32_of_string" +(** Convert the given string to a 32-bit integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int32]. *) + +val to_string : int32 -> string +(** Return the string representation of its argument, in signed decimal. *) + +external bits_of_float : float -> int32 + = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed" + [@@unboxed] [@@noalloc] +(** Return the internal representation of the given float according + to the IEEE 754 floating-point 'single format' bit layout. + Bit 31 of the result represents the sign of the float; + bits 30 to 23 represent the (biased) exponent; bits 22 to 0 + represent the mantissa. *) + +external float_of_bits : int32 -> float + = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed" + [@@unboxed] [@@noalloc] +(** Return the floating-point number whose internal representation, + according to the IEEE 754 floating-point 'single format' bit layout, + is the given [int32]. *) + +type t = int32 +(** An alias for the type of 32-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 32-bit integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Int32] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for int32s. + @since 4.03.0 *) + +(**/**) + +(** {6 Deprecated functions} *) + +external format : string -> int32 -> string = "caml_int32_format" +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%l...] format. *) diff --git a/src/proto/environment/int64.mli b/src/proto/environment/int64.mli new file mode 100644 index 000000000..85df21fe2 --- /dev/null +++ b/src/proto/environment/int64.mli @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** 64-bit integers. + + This module provides operations on the type [int64] of + signed 64-bit integers. Unlike the built-in [int] type, + the type [int64] is guaranteed to be exactly 64-bit wide on all + platforms. All arithmetic operations over [int64] are taken + modulo 2{^64} + + Performance notice: values of type [int64] occupy more memory + space than values of type [int], and arithmetic operations on + [int64] are generally slower than those on [int]. Use [int64] + only when the application requires exact 64-bit arithmetic. +*) + +val zero : int64 +(** The 64-bit integer 0. *) + +val one : int64 +(** The 64-bit integer 1. *) + +val minus_one : int64 +(** The 64-bit integer -1. *) + +external neg : int64 -> int64 = "%int64_neg" +(** Unary negation. *) + +external add : int64 -> int64 -> int64 = "%int64_add" +(** Addition. *) + +external sub : int64 -> int64 -> int64 = "%int64_sub" +(** Subtraction. *) + +external mul : int64 -> int64 -> int64 = "%int64_mul" +(** Multiplication. *) + +external div : int64 -> int64 -> int64 = "%int64_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) + +external rem : int64 -> int64 -> int64 = "%int64_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int64.rem x y] satisfies the following property: + [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. + If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) + +val succ : int64 -> int64 +(** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) + +val pred : int64 -> int64 +(** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. *) + +val abs : int64 -> int64 +(** Return the absolute value of its argument. *) + +val max_int : int64 +(** The greatest representable 64-bit integer, 2{^63} - 1. *) + +val min_int : int64 +(** The smallest representable 64-bit integer, -2{^63}. *) + +external logand : int64 -> int64 -> int64 = "%int64_and" +(** Bitwise logical and. *) + +external logor : int64 -> int64 -> int64 = "%int64_or" +(** Bitwise logical or. *) + +external logxor : int64 -> int64 -> int64 = "%int64_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int64 -> int64 +(** Bitwise logical negation *) + +external shift_left : int64 -> int -> int64 = "%int64_lsl" +(** [Int64.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right : int64 -> int -> int64 = "%int64_asr" +(** [Int64.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" +(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external of_int : int -> int64 = "%int64_of_int" +(** Convert the given integer (type [int]) to a 64-bit integer + (type [int64]). *) + +external to_int : int64 -> int = "%int64_to_int" +(** Convert the given 64-bit integer (type [int64]) to an + integer (type [int]). On 64-bit platforms, the 64-bit integer + is taken modulo 2{^63}, i.e. the high-order bit is lost + during the conversion. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^31}, i.e. the top 33 bits are lost + during the conversion. *) + +external of_float : float -> int64 + = "caml_int64_of_float" "caml_int64_of_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given floating-point number to a 64-bit integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) + +external to_float : int64 -> float + = "caml_int64_to_float" "caml_int64_to_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given 64-bit integer to a floating-point number. *) + + +external of_int32 : int32 -> int64 = "%int64_of_int32" +(** Convert the given 32-bit integer (type [int32]) + to a 64-bit integer (type [int64]). *) + +external to_int32 : int64 -> int32 = "%int64_to_int32" +(** Convert the given 64-bit integer (type [int64]) to a + 32-bit integer (type [int32]). The 64-bit integer + is taken modulo 2{^32}, i.e. the top 32 bits are lost + during the conversion. *) + +external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" +(** Convert the given native integer (type [nativeint]) + to a 64-bit integer (type [int64]). *) + +external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" +(** Convert the given 64-bit integer (type [int64]) to a + native integer. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^32}. On 64-bit platforms, + the conversion is exact. *) + +external of_string : string -> int64 = "caml_int64_of_string" +(** Convert the given string to a 64-bit integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int64]. *) + +val to_string : int64 -> string +(** Return the string representation of its argument, in decimal. *) + +external bits_of_float : float -> int64 + = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed" + [@@unboxed] [@@noalloc] +(** Return the internal representation of the given float according + to the IEEE 754 floating-point 'double format' bit layout. + Bit 63 of the result represents the sign of the float; + bits 62 to 52 represent the (biased) exponent; bits 51 to 0 + represent the mantissa. *) + +external float_of_bits : int64 -> float + = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" + [@@unboxed] [@@noalloc] +(** Return the floating-point number whose internal representation, + according to the IEEE 754 floating-point 'double format' bit layout, + is the given [int64]. *) + +type t = int64 +(** An alias for the type of 64-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 64-bit integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Int64] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val equal: t -> t -> bool +(** The equal function for int64s. + @since 4.03.0 *) + +(**/**) + +(** {6 Deprecated functions} *) + +external format : string -> int64 -> string = "caml_int64_format" +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%L...] format. *) diff --git a/src/proto/environment/json.mli b/src/proto/environment/json.mli new file mode 100644 index 000000000..3f61e1603 --- /dev/null +++ b/src/proto/environment/json.mli @@ -0,0 +1,21 @@ +open MBytes + +(** In memory JSON data *) +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +(** Read a JSON document from a string. *) +val from_string : string -> (json, string) result + +(** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) +val to_string : json -> string + +(** Helpers for [Data_encoding] *) +val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a +val wrap_error : ('a -> 'b) -> 'a -> 'b diff --git a/src/proto/environment/list.mli b/src/proto/environment/list.mli new file mode 100644 index 000000000..10ea35883 --- /dev/null +++ b/src/proto/environment/list.mli @@ -0,0 +1,299 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** List operations. + + Some functions are flagged as not tail-recursive. A tail-recursive + function uses constant stack space, while a non-tail-recursive function + uses stack space proportional to the length of its list argument, which + can be a problem with very long lists. When the function takes several + list arguments, an approximate formula giving stack usage (in some + unspecified constant unit) is shown in parentheses. + + The above considerations can usually be ignored if your lists are not + longer than about 10000 elements. +*) + +val length : 'a list -> int +(** Return the length (number of elements) of the given list. *) + +val cons : 'a -> 'a list -> 'a list +(** [cons x xs] is [x :: xs] + @since 4.03.0 +*) + +val hd : 'a list -> 'a +(** Return the first element of the given list. Raise + [Failure "hd"] if the list is empty. *) + +val tl : 'a list -> 'a list +(** Return the given list without its first element. Raise + [Failure "tl"] if the list is empty. *) + +val nth : 'a list -> int -> 'a +(** Return the [n]-th element of the given list. + The first element (head of the list) is at position 0. + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) + +val rev : 'a list -> 'a list +(** List reversal. *) + +val append : 'a list -> 'a list -> 'a list +(** Concatenate two lists. Same as the infix operator [@]. + Not tail-recursive (length of the first argument). *) + +val rev_append : 'a list -> 'a list -> 'a list +(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. + This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is + tail-recursive and more efficient. *) + +val concat : 'a list list -> 'a list +(** Concatenate a list of lists. The elements of the argument are all + concatenated together (in the same order) to give the result. + Not tail-recursive + (length of the argument + length of the longest sub-list). *) + +val flatten : 'a list list -> 'a list +(** Same as [concat]. Not tail-recursive + (length of the argument + length of the longest sub-list). *) + + +(** {6 Iterators} *) + + +val iter : ('a -> unit) -> 'a list -> unit +(** [List.iter f [a1; ...; an]] applies function [f] in turn to + [a1; ...; an]. It is equivalent to + [begin f a1; f a2; ...; f an; () end]. *) + +val iteri : (int -> 'a -> unit) -> 'a list -> unit +(** Same as {!List.iter}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. + @since 4.00.0 +*) + +val map : ('a -> 'b) -> 'a list -> 'b list +(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], + and builds the list [[f a1; ...; f an]] + with the results returned by [f]. Not tail-recursive. *) + +val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list +(** Same as {!List.map}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. Not tail-recursive. + @since 4.00.0 +*) + +val rev_map : ('a -> 'b) -> 'a list -> 'b list +(** [List.rev_map f l] gives the same result as + {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and + more efficient. *) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a +(** [List.fold_left f a [b1; ...; bn]] is + [f (... (f (f a b1) b2) ...) bn]. *) + +val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +(** [List.fold_right f [a1; ...; an] b] is + [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) + + +(** {6 Iterators on two lists} *) + + +val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit +(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn + [f a1 b1; ...; f an bn]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) + +val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is + [[f a1 b1; ...; f an bn]]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) + +val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.rev_map2 f l1 l2] gives the same result as + {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and + more efficient. *) + +val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a +(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is + [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) + +val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c +(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is + [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) + + +(** {6 List scanning} *) + + +val for_all : ('a -> bool) -> 'a list -> bool +(** [for_all p [a1; ...; an]] checks if all elements of the list + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) + +val exists : ('a -> bool) -> 'a list -> bool +(** [exists p [a1; ...; an]] checks if at least one element of + the list satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) + +val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!List.for_all}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) + +val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!List.exists}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) + +val mem : 'a -> 'a list -> bool +(** [mem a l] is true if and only if [a] is equal + to an element of [l]. *) + +val memq : 'a -> 'a list -> bool +(** Same as {!List.mem}, but uses physical equality instead of structural + equality to compare list elements. *) + + +(** {6 List searching} *) + + +val find : ('a -> bool) -> 'a list -> 'a +(** [find p l] returns the first element of the list [l] + that satisfies the predicate [p]. + Raise [Not_found] if there is no value that satisfies [p] in the + list [l]. *) + +val filter : ('a -> bool) -> 'a list -> 'a list +(** [filter p l] returns all the elements of the list [l] + that satisfy the predicate [p]. The order of the elements + in the input list is preserved. *) + +val find_all : ('a -> bool) -> 'a list -> 'a list +(** [find_all] is another name for {!List.filter}. *) + +val partition : ('a -> bool) -> 'a list -> 'a list * 'a list +(** [partition p l] returns a pair of lists [(l1, l2)], where + [l1] is the list of all the elements of [l] that + satisfy the predicate [p], and [l2] is the list of all the + elements of [l] that do not satisfy [p]. + The order of the elements in the input list is preserved. *) + + +(** {6 Association lists} *) + + +val assoc : 'a -> ('a * 'b) list -> 'b +(** [assoc a l] returns the value associated with key [a] in the list of + pairs [l]. That is, + [assoc a [ ...; (a,b); ...] = b] + if [(a,b)] is the leftmost binding of [a] in list [l]. + Raise [Not_found] if there is no value associated with [a] in the + list [l]. *) + +val assq : 'a -> ('a * 'b) list -> 'b +(** Same as {!List.assoc}, but uses physical equality instead of structural + equality to compare keys. *) + +val mem_assoc : 'a -> ('a * 'b) list -> bool +(** Same as {!List.assoc}, but simply return true if a binding exists, + and false if no bindings exist for the given key. *) + +val mem_assq : 'a -> ('a * 'b) list -> bool +(** Same as {!List.mem_assoc}, but uses physical equality instead of + structural equality to compare keys. *) + +val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list +(** [remove_assoc a l] returns the list of + pairs [l] without the first pair with key [a], if any. + Not tail-recursive. *) + +val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list +(** Same as {!List.remove_assoc}, but uses physical equality instead + of structural equality to compare keys. Not tail-recursive. *) + + +(** {6 Lists of pairs} *) + + +val split : ('a * 'b) list -> 'a list * 'b list +(** Transform a list of pairs into a pair of lists: + [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. + Not tail-recursive. +*) + +val combine : 'a list -> 'b list -> ('a * 'b) list +(** Transform a pair of lists into a list of pairs: + [combine [a1; ...; an] [b1; ...; bn]] is + [[(a1,b1); ...; (an,bn)]]. + Raise [Invalid_argument] if the two lists + have different lengths. Not tail-recursive. *) + + +(** {6 Sorting} *) + + +val sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Sort a list in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see Array.sort for + a complete specification). For example, + {!Pervasives.compare} is a suitable comparison function. + The resulting list is sorted in increasing order. + [List.sort] is guaranteed to run in constant heap space + (in addition to the size of the result list) and logarithmic + stack space. + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort}, but the sorting algorithm is guaranteed to + be stable (i.e. elements that compare equal are kept in their + original order) . + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster + on typical input. *) + +val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort}, but also remove duplicates. + @since 4.02.0 *) + +val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +(** Merge two lists: + Assuming that [l1] and [l2] are sorted according to the + comparison function [cmp], [merge cmp l1 l2] will return a + sorted list containting all the elements of [l1] and [l2]. + If several elements compare equal, the elements of [l1] will be + before the elements of [l2]. + Not tail-recursive (sum of the lengths of the arguments). +*) diff --git a/src/proto/environment/logging.mli b/src/proto/environment/logging.mli new file mode 100644 index 000000000..118cfc335 --- /dev/null +++ b/src/proto/environment/logging.mli @@ -0,0 +1,13 @@ + +val debug: ('a, Format.formatter, unit, unit) format4 -> 'a +val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a +val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a +val warn: ('a, Format.formatter, unit, unit) format4 -> 'a +val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a +val fatal_error: ('a, Format.formatter, unit, 'b) format4 -> 'a + +val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a diff --git a/src/proto/environment/lwt.mli b/src/proto/environment/lwt.mli new file mode 100644 index 000000000..b6d3e7e52 --- /dev/null +++ b/src/proto/environment/lwt.mli @@ -0,0 +1,469 @@ +(* Lightweight thread library for OCaml + * http://www.ocsigen.org/lwt + * Interface Lwt + * Copyright (C) 2005-2008 J�r�me Vouillon + * Laboratoire PPS - CNRS Universit� Paris Diderot + * 2009-2012 J�r�mie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* TEZOS CHANGES + + * import version 2.4.5 + * Comment a few function that shouldn't be used in the protocol: + * choose: scheduling may be system dependent. + * wait/wakeup + * state + * cancel + * pause + * async + * thread storage + * lwt exceptions +*) + + +(** Module [Lwt]: cooperative light-weight threads. *) + +(** This module defines {e cooperative light-weight threads} with + their primitives. A {e light-weight thread} represent a + computation that may be not terminated, for example because it is + waiting for some event to happen. + + Lwt threads are cooperative in the sense that switching to another + thread is awlays explicit (with {!wakeup} or {!wakeup_exn}). When a + thread is running, it executes as much as possible, and then + returns (a value or an eror) or sleeps. + + Note that inside a Lwt thread, exceptions must be raised with + {!fail} instead of [raise]. Also the [try ... with ...] + construction will not catch Lwt errors. You must use {!catch} + instead. You can also use {!wrap} for functions that may raise + normal exception. + + Lwt also provides the syntax extension {!Pa_lwt} to make code + using Lwt more readable. +*) + +(** {2 Definitions and basics} *) + +type +'a t + (** The type of threads returning a result of type ['a]. *) + +val return : 'a -> 'a t + (** [return e] is a thread whose return value is the value of the + expression [e]. *) + +(* val fail : exn -> 'a t *) +(* (\** [fail e] is a thread that fails with the exception [e]. *\) *) + +val bind : 'a t -> ('a -> 'b t) -> 'b t + (** [bind t f] is a thread which first waits for the thread [t] to + terminate and then, if the thread succeeds, behaves as the + application of function [f] to the return value of [t]. If the + thread [t] fails, [bind t f] also fails, with the same + exception. + + The expression [bind t (fun x -> t')] can intuitively be read as + [let x = t in t'], and if you use the {e lwt.syntax} syntax + extension, you can write a bind operation like that: [lwt x = t in t']. + + Note that [bind] is also often used just for synchronization + purpose: [t'] will not execute before [t] is terminated. + + The result of a thread can be bound several time. *) + +val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** [t >>= f] is an alternative notation for [bind t f]. *) + +val (=<<) : ('a -> 'b t) -> 'a t -> 'b t + (** [f =<< t] is [t >>= f] *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f m] map the result of a thread. This is the same as [bind + m (fun x -> return (f x))] *) + +val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** [m >|= f] is [map f m] *) + +val (=|<) : ('a -> 'b) -> 'a t -> 'b t + (** [f =|< m] is [map f m] *) + +(** {3 Pre-allocated threads} *) + +val return_unit : unit t + (** [return_unit = return ()] *) + +val return_none : 'a option t + (** [return_none = return None] *) + +val return_nil : 'a list t + (** [return_nil = return \[\]] *) + +val return_true : bool t + (** [return_true = return true] *) + +val return_false : bool t + (** [return_false = return false] *) + +(* (\** {2 Thread storage} *\) *) + +(* type 'a key *) +(* (\** Type of a key. Keys are used to store local values into *) +(* threads *\) *) + +(* val new_key : unit -> 'a key *) +(* (\** [new_key ()] creates a new key. *\) *) + +(* val get : 'a key -> 'a option *) +(* (\** [get key] returns the value associated with [key] in the current *) +(* thread. *\) *) + +(* val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b *) +(* (\** [with_value key value f] executes [f] with [value] associated to *) +(* [key]. The previous value associated to [key] is restored after *) +(* [f] terminates. *\) *) + +(* (\** {2 Exceptions handling} *\) *) + +(* val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t *) +(* (\** [catch t f] is a thread that behaves as the thread [t ()] if *) +(* this thread succeeds. If the thread [t ()] fails with some *) +(* exception, [catch t f] behaves as the application of [f] to this *) +(* exception. *\) *) + +(* val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t *) +(* (\** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not *) +(* fail. Otherwise, it behaves as the application of [g] to the *) +(* exception associated to [t ()]. *\) *) + +(* val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t *) +(* (\** [finalize f g] returns the same result as [f ()] whether it *) +(* fails or not. In both cases, [g ()] is executed after [f]. *\) *) + +(* val wrap : (unit -> 'a) -> 'a t *) +(* (\** [wrap f] calls [f] and transform the result into a monad. If [f] *) +(* raise an exception, it is catched by Lwt. *) + +(* This is actually the same as: *) + +(* {[ *) +(* try *) +(* return (f ()) *) +(* with exn -> *) +(* fail exn *) +(* ]} *) +(* *\) *) + +(* val wrap1 : ('a -> 'b) -> 'a -> 'b t *) +(* (\** [wrap1 f x] applies [f] on [x] and returns the result as a *) +(* thread. If the application of [f] to [x] raise an exception it *) +(* is catched and a thread is returned. *) + +(* Note that you must use {!wrap} instead of {!wrap1} if the *) +(* evaluation of [x] may raise an exception. *) + +(* for example the following code is not ok: *) + +(* {[ *) +(* wrap1 f (Hashtbl.find table key) *) +(* ]} *) + +(* you should write instead: *) + +(* {[ *) +(* wrap (fun () -> f (Hashtbl.find table key)) *) +(* ]} *) +(* *\) *) + +(* val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t *) +(* val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t *) +(* val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t *) +(* val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t *) +(* val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t *) +(* val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t *) + +(** {2 Multi-threads composition} *) + +(* we shouldn't use choose: the scheduling may be system dependent *) + +(* val choose : 'a t list -> 'a t *) +(* (\** [choose l] behaves as the first thread in [l] to terminate. If *) +(* several threads are already terminated, one is choosen at *) +(* random. *) + +(* Note: {!choose} leaves the local values of the current thread *) +(* unchanged. *\) *) + +(* val nchoose : 'a t list -> 'a list t *) +(* (\** [nchoose l] returns the value of all that have succcessfully *) +(* terminated. If all threads are sleeping, it waits for at least *) +(* one to terminates. If one the threads of [l] fails, [nchoose] *) +(* fails with the same exception. *) + +(* Note: {!nchoose} leaves the local values of the current thread *) +(* unchanged. *\) *) + +(* val nchoose_split : 'a t list -> ('a list * 'a t list) t *) +(* (\** [nchoose_split l] does the same as {!nchoose} but also retrurns *) +(* the list of threads that have not yet terminated. *\) *) + +val join : unit t list -> unit t + (** [join l] waits for all threads in [l] to terminate. If one of + the threads fails, then [join l] will fails with the same + exception as the first one to terminate. + + Note: {!join} leaves the local values of the current thread + unchanged. *) + +(* val ( ) : 'a t -> 'a t -> 'a t *) +(* (\** [t t'] is the same as [choose [t; t']] *\) *) + +val ( <&> ) : unit t -> unit t -> unit t + (** [t <&> t'] is the same as [join [t; t']] *) + +(* val async : (unit -> 'a t) -> unit *) +(* (\** [async f] starts a thread without waiting for the result. If it *) +(* fails (now or later), the exception is given to *) +(* {!async_exception_hook}. *) + +(* You should use this function if you want to start a thread that *) +(* might fail and don't care what its return value is, nor when it *) +(* terminates (for instance, because it is looping). *\) *) + +(* val ignore_result : 'a t -> unit *) +(* (\** [ignore_result t] is like [Pervasives.ignore t] except that: *) + +(* - if [t] already failed, it raises the exception now, *) +(* - if [t] is sleeping and fails later, the exception will be *) +(* given to {!async_exception_hook}. *\) *) + +(* val async_exception_hook : (exn -> unit) ref *) +(* (\** Function called when a asynchronous exception is thrown. *) + +(* The default behavior is to print an error message with a *) +(* backtrace if available and to exit the program. *) + +(* The behavior is undefined if this function raise an *) +(* exception. *\) *) + +(* (\** {2 Sleeping and resuming} *\) *) + +(* type 'a u *) +(* (\** The type of thread wakeners. *\) *) + +(* val wait : unit -> 'a t * 'a u *) +(* (\** [wait ()] is a pair of a thread which sleeps forever (unless it *) +(* is resumed by one of the functions [wakeup], [wakeup_exn] below) *) +(* and the corresponding wakener. This thread does not block the *) +(* execution of the remainder of the program (except of course, if *) +(* another thread tries to wait for its termination). *\) *) + +(* val wakeup : 'a u -> 'a -> unit *) +(* (\** [wakeup t e] makes the sleeping thread [t] terminate and return *) +(* the value of the expression [e]. *\) *) + +(* val wakeup_exn : 'a u -> exn -> unit *) +(* (\** [wakeup_exn t e] makes the sleeping thread [t] fail with the *) +(* exception [e]. *\) *) + +(* val wakeup_later : 'a u -> 'a -> unit *) +(* (\** Same as {!wakeup} but it is not guaranteed that the thread will *) +(* be woken up immediately. *\) *) + +(* val wakeup_later_exn : 'a u -> exn -> unit *) +(* (\** Same as {!wakeup_exn} but it is not guaranteed that the thread *) +(* will be woken up immediately. *\) *) + +(* val waiter_of_wakener : 'a u -> 'a t *) +(* (\** Returns the thread associated to a wakener. *\) *) + +(* type +'a result *) +(* (\** Either a value of type ['a], either an exception. *\) *) + +(* val make_value : 'a -> 'a result *) +(* (\** [value x] creates a result containing the value [x]. *\) *) + +(* val make_error : exn -> 'a result *) +(* (\** [error e] creates a result containing the exception [e]. *\) *) + +(* val of_result : 'a result -> 'a t *) +(* (\** Returns a thread from a result. *\) *) + +(* val wakeup_result : 'a u -> 'a result -> unit *) +(* (\** [wakeup_result t r] makes the sleeping thread [t] terminate with *) +(* the result [r]. *\) *) + +(* val wakeup_later_result : 'a u -> 'a result -> unit *) +(* (\** Same as {!wakeup_result} but it is not guaranteed that the *) +(* thread will be woken up immediately. *\) *) + +(* (\** {2 Threads state} *\) *) + +(* (\** State of a thread *\) *) +(* type 'a state = *) +(* | Return of 'a *) +(* (\** The thread which has successfully terminated *\) *) +(* | Fail of exn *) +(* (\** The thread raised an exception *\) *) +(* | Sleep *) +(* (\** The thread is sleeping *\) *) + +(* val state : 'a t -> 'a state *) +(* (\** [state t] returns the state of a thread *\) *) + +(* val is_sleeping : 'a t -> bool *) +(* (\** [is_sleeping t] returns [true] iff [t] is sleeping. *\) *) + +(* (\** {2 Cancelable threads} *\) *) + +(* (\** Cancelable threads are the same as regular threads except that *) +(* they can be canceled. *\) *) + +(* exception Canceled *) +(* (\** Canceled threads fails with this exception *\) *) + +(* val task : unit -> 'a t * 'a u *) +(* (\** [task ()] is the same as [wait ()] except that threads created *) +(* with [task] can be canceled. *\) *) + +(* val on_cancel : 'a t -> (unit -> unit) -> unit *) +(* (\** [on_cancel t f] executes [f] when [t] is canceled. [f] will be *) +(* executed before all other threads waiting on [t]. *) + +(* If [f] raises an exception it is given to *) +(* {!async_exception_hook}. *\) *) + +(* val add_task_r : 'a u Lwt_sequence.t -> 'a t *) +(* (\** [add_task_r seq] creates a sleeping thread, adds its wakener to *) +(* the right of [seq] and returns its waiter. When the thread is *) +(* canceled, it is removed from [seq]. *\) *) + +(* val add_task_l : 'a u Lwt_sequence.t -> 'a t *) +(* (\** [add_task_l seq] creates a sleeping thread, adds its wakener to *) +(* the left of [seq] and returns its waiter. When the thread is *) +(* canceled, it is removed from [seq]. *\) *) + +(* val cancel : 'a t -> unit *) +(* (\** [cancel t] cancels the threads [t]. This means that the deepest *) +(* sleeping thread created with [task] and connected to [t] is *) +(* woken up with the exception {!Canceled}. *) + +(* For example, in the following code: *) + +(* {[ *) +(* let waiter, wakener = task () in *) +(* cancel (waiter >> printl "plop") *) +(* ]} *) + +(* [waiter] will be woken up with {!Canceled}. *) +(* *\) *) + +(* val pick : 'a t list -> 'a t *) +(* (\** [pick l] is the same as {!choose}, except that it cancels all *) +(* sleeping threads when one terminates. *) + +(* Note: {!pick} leaves the local values of the current thread *) +(* unchanged. *\) *) + +(* val npick : 'a t list -> 'a list t *) +(* (\** [npick l] is the same as {!nchoose}, except that it cancels all *) +(* sleeping threads when one terminates. *) + +(* Note: {!npick} leaves the local values of the current thread *) +(* unchanged. *\) *) + +(* val protected : 'a t -> 'a t *) +(* (\** [protected thread] creates a new cancelable thread which behave *) +(* as [thread] except that cancelling it does not cancel *) +(* [thread]. *\) *) + +(* val no_cancel : 'a t -> 'a t *) +(* (\** [no_cancel thread] creates a thread which behave as [thread] *) +(* except that it cannot be canceled. *\) *) + +(* (\** {2 Pause} *\) *) + +(* val pause : unit -> unit t *) +(* (\** [pause ()] is a sleeping thread which is wake up on the next *) +(* call to {!wakeup_paused}. A thread created with [pause] can be *) +(* canceled. *\) *) + +(* val wakeup_paused : unit -> unit *) +(* (\** [wakeup_paused ()] wakes up all threads which suspended *) +(* themselves with {!pause}. *) + +(* This function is called by the scheduler, before entering the *) +(* main loop. You usually do not have to call it directly, except *) +(* if you are writing a custom scheduler. *) + +(* Note that if a paused thread resumes and pauses again, it will not *) +(* be woken up at this point. *\) *) + +(* val paused_count : unit -> int *) +(* (\** [paused_count ()] returns the number of currently paused *) +(* threads. *\) *) + +(* val register_pause_notifier : (int -> unit) -> unit *) +(* (\** [register_pause_notifier f] register a function [f] that will be *) +(* called each time pause is called. The parameter passed to [f] is *) +(* the new number of threads paused. It is usefull to be able to *) +(* call {!wakeup_paused} when there is no scheduler *\) *) + +(* (\** {2 Misc} *\) *) + +(* val on_success : 'a t -> ('a -> unit) -> unit *) +(* (\** [on_success t f] executes [f] when [t] terminates without *) +(* failing. If [f] raises an exception it is given to *) +(* {!async_exception_hook}. *\) *) + +(* val on_failure : 'a t -> (exn -> unit) -> unit *) +(* (\** [on_failure t f] executes [f] when [t] terminates and fails. If *) +(* [f] raises an exception it is given to *) +(* {!async_exception_hook}. *\) *) + +(* val on_termination : 'a t -> (unit -> unit) -> unit *) +(* (\** [on_termination t f] executes [f] when [t] terminates. If [f] *) +(* raises an exception it is given to {!async_exception_hook}. *\) *) + +(* val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit *) +(* (\** [on_any t f g] executes [f] or [g] when [t] terminates. If [f] *) +(* or [g] raises an exception it is given to *) +(* {!async_exception_hook}. *\) *) + +(* (\**/**\) *) + +(* (\* The functions below are probably not useful for the casual user. *) +(* They provide the basic primitives on which can be built multi- *) +(* threaded libraries such as Lwt_unix. *\) *) + +(* val poll : 'a t -> 'a option *) +(* (\* [poll e] returns [Some v] if the thread [e] is terminated and *) +(* returned the value [v]. If the thread failed with some *) +(* exception, this exception is raised. If the thread is still *) +(* running, [poll e] returns [None] without blocking. *\) *) + +(* val apply : ('a -> 'b t) -> 'a -> 'b t *) +(* (\* [apply f e] apply the function [f] to the expression [e]. If *) +(* an exception is raised during this application, it is caught *) +(* and the resulting thread fails with this exception. *\) *) +(* (\* Q: Could be called 'glue' or 'trap' or something? *\) *) + +(* val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t *) +(* val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t *) +(* val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t *) +(* val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t *) diff --git a/src/proto/environment/lwt_list.mli b/src/proto/environment/lwt_list.mli new file mode 100644 index 000000000..44497cee8 --- /dev/null +++ b/src/proto/environment/lwt_list.mli @@ -0,0 +1,74 @@ +(* Lightweight thread library for OCaml + * http://www.ocsigen.org/lwt + * Interface Lwt_list + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** List helpers *) + +(* TEZOS CHANGES + + * import version 2.4.5 + +*) + +(** Note: this module use the same naming convention as + {!Lwt_stream}. *) + +(** {2 List iterators} *) + +val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t +val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t +val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + +val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t + +(** {2 List scanning} *) + +val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t +val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t +val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +(** {2 List searching} *) + +val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t + +val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t +val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + +val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t +val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + +val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t +val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t diff --git a/src/proto/environment/lwt_sequence.mli b/src/proto/environment/lwt_sequence.mli new file mode 100644 index 000000000..13c3d0f9f --- /dev/null +++ b/src/proto/environment/lwt_sequence.mli @@ -0,0 +1,155 @@ +(* Lightweight thread library for OCaml + * http://www.ocsigen.org/lwt + * Interface Lwt_sequence + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Mutable sequence of elements *) + +(** A sequence is an object holding a list of elements which support + the following operations: + + - adding an element to the left or the right in time and space O(1) + - taking an element from the left or the right in time and space O(1) + - removing a previously added element from a sequence in time and space O(1) + - removing an element while the sequence is being transversed. +*) + +type 'a t + (** Type of a sequence holding values of type ['a] *) + +type 'a node + (** Type of a node holding one value of type ['a] in a sequence *) + +(** {2 Operation on nodes} *) + +val get : 'a node -> 'a + (** Returns the contents of a node *) + +val set : 'a node -> 'a -> unit + (** Change the contents of a node *) + +val remove : 'a node -> unit + (** Removes a node from the sequence it is part of. It does nothing + if the node has already been removed. *) + +(** {2 Operations on sequence} *) + +val create : unit -> 'a t + (** [create ()] creates a new empty sequence *) + +val is_empty : 'a t -> bool + (** Returns [true] iff the given sequence is empty *) + +val length : 'a t -> int + (** Returns the number of elemenets in the given sequence. This is a + O(n) operation where [n] is the number of elements in the + sequence. *) + +val add_l : 'a -> 'a t -> 'a node + (** [add_l x s] adds [x] to the left of the sequence [s] *) + +val add_r : 'a -> 'a t -> 'a node + (** [add_l x s] adds [x] to the right of the sequence [s] *) + +exception Empty + (** Exception raised by [take_l] and [tale_s] and when the sequence + is empty *) + +val take_l : 'a t -> 'a + (** [take_l x s] remove and returns the leftmost element of [s] + + @raise Empty if the sequence is empty *) + +val take_r : 'a t -> 'a + (** [take_l x s] remove and returns the rightmost element of [s] + + @raise Empty if the sequence is empty *) + +val take_opt_l : 'a t -> 'a option + (** [take_opt_l x s] remove and returns [Some x] where [x] is the + leftmost element of [s] or [None] if [s] is empty *) + +val take_opt_r : 'a t -> 'a option + (** [take_opt_l x s] remove and returns [Some x] where [x] is the + rightmost element of [s] or [None] if [s] is empty *) + +val transfer_l : 'a t -> 'a t -> unit + (** [transfer_l s1 s2] removes all elements of [s1] and add them at + the left of [s2]. This operation runs in constant time and + space. *) + +val transfer_r : 'a t -> 'a t -> unit + (** [transfer_r s1 s2] removes all elements of [s1] and add them at + the right of [s2]. This operation runs in constant time and + space. *) + +(** {2 Sequence iterators} *) + +(** Note: it is OK to remove a node while traversing a sequence *) + +val iter_l : ('a -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all elements of [s] starting from + the left *) + +val iter_r : ('a -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all elements of [s] starting from + the right *) + +val iter_node_l : ('a node -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all nodes of [s] starting from + the left *) + +val iter_node_r : ('a node -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all nodes of [s] starting from + the right *) + +val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_l f s] is: + {[ + fold_l f s x = f en (... (f e2 (f e1 x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] + *) + +val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_r f s] is: + {[ + fold_r f s x = f e1 (f e2 (... (f en x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] + *) + +val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option + (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of + [s] starting from the left that satisfies [f] or [None] if none + exists. *) + +val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option + (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of + [s] starting from the right that satisfies [f] or [None] if none + exists. *) + +val find_node_l : ('a -> bool) -> 'a t -> 'a node + (** [find_node_l f s] returns the first node of [s] starting from the left + that satisfies [f] or raises [Not_found] if none exists. *) + +val find_node_r : ('a -> bool) -> 'a t -> 'a node + (** [find_node_r f s] returns the first node of [s] starting from the right + that satisfies [f] or raises [Not_found] if none exists. *) diff --git a/src/proto/environment/mBytes.mli b/src/proto/environment/mBytes.mli new file mode 100644 index 000000000..12df8946f --- /dev/null +++ b/src/proto/environment/mBytes.mli @@ -0,0 +1,127 @@ + +type t + +val create: int -> t + +val length: t -> int + +val copy: t -> t + +val sub: t -> int -> int -> t +(** [sub src ofs len] extract a sub-array of [src] starting at [ofs] + and of length [len]. No copying of elements is involved: the + sub-array and the original array share the same storage space. *) + +val shift: t -> int -> t +(** [shift src ofs] is equivalent to [sub src ofs (length src - ofs)] *) + +val blit: t -> int -> t -> int -> int -> unit +(** [blit src ofs_src dst ofs_dst len] copy [len] bytes from [src] + starting at [ofs_src] into [dst] starting at [ofs_dst].] *) + +val blit_from_string: string -> int -> t -> int -> int -> unit +(** See [blit] *) + +val blit_to_bytes: t -> int -> bytes -> int -> int -> unit +(** See [blit] *) + +val of_string: string -> t +(** [of_string s] create an byte array filled with the same content than [s]. *) + +val to_string: t -> string +(** [to_string b] dump the array content in a [string]. *) + +val substring: t -> int -> int -> string +(** [substring b ofs len] is equivalent to [to_string (sub b ofs len)]. *) + + + +(** Functions reading and writing bytes *) + +val get_char: t -> int -> char +(** [get_char buff i] reads 1 byte at offset i as a char *) + +val get_bool: t -> int -> bool +(** [get_bool buff i] reads 1 bit at offset i as an unsigned int bit. *) + +val get_uint8: t -> int -> int +(** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + +val get_int8: t -> int -> int +(** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + +val set_char: t -> int -> char -> unit +(** [set_char buff i v] writes [v] to [buff] at offset [i] *) + +val set_int8: t -> int -> int -> unit +(** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + +(** Functions reading according to Big Endian byte order *) + +val get_uint16: t -> int -> int +(** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + +val get_int16: t -> int -> int +(** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + +val get_int32: t -> int -> int32 +(** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + +val get_int64: t -> int -> int64 +(** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + +val set_int16: t -> int -> int -> unit +(** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + +val set_int32: t -> int -> int32 -> unit +(** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + +val set_int64: t -> int -> int64 -> unit +(** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + + +module LE: sig + + (** Functions reading according to Little Endian byte order *) + + val get_uint16: t -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16: t -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32: t -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64: t -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val set_int16: t -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32: t -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64: t -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + +end + +val (=) : t -> t -> bool +val (<>) : t -> t -> bool +val (<) : t -> t -> bool +val (<=) : t -> t -> bool +val (>=) : t -> t -> bool +val (>) : t -> t -> bool +val compare : t -> t -> int + +val concat: t -> t -> t diff --git a/src/proto/environment/map.mli b/src/proto/environment/map.mli new file mode 100644 index 000000000..d8c68f8fd --- /dev/null +++ b/src/proto/environment/map.mli @@ -0,0 +1,232 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Association tables over ordered types. + + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. + + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end + + module PairsMap = Map.Make(IntPairs) + + let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") + ]} + + This creates a new module [PairsMap], with a new type ['a PairsMap.t] + of maps from [int * int] to ['a]. In this example, [m] contains [string] + values so its type is [string PairsMap.t]. +*) + +module type OrderedType = + sig + type t + (** The type of the map keys. *) + + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Map.Make}. *) + +module type S = + sig + type key + (** The type of the map keys. *) + + type (+'a) t + (** The type of maps from type [key] to type ['a]. *) + + val empty: 'a t + (** The empty map. *) + + val is_empty: 'a t -> bool + (** Test whether a map is empty or not. *) + + val mem: key -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + val add: key -> 'a -> 'a t -> 'a t + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m] to a value that is physically equal to [y], + [m] is returned unchanged (the result of the function is + then physically equal to [m]). Otherwise, the previous binding + of [x] in [m] disappears. + @before 4.03 Physical equality was not ensured. *) + + val singleton: key -> 'a -> 'a t + (** [singleton x y] returns the one-element map that contains a binding [y] + for [x]. + @since 3.12.0 + *) + + val remove: key -> 'a t -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. + If [x] was not in [m], [m] is returned unchanged + (the result of the function is then physically equal to [m]). + @before 4.03 Physical equality was not ensured. *) + + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) + + val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + (** [union f m1 m2] computes a map whose keys is the union of keys + of [m1] and of [m2]. When the same binding is defined in both + arguments, the function [f] is used to combine them. + @since 4.03.0 + *) + + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) + + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + + val iter: (key -> 'a -> unit) -> 'a t -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + + val for_all: (key -> 'a -> bool) -> 'a t -> bool + (** [for_all p m] checks if all the bindings of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val exists: (key -> 'a -> bool) -> 'a t -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. If [p] satisfies every binding in [m], + [m] is returned unchanged (the result of the function is then + physically equal to [m]) + @since 3.12.0 + @before 4.03 Physical equality was not ensured. + *) + + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + @since 3.12.0 + *) + + val cardinal: 'a t -> int + (** Return the number of bindings of a map. + @since 3.12.0 + *) + + val bindings: 'a t -> (key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + @since 3.12.0 + *) + + val min_binding: 'a t -> (key * 'a) + (** Return the smallest binding of the given map + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the map is empty. + @since 3.12.0 + *) + + val max_binding: 'a t -> (key * 'a) + (** Same as {!Map.S.min_binding}, but returns the largest binding + of the given map. + @since 3.12.0 + *) + + val choose: 'a t -> (key * 'a) + (** Return one binding of the given map, or raise [Not_found] if + the map is empty. Which binding is chosen is unspecified, + but equal bindings will be chosen for equal maps. + @since 3.12.0 + *) + + val split: key -> 'a t -> 'a t * 'a option * 'a t + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) + + val find: key -> 'a t -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + + val map: ('a -> 'b) -> 'a t -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + + end +(** Output signature of the functor {!Map.Make}. *) + +module Make (Ord : OrderedType) : S with type key = Ord.t +(** Functor building an implementation of the map structure + given a totally ordered type. *) diff --git a/src/proto/environment/persist.mli b/src/proto/environment/persist.mli new file mode 100644 index 000000000..25657f2c8 --- /dev/null +++ b/src/proto/environment/persist.mli @@ -0,0 +1,192 @@ +(** Tezos - Persistent structures on top of {!Store} or {!Context} *) + +open Lwt + + +(** Keys in (kex x value) database implementations *) +type key = string list + +(** Values in (kex x value) database implementations *) +type value = MBytes.t + +(** Low level view over a (key x value) database implementation. *) +module type STORE = sig + type t + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +(** Projection of OCaml keys of some abstract type to concrete storage + keys. For practical reasons, all such keys must fall under a same + {!prefix} and have the same relative {!length}. Functions + {!to_path} and {!of_path} only take the relative part into account + (the prefix is added and removed when needed). *) +module type KEY = sig + type t + val prefix: key + val length: int + val to_path: t -> key + val of_path: key -> t + val compare: t -> t -> int +end + +(** A KEY instance for using raw implementation paths as keys *) +module RawKey : KEY with type t = key + +(** Projection of OCaml values of some abstract type to concrete + storage data. *) +module type VALUE = sig + type t + val of_bytes: value -> t option + val to_bytes: t -> value +end + +(** A VALUE instance for using the raw bytes values *) +module RawValue : VALUE with type t = value + +module type BYTES_STORE = sig + type t + type key + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t + val list: t -> key list -> key list Lwt.t + val remove_rec: t -> key -> t Lwt.t +end + +module MakeBytesStore (S : STORE) (K : KEY) : + BYTES_STORE with type t = S.t and type key = K.t + +(** {2 Typed Store Overlays} *************************************************) + +(** Signature of a typed store as returned by {!MakecoTypedStore} *) +module type TYPED_STORE = sig + type t + type key + type value + val mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t +end + +(** Gives a typed view of a store (values of a given type stored under + keys of a given type). The view is also restricted to a prefix, + (which can be empty). For all primitives to work as expected, all + keys under this prefix must be homogeneously typed. *) +module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) : + TYPED_STORE with type t = S.t and type key = K.t and type value = C.t + +(** {2 Persistent Sets} ******************************************************) + +(** Signature of a set as returned by {!MakePersistentSet} *) +module type PERSISTENT_SET = sig + type t and key + val mem : t -> key -> bool Lwt.t + val set : t -> key -> t Lwt.t + val del : t -> key -> t Lwt.t + val elements : t -> key list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +(** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *) +module type BUFFERED_PERSISTENT_SET = sig + include PERSISTENT_SET + module Set : Set.S with type elt = key + val read : t -> Set.t Lwt.t + val write : t -> Set.t -> t Lwt.t +end + +(** Build a set in the (key x value) storage by encoding elements as + keys and using the association of (any) data to these keys as + membership. For this to work, the prefix passed must be reserved + for the set (every key under it is considered a member). *) +module MakePersistentSet (S : STORE) (K : KEY) + : PERSISTENT_SET with type t := S.t and type key := K.t + +(** Same as {!MakePersistentSet} but also provides a way to use an + OCaml set as an explicitly synchronized in-memory buffer. *) +module MakeBufferedPersistentSet + (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) + : BUFFERED_PERSISTENT_SET + with type t := S.t + and type key := K.t + and module Set := Set + +(** {2 Persistent Maps} ******************************************************) + +(** Signature of a map as returned by {!MakePersistentMap} *) +module type PERSISTENT_MAP = sig + type t and key and value + val mem : t -> key -> bool Lwt.t + val get : t -> key -> value option Lwt.t + val set : t -> key -> value -> t Lwt.t + val del : t -> key -> t Lwt.t + val bindings : t -> (key * value) list Lwt.t + val clear : t -> t Lwt.t + val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t + val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +(** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *) +module type BUFFERED_PERSISTENT_MAP = sig + include PERSISTENT_MAP + module Map : Map.S with type key = key + val read : t -> value Map.t Lwt.t + val write : t -> value Map.t -> t Lwt.t +end + +(** Build a map in the (key x value) storage. For this to work, the + prefix passed must be reserved for the map (every key under it is + considered the key of a binding). *) +module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := C.t + +(** Same as {!MakePersistentMap} but also provides a way to use an + OCaml map as an explicitly synchronized in-memory buffer. *) +module MakeBufferedPersistentMap + (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := C.t + and module Map := Map + +(** {2 Predefined Instances} *************************************************) + +module MakePersistentBytesMap (S : STORE) (K : KEY) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := MBytes.t + +module MakeBufferedPersistentBytesMap + (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := MBytes.t + and module Map := Map + +module type TYPED_VALUE_REPR = sig + type value + val encoding: value Data_encoding.t +end + +module MakePersistentTypedMap (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) + : PERSISTENT_MAP + with type t := S.t and type key := K.t and type value := T.value + +module MakeBufferedPersistentTypedMap + (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) (Map : Map.S with type key = K.t) + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := T.value + and module Map := Map diff --git a/src/proto/environment/pervasives.mli b/src/proto/environment/pervasives.mli new file mode 100644 index 000000000..d227e8f2b --- /dev/null +++ b/src/proto/environment/pervasives.mli @@ -0,0 +1,560 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* TEZOS CHANGES + + * import version 4.02.1 + * Removed [channel], [exit], ... + * Removed polymorphic comparisons +*) + + +(** The initially opened module. + + This module provides the basic operations over the built-in types + (numbers, booleans, byte sequences, strings, exceptions, references, + lists, arrays, input-output channels, ...). + + This module is automatically opened at the beginning of each compilation. + All components of this module can therefore be referred by their short + name, without prefixing them by [Pervasives]. +*) + + +(** {6 Exceptions} *) + +external raise : exn -> 'a = "%raise" +(** Raise the given exception value *) + +(* external raise_notrace : exn -> 'a = "%raise_notrace" *) +(** A faster version [raise] which does not record the backtrace. + @since 4.02.0 +*) + +val invalid_arg : string -> 'a +(** Raise exception [Invalid_argument] with the given string. *) + +(* val failwith : string -> 'a *) +(** Raise exception [Failure] with the given string. *) + +exception Exit +(** The [Exit] exception is not raised by any library function. It is + provided for use in your programs. *) + + +(** {6 Boolean operations} *) + +external not : bool -> bool = "%boolnot" +(** The boolean negation. *) + +external ( && ) : bool -> bool -> bool = "%sequand" +(** The boolean 'and'. Evaluation is sequential, left-to-right: + in [e1 && e2], [e1] is evaluated first, and if it returns [false], + [e2] is not evaluated at all. *) + +external ( & ) : bool -> bool -> bool = "%sequand" +(** @deprecated {!Pervasives.( && )} should be used instead. *) + +external ( || ) : bool -> bool -> bool = "%sequor" +(** The boolean 'or'. Evaluation is sequential, left-to-right: + in [e1 || e2], [e1] is evaluated first, and if it returns [true], + [e2] is not evaluated at all. *) + +external ( or ) : bool -> bool -> bool = "%sequor" + [@@ocaml.deprecated "Use (||) instead."] +(** @deprecated {!Pervasives.( || )} should be used instead.*) + +(** {6 Debugging} *) + +external __LOC__ : string = "%loc_LOC" +(** [__LOC__] returns the location at which this expression appears in + the file currently being parsed by the compiler, with the standard + error format of OCaml: "File %S, line %d, characters %d-%d" *) +external __FILE__ : string = "%loc_FILE" +(** [__FILE__] returns the name of the file currently being + parsed by the compiler. *) +external __LINE__ : int = "%loc_LINE" +(** [__LINE__] returns the line number at which this expression + appears in the file currently being parsed by the compiler. *) +external __MODULE__ : string = "%loc_MODULE" +(** [__MODULE__] returns the module name of the file being + parsed by the compiler. *) +external __POS__ : string * int * int * int = "%loc_POS" +(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding + to the location at which this expression appears in the file + currently being parsed by the compiler. [file] is the current + filename, [lnum] the line number, [cnum] the character position in + the line and [enum] the last character position in the line. *) + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the + location of [expr] in the file currently being parsed by the + compiler, with the standard error format of OCaml: "File %S, line + %d, characters %d-%d" *) +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +(** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the + line number at which the expression [expr] appears in the file + currently being parsed by the compiler. *) +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" +(** [__POS_OF__ expr] returns a pair [(expr,loc)], where [loc] is a + tuple [(file,lnum,cnum,enum)] corresponding to the location at + which the expression [expr] appears in the file currently being + parsed by the compiler. [file] is the current filename, [lnum] the + line number, [cnum] the character position in the line and [enum] + the last character position in the line. *) + +(** {6 Composition operators} *) + +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" +(** Reverse-application operator: [x |> f |> g] is exactly equivalent + to [g (f (x))]. + @since 4.01 +*) + +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(** Application operator: [g @@ f @@ x] is exactly equivalent to + [g (f (x))]. + @since 4.01 +*) + +(** {6 Integer arithmetic} *) + +(** Integers are 31 bits wide (or 63 bits on 64-bit processors). + All operations are taken modulo 2{^31} (or 2{^63}). + They do not fail on overflow. *) + +external ( ~- ) : int -> int = "%negint" +(** Unary negation. You can also write [- e] instead of [~- e]. *) + +external ( ~+ ) : int -> int = "%identity" +(** Unary addition. You can also write [+ e] instead of [~+ e]. + @since 3.12.0 +*) + +external succ : int -> int = "%succint" +(** [succ x] is [x + 1]. *) + +external pred : int -> int = "%predint" +(** [pred x] is [x - 1]. *) + +external ( + ) : int -> int -> int = "%addint" +(** Integer addition. *) + +external ( - ) : int -> int -> int = "%subint" +(** Integer subtraction. *) + +external ( * ) : int -> int -> int = "%mulint" +(** Integer multiplication. *) + +external ( / ) : int -> int -> int = "%divint" +(** Integer division. + Raise [Division_by_zero] if the second argument is 0. + Integer division rounds the real quotient of its arguments towards zero. + More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer + less than or equal to the real quotient of [x] by [y]. Moreover, + [(- x) / y = x / (- y) = - (x / y)]. *) + +external ( mod ) : int -> int -> int = "%modint" +(** Integer remainder. If [y] is not zero, the result + of [x mod y] satisfies the following properties: + [x = (x / y) * y + x mod y] and + [abs(x mod y) <= abs(y) - 1]. + If [y = 0], [x mod y] raises [Division_by_zero]. + Note that [x mod y] is negative only if [x < 0]. + Raise [Division_by_zero] if [y] is zero. *) + +val abs : int -> int +(** Return the absolute value of the argument. Note that this may be + negative if the argument is [min_int]. *) + +val max_int : int +(** The greatest representable integer. *) + +val min_int : int +(** The smallest representable integer. *) + + +(** {7 Bitwise operations} *) + +external ( land ) : int -> int -> int = "%andint" +(** Bitwise logical and. *) + +external ( lor ) : int -> int -> int = "%orint" +(** Bitwise logical or. *) + +external ( lxor ) : int -> int -> int = "%xorint" +(** Bitwise logical exclusive or. *) + +val lnot : int -> int +(** Bitwise logical negation. *) + +external ( lsl ) : int -> int -> int = "%lslint" +(** [n lsl m] shifts [n] to the left by [m] bits. + The result is unspecified if [m < 0] or [m >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) + +external ( lsr ) : int -> int -> int = "%lsrint" +(** [n lsr m] shifts [n] to the right by [m] bits. + This is a logical shift: zeroes are inserted regardless of + the sign of [n]. + The result is unspecified if [m < 0] or [m >= bitsize]. *) + +external ( asr ) : int -> int -> int = "%asrint" +(** [n asr m] shifts [n] to the right by [m] bits. + This is an arithmetic shift: the sign bit of [n] is replicated. + The result is unspecified if [m < 0] or [m >= bitsize]. *) + + +(** {6 Floating-point arithmetic} + + OCaml's floating-point numbers follow the + IEEE 754 standard, using double precision (64 bits) numbers. + Floating-point operations never raise an exception on overflow, + underflow, division by zero, etc. Instead, special IEEE numbers + are returned as appropriate, such as [infinity] for [1.0 /. 0.0], + [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') + for [0.0 /. 0.0]. These special numbers then propagate through + floating-point computations as expected: for instance, + [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] + as argument returns [nan] as result. +*) + +external ( ~-. ) : float -> float = "%negfloat" +(** Unary negation. You can also write [-. e] instead of [~-. e]. *) + +external ( ~+. ) : float -> float = "%identity" +(** Unary addition. You can also write [+. e] instead of [~+. e]. + @since 3.12.0 +*) + +external ( +. ) : float -> float -> float = "%addfloat" +(** Floating-point addition *) + +external ( -. ) : float -> float -> float = "%subfloat" +(** Floating-point subtraction *) + +external ( *. ) : float -> float -> float = "%mulfloat" +(** Floating-point multiplication *) + +external ( /. ) : float -> float -> float = "%divfloat" +(** Floating-point division. *) + +external ceil : float -> float = "caml_ceil_float" "ceil" + [@@unboxed] [@@noalloc] +(** Round above to an integer value. + [ceil f] returns the least integer value greater than or equal to [f]. + The result is returned as a float. *) + +external floor : float -> float = "caml_floor_float" "floor" + [@@unboxed] [@@noalloc] +(** Round below to an integer value. + [floor f] returns the greatest integer value less than or + equal to [f]. + The result is returned as a float. *) + +external abs_float : float -> float = "%absfloat" +(** [abs_float f] returns the absolute value of [f]. *) + +external copysign : float -> float -> float + = "caml_copysign_float" "caml_copysign" + [@@unboxed] [@@noalloc] +(** [copysign x y] returns a float whose absolute value is that of [x] + and whose sign is that of [y]. If [x] is [nan], returns [nan]. + If [y] is [nan], returns either [x] or [-. x], but it is not + specified which. + @since 4.00.0 *) + +external mod_float : float -> float -> float = "caml_fmod_float" "fmod" + [@@unboxed] [@@noalloc] +(** [mod_float a b] returns the remainder of [a] with respect to + [b]. The returned value is [a -. n *. b], where [n] + is the quotient [a /. b] rounded towards zero to an integer. *) + +external frexp : float -> float * int = "caml_frexp_float" +(** [frexp f] returns the pair of the significant + and the exponent of [f]. When [f] is zero, the + significant [x] and the exponent [n] of [f] are equal to + zero. When [f] is non-zero, they are defined by + [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) + + +external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) = + "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc] +(** [ldexp x n] returns [x *. 2 ** n]. *) + +external modf : float -> float * float = "caml_modf_float" +(** [modf f] returns the pair of the fractional and integral + part of [f]. *) + +external float : int -> float = "%floatofint" +(** Same as {!Pervasives.float_of_int}. *) + +external float_of_int : int -> float = "%floatofint" +(** Convert an integer to floating-point. *) + +external truncate : float -> int = "%intoffloat" +(** Same as {!Pervasives.int_of_float}. *) + +external int_of_float : float -> int = "%intoffloat" +(** Truncate the given floating-point number to an integer. + The result is unspecified if the argument is [nan] or falls outside the + range of representable integers. *) + +val infinity : float +(** Positive infinity. *) + +val neg_infinity : float +(** Negative infinity. *) + +val nan : float +(** A special floating-point value denoting the result of an + undefined operation such as [0.0 /. 0.0]. Stands for + 'not a number'. Any floating-point operation with [nan] as + argument returns [nan] as result. As for floating-point comparisons, + [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] + if one or both of their arguments is [nan]. *) + +val max_float : float +(** The largest positive finite value of type [float]. *) + +val min_float : float +(** The smallest positive, non-zero, non-denormalized value of type [float]. *) + +val epsilon_float : float +(** The difference between [1.0] and the smallest exactly representable + floating-point number greater than [1.0]. *) + +type fpclass = + FP_normal (** Normal number, none of the below *) + | FP_subnormal (** Number very close to 0.0, has reduced precision *) + | FP_zero (** Number is 0.0 or -0.0 *) + | FP_infinite (** Number is positive or negative infinity *) + | FP_nan (** Not a number: result of an undefined operation *) +(** The five classes of floating-point numbers, as determined by + the {!Pervasives.classify_float} function. *) + +external classify_float : (float [@unboxed]) -> fpclass = + "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc] +(** Return the class of the given floating-point number: + normal, subnormal, zero, infinite, or not a number. *) + + +(** {6 String operations} + + More string operations are provided in module {!String}. +*) + +val ( ^ ) : string -> string -> string +(** String concatenation. *) + + +(** {6 Character operations} + + More character operations are provided in module {!Char}. +*) + +external int_of_char : char -> int = "%identity" +(** Return the ASCII code of the argument. *) + +val char_of_int : int -> char +(** Return the character with the given ASCII code. + Raise [Invalid_argument "char_of_int"] if the argument is + outside the range 0--255. *) + + +(** {6 Unit operations} *) + +external ignore : 'a -> unit = "%ignore" +(** Discard the value of its argument and return [()]. + For instance, [ignore(f x)] discards the result of + the side-effecting function [f]. It is equivalent to + [f x; ()], except that the latter may generate a + compiler warning; writing [ignore(f x)] instead + avoids the warning. *) + + +(** {6 String conversion functions} *) + +val string_of_bool : bool -> string +(** Return the string representation of a boolean. As the returned values + may be shared, the user should not modify them directly. +*) + +val bool_of_string : string -> bool +(** Convert the given string to a boolean. + Raise [Invalid_argument "bool_of_string"] if the string is not + ["true"] or ["false"]. *) + +val string_of_int : int -> string +(** Return the string representation of an integer, in decimal. *) + +external int_of_string : string -> int = "caml_int_of_string" +(** Convert the given string to an integer. + The string is read in decimal (by default), in hexadecimal (if it + begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), + or in binary (if it begins with [0b] or [0B]). + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int]. *) + +val string_of_float : float -> string +(** Return the string representation of a floating-point number. *) + +external float_of_string : string -> float = "caml_float_of_string" +(** Convert the given string to a float. The string is read in decimal + (by default) or in hexadecimal (marked by [0x] or [0X]). + The format of decimal floating-point numbers is + [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. + The format of hexadecimal floating-point numbers is + [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an + hexadecimal digit and [d] for a decimal digit. + In both cases, at least one of the integer and fractional parts must be + given; the exponent part is optional. + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Depending on the execution platforms, other representations of + floating-point numbers can be accepted, but should not be relied upon. + Raise [Failure "float_of_string"] if the given string is not a valid + representation of a float. *) + +(** {6 Pair operations} *) + +external fst : 'a * 'b -> 'a = "%field0" +(** Return the first component of a pair. *) + +external snd : 'a * 'b -> 'b = "%field1" +(** Return the second component of a pair. *) + + +(** {6 List operations} + + More list operations are provided in module {!List}. +*) + +val ( @ ) : 'a list -> 'a list -> 'a list +(** List concatenation. Not tail-recursive (length of the first argument). *) + + +(** {6 References} *) + +type 'a ref = { mutable contents : 'a } +(** The type of references (mutable indirection cells) containing + a value of type ['a]. *) + +external ref : 'a -> 'a ref = "%makemutable" +(** Return a fresh reference containing the given value. *) + +external ( ! ) : 'a ref -> 'a = "%field0" +(** [!r] returns the current contents of reference [r]. + Equivalent to [fun r -> r.contents]. *) + +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +(** [r := a] stores the value of [a] in reference [r]. + Equivalent to [fun r v -> r.contents <- v]. *) + +external incr : int ref -> unit = "%incr" +(** Increment the integer contained in the given reference. + Equivalent to [fun r -> r := succ !r]. *) + +external decr : int ref -> unit = "%decr" +(** Decrement the integer contained in the given reference. + Equivalent to [fun r -> r := pred !r]. *) + +(** {6 Result type} *) + +type ('a,'b) result = Ok of 'a | Error of 'b + +(** {6 Operations on format strings} *) + +(** Format strings are character strings with special lexical conventions + that defines the functionality of formatted input/output functions. Format + strings are used to read data with formatted input functions from module + {!Scanf} and to print data with formatted output functions from modules + {!Printf} and {!Format}. + + Format strings are made of three kinds of entities: + - {e conversions specifications}, introduced by the special character ['%'] + followed by one or more characters specifying what kind of argument to + read or print, + - {e formatting indications}, introduced by the special character ['@'] + followed by one or more characters specifying how to read or print the + argument, + - {e plain characters} that are regular characters with usual lexical + conventions. Plain characters specify string literals to be read in the + input or printed in the output. + + There is an additional lexical rule to escape the special characters ['%'] + and ['@'] in format strings: if a special character follows a ['%'] + character, it is treated as a plain character. In other words, ["%%"] is + considered as a plain ['%'] and ["%@"] as a plain ['@']. + + For more information about conversion specifications and formatting + indications available, read the documentation of modules {!Scanf}, + {!Printf} and {!Format}. +*) + +(** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. + The two simplified types, [format] and [format4] below are + included for backward compatibility with earlier releases of + OCaml. + + The meaning of format string type parameters is as follows: + + - ['a] is the type of the parameters of the format for formatted output + functions ([printf]-style functions); + ['a] is the type of the values read by the format for formatted input + functions ([scanf]-style functions). + + - ['b] is the type of input source for formatted input functions and the + type of output target for formatted output functions. + For [printf]-style functions from module [Printf], ['b] is typically + [out_channel]; + for [printf]-style functions from module [Format], ['b] is typically + [Format.formatter]; + for [scanf]-style functions from module [Scanf], ['b] is typically + [Scanf.Scanning.in_channel]. + + Type argument ['b] is also the type of the first argument given to + user's defined printing functions for [%a] and [%t] conversions, + and user's defined reading functions for [%r] conversion. + + - ['c] is the type of the result of the [%a] and [%t] printing + functions, and also the type of the argument transmitted to the + first argument of [kprintf]-style functions or to the + [kscanf]-style functions. + + - ['d] is the type of parameters for the [scanf]-style functions. + + - ['e] is the type of the receiver function for the [scanf]-style functions. + + - ['f] is the final result type of a formatted input/output function + invocation: for the [printf]-style functions, it is typically [unit]; + for the [scanf]-style functions, it is typically the result type of the + receiver function. +*) + +type ('a, 'b, 'c, 'd, 'e, 'f) format6 = + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + + + diff --git a/src/proto/environment/set.mli b/src/proto/environment/set.mli new file mode 100644 index 000000000..5d968e0cf --- /dev/null +++ b/src/proto/environment/set.mli @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Sets over ordered types. + + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. + + The [Make] functor constructs implementations for any type, given a + [compare] function. + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end + + module PairsSet = Set.Make(IntPairs) + + let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) + ]} + + This creates a new module [PairsSet], with a new type [PairsSet.t] + of sets of [int * int]. +*) + +module type OrderedType = + sig + type t + (** The type of the set elements. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that + [f e1 e2] is zero if the elements [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Set.Make}. *) + +module type S = + sig + type elt + (** The type of the set elements. *) + + type t + (** The type of sets. *) + + val empty: t + (** The empty set. *) + + val is_empty: t -> bool + (** Test whether a set is empty or not. *) + + val mem: elt -> t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + val add: elt -> t -> t + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) + + val singleton: elt -> t + (** [singleton x] returns the one-element set containing only [x]. *) + + val remove: elt -> t -> t + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) + + val union: t -> t -> t + (** Set union. *) + + val inter: t -> t -> t + (** Set intersection. *) + + val diff: t -> t -> t + (** Set difference. *) + + val compare: t -> t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + val equal: t -> t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + val subset: t -> t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + val iter: (elt -> unit) -> t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) + + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + + val for_all: (elt -> bool) -> t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + val exists: (elt -> bool) -> t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + val filter: (elt -> bool) -> t -> t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. If [p] satisfies every element in [s], + [s] is returned unchanged (the result of the function is then + physically equal to [s]). + @before 4.03 Physical equality was not ensured.*) + + val partition: (elt -> bool) -> t -> t * t + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + val cardinal: t -> int + (** Return the number of elements of a set. *) + + val elements: t -> elt list + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) + + val min_elt: t -> elt + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + + val max_elt: t -> elt + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + + val choose: t -> elt + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + + val split: elt -> t -> t * bool * t + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) + + val find: elt -> t -> elt + (** [find x s] returns the element of [s] equal to [x] (according + to [Ord.compare]), or raise [Not_found] if no such element + exists. + @since 4.01.0 *) + + val of_list: elt list -> t + (** [of_list l] creates a set from a list of elements. + This is usually more efficient than folding [add] over the list, + except perhaps for lists with many duplicated elements. + @since 4.02.0 *) + end +(** Output signature of the functor {!Set.Make}. *) + +module Make (Ord : OrderedType) : S with type elt = Ord.t +(** Functor building an implementation of the set structure + given a totally ordered type. *) diff --git a/src/proto/environment/string.mli b/src/proto/environment/string.mli new file mode 100644 index 000000000..6b9c7f577 --- /dev/null +++ b/src/proto/environment/string.mli @@ -0,0 +1,240 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** String operations. + + A string is an immutable data structure that contains a + fixed-length sequence of (single-byte) characters. Each character + can be accessed in constant time through its index. + + Given a string [s] of length [l], we can access each of the [l] + characters of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + characters or at the beginning or end of the string. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the character at index [n] is between + positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + + OCaml strings used to be modifiable in place, for instance via the + {!String.set} and {!String.blit} functions described below. This + usage is deprecated and only possible when the compiler is put in + "unsafe-string" mode by giving the [-unsafe-string] command-line + option (which is currently the default for reasons of backward + compatibility). This is done by making the types [string] and + [bytes] (see module {!Bytes}) interchangeable so that functions + expecting byte sequences can also accept strings as arguments and + modify them. + + All new code should avoid this feature and be compiled with the + [-safe-string] command-line option to enforce the separation between + the types [string] and [bytes]. + + *) + +external length : string -> int = "%string_length" +(** Return the length (number of characters) of the given string. *) + +external get : string -> int -> char = "%string_safe_get" +(** [String.get s n] returns the character at index [n] in string [s]. + You can also write [s.[n]] instead of [String.get s n]. + + Raise [Invalid_argument] if [n] not a valid index in [s]. *) + + +external set : bytes -> int -> char -> unit = "%string_safe_set" + [@@ocaml.deprecated "Use Bytes.set instead."] +(** [String.set s n c] modifies byte sequence [s] in place, + replacing the byte at index [n] with [c]. + You can also write [s.[n] <- c] instead of [String.set s n c]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. + + @deprecated This is a deprecated alias of {!Bytes.set}.[ ] *) + +external create : int -> bytes = "caml_create_string" + [@@ocaml.deprecated "Use Bytes.create instead."] +(** [String.create n] returns a fresh byte sequence of length [n]. + The sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @deprecated This is a deprecated alias of {!Bytes.create}.[ ] *) + +val make : int -> char -> string +(** [String.make n c] returns a fresh string of length [n], + filled with the character [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> string +(** [String.init n f] returns a string of length [n], with character + [i] initialized to the result of [f i] (called in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @since 4.02.0 +*) + +val copy : string -> string [@@ocaml.deprecated] +(** Return a copy of the given string. + + @deprecated Because strings are immutable, it doesn't make much + sense to make identical copies of them. *) + +val sub : string -> int -> int -> string +(** [String.sub s start len] returns a fresh string of length [len], + containing the substring of [s] that starts at position [start] and + has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) + +val fill : bytes -> int -> int -> char -> unit + [@@ocaml.deprecated "Use Bytes.fill instead."] +(** [String.fill s start len c] modifies byte sequence [s] in place, + replacing [len] bytes with [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid range of [s]. + + @deprecated This is a deprecated alias of {!Bytes.fill}.[ ] *) + +val blit : string -> int -> bytes -> int -> int -> unit +(** Same as {!Bytes.blit_string}. *) + +val concat : string -> string list -> string +(** [String.concat sep sl] concatenates the list of strings [sl], + inserting the separator string [sep] between each. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val iter : (char -> unit) -> string -> unit +(** [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) + +val iteri : (int -> char -> unit) -> string -> unit +(** Same as {!String.iter}, but the + function is applied to the index of the element as first argument + (counting from 0), and the character itself as second argument. + @since 4.00.0 *) + +val map : (char -> char) -> string -> string +(** [String.map f s] applies function [f] in turn to all the + characters of [s] (in increasing index order) and stores the + results in a new string that is returned. + @since 4.00.0 *) + +val mapi : (int -> char -> char) -> string -> string +(** [String.mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the results in a new + string that is returned. + @since 4.02.0 *) + +val trim : string -> string +(** Return a copy of the argument, without leading and trailing + whitespace. The characters regarded as whitespace are: [' '], + ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor + trailing whitespace character in the argument, return the original + string itself, not a copy. + @since 4.00.0 *) + +val escaped : string -> string +(** Return a copy of the argument, with special characters + represented by escape sequences, following the lexical + conventions of OCaml. If there is no special + character in the argument, return the original string itself, + not a copy. Its inverse function is Scanf.unescaped. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val index : string -> char -> int +(** [String.index s c] returns the index of the first + occurrence of character [c] in string [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : string -> char -> int +(** [String.rindex s c] returns the index of the last + occurrence of character [c] in string [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : string -> int -> char -> int +(** [String.index_from s i c] returns the index of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + +val rindex_from : string -> int -> char -> int +(** [String.rindex_from s i c] returns the index of the + last occurrence of character [c] in string [s] before position [i+1]. + [String.rindex s c] is equivalent to + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + +val contains : string -> char -> bool +(** [String.contains s c] tests if character [c] + appears in the string [s]. *) + +val contains_from : string -> int -> char -> bool +(** [String.contains_from s start c] tests if character [c] + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : string -> int -> char -> bool +(** [String.rcontains_from s stop c] tests if character [c] + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase : string -> string +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val lowercase : string -> string +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val capitalize : string -> string +(** Return a copy of the argument, with the first character set to uppercase. *) + +val uncapitalize : string -> string +(** Return a copy of the argument, with the first character set to lowercase. *) + +type t = string +(** An alias for the type of strings. *) + +val compare: t -> t -> int +(** The comparison function for strings, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [String] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) diff --git a/src/proto/environment/time.mli b/src/proto/environment/time.mli new file mode 100644 index 000000000..4ab75ec98 --- /dev/null +++ b/src/proto/environment/time.mli @@ -0,0 +1,32 @@ + +type t + +val add : t -> int64 -> t +val diff : t -> t -> int64 + +val equal : t -> t -> bool +val compare : t -> t -> int + +val (=) : t -> t -> bool +val (<>) : t -> t -> bool +val (<) : t -> t -> bool +val (<=) : t -> t -> bool +val (>=) : t -> t -> bool +val (>) : t -> t -> bool +val min : t -> t -> t +val max : t -> t -> t + +val of_seconds : int64 -> t +val to_seconds : t -> int64 + +val of_notation : string -> t option +val of_notation_exn : string -> t +val to_notation : t -> string + +val encoding : t Data_encoding.t +val rfc_encoding : t Data_encoding.t + +val pp_hum : Format.formatter -> t -> unit + + + diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli new file mode 100644 index 000000000..42c435d16 --- /dev/null +++ b/src/proto/environment/updater.mli @@ -0,0 +1,146 @@ +(** Tezos Protocol Environment - Protocol Implementation Updater *) + +open Hash + +type net_id +val net_id_encoding: net_id Data_encoding.t + +type shell_operation = { + net_id: net_id ; +} +val shell_operation_encoding: shell_operation Data_encoding.t + +type raw_operation = { + shell: shell_operation ; + proto: MBytes.t ; +} + + +(** The version agnostic toplevel structure of blocks. *) +type shell_block_header = { + net_id: net_id ; + (** The genesis of the chain this block belongs to. *) + predecessor: Block_hash.t ; + (** The preceding block in the chain. *) + timestamp: Time.t ; + (** The date at which this block has been forged. *) + fitness: MBytes.t list ; + (** The announced score of the block. As a sequence of sequences + of unsigned bytes. Ordered by length and then by contents + lexicographically. *) + operations: Operation_hash.t list ; + (** The sequence of operations. *) +} +val shell_block_header_encoding: shell_block_header Data_encoding.t + +type raw_block_header = { + shell: shell_block_header ; + proto: MBytes.t ; +} + +(** Result of the {!PROTOCOL.preapply} function of the protocol for + discriminating cacheable operations from droppable ones. *) +type 'error preapply_result = + { applied: Operation_hash.t list; + (** Operations that where successfully applied. *) + refused: 'error list Operation_hash_map.t; + (** Operations which triggered a context independent, unavoidable + error (e.g. invalid signature). *) + branch_refused: 'error list Operation_hash_map.t; + (** Operations which triggered an error that might not arise in a + different context (e.g. past account counter, insufficent + balance). *) + branch_delayed: 'error list Operation_hash_map.t; + (** Operations which triggered an error that might not arise in a + future update of this context (e.g. futur account counter). *) } + +(** This is the signature of a Tezos protocol implementation. It has + access to the Environment module. *) +module type PROTOCOL = sig + + type error = .. + type 'a tzresult = ('a, error list) result + + (** The version specific type of operations. *) + type operation + + (** The maximum size of operations in bytes *) + val max_operation_data_length : int + + (** The version specific part of blocks. *) + type block_header + + (** The maximum size of block headers in bytes *) + val max_block_header_length : int + + (** The maximum *) + val max_number_of_operations : int + + (** The parsing / preliminary validation function for blocks. Its + role is to check that the raw header is well formed, and to + produce a pre-decomposed value of the high level, protocol defined + {!block_header} type. It does not have access to the storage + context. It may store the hash and raw bytes for later signature + verification by {!apply} or {!preapply}. *) + val parse_block_header : raw_block_header -> block_header tzresult + + (** The parsing / preliminary validation function for + operations. Similar to {!parse_block_header}. *) + val parse_operation : + Operation_hash.t -> raw_operation -> operation tzresult + + (** The main protocol function that validates blocks. It receives the + block header and the list of associated operations, as + pre-decomposed by {!parse_block_header} and {!parse_operation}. *) + val apply : + Context.t -> block_header -> operation list -> Context.t tzresult Lwt.t + + (** The auxiliary protocol entry point that validates pending + operations out of blocks. This function tries to apply the all + operations in the given order, and returns which applications have + suceeded and which ones have failed. The first three parameters + are a context in which to apply the operations, the hash of the + preceding block and the date at which the operations are + executed. This function is used by the shell for accepting or + dropping operations, as well as the mining client to check that a + sequence of operations forms a valid block. *) + val preapply : + Context.t -> Block_hash.t -> Time.t -> bool -> operation list -> + (Context.t * error preapply_result) tzresult Lwt.t + + (** The context rating function to determine the winning block chain. *) + val fitness : + Context.t -> Fitness.fitness Lwt.t + + (** The list of remote procedures exported by this implementation *) + val rpc_services : Context.t RPC.directory + + val configure_sandbox : + Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t + +end + +(** An OCaml source component of a protocol implementation. *) +type component = { + (** The OCaml module name. *) + name : string ; + (** The OCaml interface source code *) + interface : string option ; + (** The OCaml source code *) + implementation : string ; +} + +(** Takes a version hash, a list of OCaml components in compilation + order. The last element must be named [protocol] and respect the + [protocol.mli] interface. Tries to compile it and returns true + if the operation was successful. *) +val compile : Protocol_hash.t -> component list -> bool Lwt.t + +(** Activates a given protocol version from a given context. This + means that the context used for the next block will use this + version (this is not an immediate change). The version must have + been previously compiled successfully. *) +val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t + +val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t +val fork_test_network: Context.t -> Context.t Lwt.t diff --git a/src/proto/environment/uri.mli b/src/proto/environment/uri.mli new file mode 100644 index 000000000..63c57c4e0 --- /dev/null +++ b/src/proto/environment/uri.mli @@ -0,0 +1 @@ +type t diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam new file mode 100644 index 000000000..b91a76ef4 --- /dev/null +++ b/src/tezos-deps.opam @@ -0,0 +1,31 @@ +opam-version: "1.2" +name: "tezos-deps" +version: "dev" +maintainer: "Grégoire Henry " +authors: [ + "Arthur Breitman " + "Benjamin Canou " + "Pierre Chambart " + "Grégoire Henry " +] +dev-repo: "https://gitlab.ocamlpro.com/tezos/tezos.git" +homepage: "https://gitlab.ocamlpro.com/tezos/tezos" +bug-reports: "https://gitlab.ocamlpro.com/tezos/tezos/issues" +depends: [ + "ocamlfind" {build} + "base-bigarray" + "base-threads" + "calendar" + "cohttp" {>= "0.21" } + "config-file" + "cryptokit" + "git" + "git-unix" + "irmin" {>= "0.11"} + "menhir" + "ocp-ocamlres" {>= "dev"} + "ocplib-endian" + "ocplib-json-typed" + "ocplib-resto" {>= "dev"} + "sodium" {>= "0.3.0"} +] diff --git a/src/utils/IO.ml b/src/utils/IO.ml new file mode 100644 index 000000000..b11c5bd5a --- /dev/null +++ b/src/utils/IO.ml @@ -0,0 +1,156 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* + * Copyright (c) 2013-2014 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let (>>=) = Lwt.(>>=) +let (>|=) = Lwt.(>|=) +let (//) = Filename.concat + +exception Error of string + +let error = + Printf.ksprintf + (fun str -> + Printf.eprintf "fatal: %s\n%!" str; + Lwt.fail (Error str)) + +let mkdir dir = + let safe_mkdir dir = + if not (Sys.file_exists dir) then + try Unix.mkdir dir 0o755 + with Unix.Unix_error(Unix.EEXIST,_,_) -> () in + let rec aux dir = + if not (Sys.file_exists dir) then begin + aux (Filename.dirname dir); + safe_mkdir dir; + end in + aux dir + +let check_dir root = + if Sys.file_exists root && not (Sys.is_directory root) then + error "%s is not a directory!" root + else begin + let mkdir dir = + if not (Sys.file_exists dir) then mkdir dir in + mkdir root; + Lwt.return_unit + end + +let files = Lwt_pool.create 50 (fun () -> Lwt.return_unit) + +let with_file fn = + Lwt_pool.use files fn + +let read_bigstring fd = + Lwt_bytes.map_file ~fd ~shared:false () + +let with_file_in file fn = + with_file + (fun () -> + let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in + try + let b = read_bigstring fd in + fn b >>= fun r -> + Unix.close fd; + Lwt.return r + with e -> + Unix.close fd; + Lwt.fail e) + +let write_bigstring fd ba = + let rec rwrite fd buf ofs len = + Lwt_bytes.write fd buf ofs len >>= fun n -> + if n = 0 && len <> 0 then Lwt.fail End_of_file + else if n < len then rwrite fd buf (ofs + n) (len - n) + else Lwt.return_unit in + rwrite fd ba 0 (Bigarray.Array1.dim ba) + +let with_file_out file ba = + mkdir (Filename.dirname file); + with_file + (fun () -> + Lwt_unix.(openfile file [O_RDWR; O_NONBLOCK; O_CREAT] 0o644) >>= fun fd -> + try + write_bigstring fd ba >>= fun r -> + Lwt_unix.close fd >>= fun () -> + Lwt.return r + with e -> + Lwt_unix.close fd >>= fun () -> + Lwt.fail e) + +let remove_file file = + if Sys.file_exists file then Unix.unlink file; + Lwt.return_unit + +let is_directory f = + try Sys.is_directory f with _ -> false + +let list_files root = + let files = Lwt_unix.files_of_directory root in + Lwt_stream.fold_s + (fun file accu -> + if file = "." || file = ".." then + Lwt.return accu + else + Lwt.return (file :: accu)) + files [] >>= fun l -> + Lwt.return (List.sort compare l) + +let rec_files root = + let rec aux accu dir = + let files = Lwt_unix.files_of_directory (root // dir) in + Lwt_stream.fold_s + (fun file accu -> + if file = "." || file = ".." then + Lwt.return accu + else + let file = if dir = "" then file else dir // file in + if is_directory (root // file) then + aux accu file + else + Lwt.return (file :: accu)) + files accu in + aux [] "" + +let remove_rec root = + let rec aux dir = + let files = Lwt_unix.files_of_directory (root // dir) in + Lwt_stream.iter_s + (fun file -> + if file = "." || file = ".." then + Lwt.return_unit + else + let file = if dir = "" then file else dir // file in + if is_directory (root // file) then begin + aux file >>= fun () -> + Lwt.return_unit + end else begin + Unix.unlink (root // file) ; + Lwt.return_unit + end) + files >>= fun () -> + Unix.rmdir (root // dir) ; + Lwt.return_unit + in + if Sys.file_exists root then aux "" else Lwt.return_unit diff --git a/src/utils/IO.mli b/src/utils/IO.mli new file mode 100644 index 000000000..4d8e308d5 --- /dev/null +++ b/src/utils/IO.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* + * Copyright (c) 2013-2014 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Utils + +val check_dir: string -> unit Lwt.t +val with_file_in: string -> (MBytes.t -> 'a Lwt.t) -> 'a Lwt.t +val list_files: string -> string list Lwt.t +val rec_files: string -> string list Lwt.t +val with_file_out: string -> MBytes.t -> unit Lwt.t +val remove_file: string -> unit Lwt.t +val remove_rec: string -> unit Lwt.t diff --git a/src/utils/base48.ml b/src/utils/base48.ml new file mode 100644 index 000000000..6c9d9471e --- /dev/null +++ b/src/utils/base48.ml @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let decode_alphabet alphabet = + let str = Bytes.make 256 '\255' in + for i = 0 to String.length alphabet - 1 do + Bytes.set str (int_of_char alphabet.[i]) (char_of_int i) ; + done ; + Bytes.to_string str + +let default_alphabet = + "eXMNE9qvHPQDdcFx5J86rT7VRm2atAypGhgLfbS3CKjnksB4" + +let default_decode_alphabet = decode_alphabet default_alphabet + +let count_trailing_char s c = + let len = String.length s in + let rec loop i = + if i < 0 then len + else if String.get s i <> c then (len-i-1) + else loop (i-1) in + loop (len-1) + +let of_char ?(alphabet=default_decode_alphabet) x = + let pos = String.get alphabet (int_of_char x) in + if pos = '\255' then failwith "Invalid data" ; + int_of_char pos + +let to_char ?(alphabet=default_alphabet) x = + alphabet.[x] + +let forty_eight = Z.of_int 48 + +let raw_encode ?alphabet s = + let zero, alphabet = + match alphabet with + | None -> default_alphabet.[0], default_alphabet + | Some alphabet -> + if String.length alphabet <> 48 then invalid_arg "Base48.encode" ; + alphabet.[0], decode_alphabet alphabet in + let zeros = count_trailing_char s '\000' in + let len = String.length s in + let res_len = (len * 8 + 4) / 5 in + let res = Bytes.make res_len '\000' in + let s = Z.of_bits s in + let rec loop s i = + if s = Z.zero then i else + let s, r = Z.div_rem s forty_eight in + Bytes.set res i (to_char ~alphabet (Z.to_int r)); + loop s (i+1) in + let i = loop s 0 in + let res = Bytes.sub_string res 0 i in + res ^ String.make zeros zero + +let raw_decode ?alphabet s = + let zero, alphabet = + match alphabet with + | None -> default_alphabet.[0], default_decode_alphabet + | Some alphabet -> + if String.length alphabet <> 48 then invalid_arg "Base48.decode" ; + alphabet.[0], decode_alphabet alphabet in + let zeros = count_trailing_char s zero in + let len = String.length s in + let rec loop res i = + if i < 0 then res else + let x = Z.of_int (of_char ~alphabet (String.get s i)) in + let res = Z.(add x (mul res forty_eight)) in + loop res (i-1) + in + let res = Z.to_bits @@ loop Z.zero (len - zeros - 1) in + let res_tzeros = count_trailing_char res '\000' in + String.sub res 0 (String.length res - res_tzeros) ^ + String.make zeros '\000' + +let sha256 s = + let hash = Cryptokit.Hash.sha256 () in + hash#add_string s; + let computed_hash = hash#result in hash#wipe; + computed_hash + +let safe_encode ?alphabet s = + raw_encode ?alphabet (String.sub (sha256 (sha256 s)) 0 4 ^ s) + +let safe_decode ?alphabet s = + let s = raw_decode ?alphabet s in + let len = String.length s in + let msg_hash = String.sub s 0 4 in + let msg = String.sub s 4 (len-4) in + if msg_hash <> String.sub (sha256 (sha256 msg)) 0 4 then + invalid_arg "safe_decode" ; + msg + +type data = .. + +type kinds = + Kind : { prefix: string; + read: data -> string option ; + build: string -> data } -> kinds + +let kinds = ref ([] : kinds list) + +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if n >= x && String.sub s 0 x = prefix then + Some (String.sub s x (n - x)) + else + None + +exception Unknown_prefix + +let decode ?alphabet s = + let rec find s = function + | [] -> raise Unknown_prefix + | Kind { prefix ; build } :: kinds -> + match remove_prefix ~prefix s with + | None -> find s kinds + | Some msg -> build msg in + let s = safe_decode ?alphabet s in + find s !kinds + +exception Unregistred_kind + +let encode ?alphabet s = + let rec find s = function + | [] -> raise Unregistred_kind + | Kind { prefix ; read } :: kinds -> + match read s with + | None -> find s kinds + | Some msg -> safe_encode ?alphabet (prefix ^ msg) in + try find s !kinds + with Not_found -> raise Unknown_prefix + +let register ~prefix ~read ~build = + match List.find (fun (Kind {prefix=s}) -> remove_prefix s prefix <> None || remove_prefix prefix s <> None) !kinds with + | exception Not_found -> + kinds := Kind { prefix ; read ; build } :: !kinds + | Kind { prefix = s } -> + Format.kasprintf + Pervasives.failwith + "Base49.register: Conflicting prefixes: %S and %S." prefix s ; + +module Prefix = struct + let block_hash = "\000" + let operation_hash = "\001" + let protocol_hash = "\002" + let public_key_hash = "\003" + let public_key = "\004" + let secret_key = "\005" + let signature = "\006" + let protocol_prefix = "\255" +end diff --git a/src/utils/base48.mli b/src/utils/base48.mli new file mode 100644 index 000000000..613516aa6 --- /dev/null +++ b/src/utils/base48.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val safe_encode: ?alphabet:string -> string -> string +val safe_decode: ?alphabet:string -> string -> string + +type data = .. + +val decode: ?alphabet:string -> string -> data +val encode: ?alphabet:string -> data -> string + +val register: + prefix:string -> + read:(data -> string option) -> + build:(string -> data) -> + unit + +module Prefix : sig + val block_hash: string + val operation_hash: string + val protocol_hash: string + val public_key_hash: string + val public_key: string + val secret_key: string + val signature: string + val protocol_prefix: string +end diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml new file mode 100644 index 000000000..3e262b0a6 --- /dev/null +++ b/src/utils/cli_entries.ml @@ -0,0 +1,314 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Command Line Parsing *) + +open Lwt + +(* User catchable exceptions *) +exception Command_not_found +exception Bad_argument of int * string * string +exception Command_failed of string + +(* A simple structure for command interpreters. *) +type 'a params = + | Prefix : string * 'a params -> 'a params + | Param : string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params + | Stop : (unit -> unit Lwt.t) params + | More : (string list -> unit Lwt.t) params + | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params + +(* A command wraps a callback with its type and info *) +and command = + | Command + : 'a params * 'a * + desc option * tag list * group option * + (Arg.key * Arg.spec * Arg.doc) list + -> command + +and desc = string +and group = string +and tag = string + +(* Associates group names with group titles *) +let groups : (group * string) list ref = ref [] +let register_group group title = + try ignore @@ List.assoc group !groups with + | Not_found -> groups := (group, title) :: !groups +let group_title group = + try List.assoc group !groups with + | Not_found -> group + +(* Associates tag names with tag descriptions *) +let tags : (tag * string) list ref = ref [] +let register_tag tag title = + try ignore @@ List.assoc tag !tags with + | Not_found -> tags := (tag, title) :: !tags +let tag_description tag = + try List.assoc tag !tags with + | Not_found -> "undocumented tag" + +(* Some combinators for writing commands concisely. *) +let param ~name ~desc kind next = Param (name, desc, kind, next) +let seq ~name ~desc kind = Seq (name, desc, kind) +let seq_of_param param = + match param Stop with + | Param (n, desc, f, Stop) -> Seq (n, desc, f) + | _ -> invalid_arg "Cli_entries.seq_of_param" + +let prefix keyword next = Prefix (keyword, next) +let rec fixed = + function [] -> Stop | n :: r -> Prefix (n, fixed r) +let rec prefixes p next = + match p with [] -> next | n :: r -> Prefix (n, prefixes r next) +let stop = Stop +let more = More +let void = Stop +let any = More +let command ?desc ?(tags = []) ?group ?(args = []) params cb = + Command (params, cb, desc,tags, group, args) + +(* Param combinators *) +let string n desc next = param n desc (fun s -> return s) next + +(* Error combinators for use in commands *) +let kasprintf cont fmt = + let buffer = Buffer.create 100 in + let ppf = Format.formatter_of_buffer buffer in + Format.kfprintf (fun ppf -> + Format.fprintf ppf "%!"; + cont (Buffer.contents buffer)) + ppf fmt +let error fmt = kasprintf (fun msg -> Lwt.fail (Command_failed msg)) fmt +let message fmt = kasprintf (Format.eprintf "%s\n%!") fmt +let answer fmt = kasprintf (Format.printf "%s\n%!") fmt +let param_error fmt = kasprintf (fun msg -> Lwt.fail (Failure msg)) fmt + +(* Command execution *) +let exec (Command (params, cb, _, _, _, _)) args = + let rec exec + : type a. int -> a params -> a -> string list -> unit Lwt.t = fun i params cb args -> + match params, args with + | Stop, [] -> cb () + | Stop, _ -> Lwt.fail Command_not_found + | Seq (_, _, f), seq -> + let rec do_seq i acc = function + | [] -> Lwt.return (List.rev acc) + | p :: rest -> + catch + (fun () -> f p) + (function + | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) + | exn -> Lwt.fail exn) >>= fun v -> + do_seq (succ i) (v :: acc) rest in + do_seq i [] seq >>= fun parsed -> + cb parsed + | More, rest -> cb rest + | Prefix (n, next), p :: rest when n = p -> + exec (succ i) next cb rest + | Param (_, _, f, next), p :: rest -> + catch + (fun () -> f p) + (function + | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) + | exn -> Lwt.fail exn) >>= fun v -> + exec (succ i) next (cb v) rest + | _ -> Lwt.fail Command_not_found + in exec 1 params cb args + +module Command_tree = struct + type level = + { stop : command option ; + prefix : (string * tree) list } + and param_level = + { stop : command option ; + tree : tree } + and tree = + | TPrefix of level + | TParam of param_level + | TStop of command + | TMore of command + | TEmpty + let insert root (Command (params, _, _, _, _, _) as command) = + let rec insert_tree + : type a. tree -> a params -> tree + = fun t c -> match t, c with + | TEmpty, Stop -> TStop command + | TEmpty, More -> TMore command + | TEmpty, Seq _ -> TMore command + | TEmpty, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = None } + | TEmpty, Prefix (n, next) -> + TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } + | TStop command, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = Some command } + | TStop command, Prefix (n, next) -> + TPrefix { stop = Some command ; + prefix = [ (n, insert_tree TEmpty next) ] } + | TParam t, Param (_, _, _, next) -> + TParam { t with tree = insert_tree t.tree next } + | TPrefix ({ prefix } as l), Prefix (n, next) -> + let rec insert_prefix = function + | [] -> [ (n, insert_tree TEmpty next) ] + | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest + | item :: rest -> item :: insert_prefix rest in + TPrefix { l with prefix = insert_prefix prefix } + | TPrefix ({ stop = None } as l), Stop -> + TPrefix { l with stop = Some command } + | TParam ({ stop = None } as l), Stop -> + TParam { l with stop = Some command } + | _, _ -> + Pervasives.failwith + "Cli_entries.Command_tree.insert: conflicting commands" in + insert_tree root params + let make commands = + List.fold_left insert TEmpty commands + let dispatcher tree args = + let rec loop = function + | TStop c, [] -> exec c args + | TPrefix { stop = Some c }, [] -> exec c args + | TMore c, _ -> exec c args + | TPrefix { prefix }, n :: rest -> + begin try + let t = List.assoc n prefix in + loop (t, rest) + with Not_found -> Lwt.fail Command_not_found end + | TParam { tree }, _ :: rest -> + loop (tree, rest) + | _, _ -> Lwt.fail Command_not_found + in + loop (tree, args) + let inline_dispatcher tree () = + let state = ref (tree, []) in + fun arg -> match !state, arg with + | (( TStop c | + TMore c | + TPrefix { stop = Some c } | + TParam { stop = Some c}), acc), + `End -> + state := (TEmpty, []) ; + `Res (exec c (List.rev acc)) + | (TMore c, acc), `Arg n -> + state := (TMore c, n :: acc) ; + `Nop + | (TPrefix { prefix }, acc), `Arg n -> + begin try + let t = List.assoc n prefix in + state := (t, n :: acc) ; + begin match t with + | TStop (Command (_, _, _, _, _, args)) + | TMore (Command (_, _, _, _, _, args)) -> `Args args + | _ -> `Nop end + with Not_found -> `Fail Command_not_found end + | (TParam { tree }, acc), `Arg n -> + state := (tree, n :: acc) ; + begin match tree with + | TStop (Command (_, _, _, _, _, args)) + | TMore (Command (_, _, _, _, _, args)) -> `Args args + | _ -> `Nop end + | _, _ -> `Fail Command_not_found +end + +(* Try a list of commands on a list of arguments *) +let dispatcher commands = + let tree = Command_tree.make commands in + fun args -> Command_tree.dispatcher tree args + +(* Argument-by-argument dispatcher to be used during argument parsing *) +let inline_dispatcher commands = + let tree = Command_tree.make commands in + Command_tree.inline_dispatcher tree + +(* Command line help for a set of commands *) +let usage commands options = + let trim s = (* config-file wokaround *) + Utils.split '\n' s |> + List.map String.trim |> + String.concat "\n" in + let rec help : type a. Format.formatter -> a params -> unit = fun ppf -> function + | Stop -> () + | More -> Format.fprintf ppf "..." + | Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n + | Seq (_, desc, _) -> Format.fprintf ppf "[ (%s) ... ]" desc + | Prefix (n, Stop) -> Format.fprintf ppf "%s" n + | Param (n, "", _, Stop) -> Format.fprintf ppf "(%s)" n + | Param (_, desc, _, Stop) -> Format.fprintf ppf "(%s)" desc + | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next + | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next + | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in + let rec help_sum : type a. Format.formatter -> a params -> unit = fun ppf -> function + | Stop -> () + | More -> Format.fprintf ppf "..." + | Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n + | Prefix (n, Stop) -> Format.fprintf ppf "%s" n + | Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n + | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next + | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in + let rec help_args : type a. Format.formatter -> a params -> unit = fun ppf -> function + | Stop -> () + | More -> Format.fprintf ppf "..." + | Seq (n, desc, _) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) + | Prefix (_, next) -> help_args ppf next + | Param (n, desc, _, Stop) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) + | Param (n, desc, _, next) -> Format.fprintf ppf "(%s): @[%a@]@,%a" n Format.pp_print_text (trim desc) help_args next in + let option_help ppf (n, opt, desc) = + Format.fprintf ppf "%s%s" n + Arg.(let rec example opt = match opt with + | Unit _ -> "" + | Bool _ -> " " + | Set _ -> "" + | Clear _ -> "" + | String _ -> " " + | Set_string _ -> " " + | Int _ -> " " + | Set_int _ -> " " + | Float _ -> " " + | Set_float _ -> " " + | Tuple opts -> List.map example opts |> String.concat "" + | Symbol (syms, _) -> " <" ^ String.concat " | " syms ^ ">" + | Rest _ -> "" in example opt) ; + if desc <> "" then + Format.fprintf ppf "@, @[%a@]" Format.pp_print_text (trim desc) in + let command_help ppf (Command (p, _, desc, _, _, options)) = + let small = Format.asprintf "@[%a@]" help p in + if String.length small < 50 then begin + Format.fprintf ppf "@[%s@,@[%a@]" + small + Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + end else begin + Format.fprintf ppf "@[%a@,@[%a@]@,%a" + help_sum p + Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + help_args p ; + end ; + if options = [] then + Format.fprintf ppf "@]" + else + Format.fprintf ppf "@,%a@]" (Format.pp_print_list option_help) options in + let rec group_help ppf (n, commands) = + Format.fprintf ppf "@[%s:@,%a@]" + (match n with None -> "Miscellaneous commands" | Some n -> group_title n) + (Format.pp_print_list command_help) !commands in + let usage ppf (by_group, options) = + Format.fprintf ppf + "@[@[Usage:@,%s [ options ] command [ command options ]@]@,@[Options:@,%a@]@,%a@]" + Sys.argv.(0) + (Format.pp_print_list option_help) options + (Format.pp_print_list group_help) by_group in + let by_group = + List.fold_left + (fun acc (Command (_, _, _, _, g, _) as c) -> + try + let r = List.assoc g acc in + r := c :: !r ; + acc + with Not_found -> + (g, ref [ c ]) :: acc) + [] commands |> List.sort compare in + Format.asprintf "%a" usage (by_group, options) diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli new file mode 100644 index 000000000..7d6e63bde --- /dev/null +++ b/src/utils/cli_entries.mli @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos: a small Command Line Parsing library *) +(* Only used in the client. *) + +exception Command_not_found +exception Bad_argument of int * string * string +exception Command_failed of string + +type 'a params = + | Prefix: string * 'a params -> 'a params + | Param: string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params + | Stop: (unit -> unit Lwt.t) params + | More: (string list -> unit Lwt.t) params + | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params + +and command = + | Command + : 'a params * 'a * + desc option * tag list * group option * + (Arg.key * Arg.spec * Arg.doc) list + -> command + +and desc = string +and group = string +and tag = string + +val error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a +val param_error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a +val message: ('a, Format.formatter, unit, unit) format4 -> 'a +val answer: ('a, Format.formatter, unit, unit) format4 -> 'a + +val param: + name: string -> + desc: string -> + (string -> 'a Lwt.t) -> 'b params -> ('a -> 'b) params +val prefix: string -> 'a params -> 'a params +val prefixes: string list -> 'a params -> 'a params +val string: string -> string -> 'a params -> (string -> 'a) params +val fixed: string list -> (unit -> unit Lwt.t) params +val stop: (unit -> unit Lwt.t) params +val seq: + name: string -> + desc: string -> + (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params + +(* [seq_of_param (param ~name ~desc f) = seq ~name ~desc f] *) +val seq_of_param: + ((unit -> unit Lwt.t) params -> ('a -> unit -> unit Lwt.t) params) -> + ('a list -> unit Lwt.t) params + +val command: + ?desc:desc -> + ?tags:tag list -> + ?group:group -> + ?args:(Arg.key * Arg.spec * Arg.doc) list -> + 'a params -> 'a -> command + +val register_group: group -> group -> unit +val register_tag: tag -> string -> unit + +val usage: + command list -> (string * Arg.spec * string) list -> string +val inline_dispatcher: + command list -> + unit -> + [> `Arg of string | `End ] -> + [> `Args of (Arg.key * Arg.spec * Arg.doc) list + | `Fail of exn + | `Nop + | `Res of unit Lwt.t ] diff --git a/src/utils/compare.ml b/src/utils/compare.ml new file mode 100644 index 000000000..f528f22d5 --- /dev/null +++ b/src/utils/compare.ml @@ -0,0 +1,150 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type S = sig + type t + val (=) : t -> t -> bool + val (<>) : t -> t -> bool + val (<) : t -> t -> bool + val (<=) : t -> t -> bool + val (>=) : t -> t -> bool + val (>) : t -> t -> bool + val compare : t -> t -> int + val max : t -> t -> t + val min : t -> t -> t +end + +module Char = struct + type t = char + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Bool = struct + type t = bool + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Int = struct + type t = int + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Int32 = struct + type t = int32 + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Int64 = struct + type t = int64 + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Float = struct + type t = float + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module String = struct + type t = string + let (=) = ((=) : t -> t -> bool) + let (<>) = ((<>) : t -> t -> bool) + let (<) = ((<) : t -> t -> bool) + let (<=) = ((<=) : t -> t -> bool) + let (>=) = ((>=) : t -> t -> bool) + let (>) = ((>) : t -> t -> bool) + let compare = compare + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module List(P : S) = struct + type t = P.t list + let rec compare xs ys = + match xs, ys with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | x :: xs, y :: ys -> + let hd = P.compare x y in + if hd <> 0 then hd else compare xs ys + let (=) xs ys = compare xs ys = 0 + let (<>) xs ys = compare xs ys <> 0 + let (<) xs ys = compare xs ys < 0 + let (<=) xs ys = compare xs ys <= 0 + let (>=) xs ys = compare xs ys >= 0 + let (>) xs ys = compare xs ys > 0 + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end + +module Option(P : S) = struct + type t = P.t option + let rec compare xs ys = + match xs, ys with + | None, None -> 0 + | None, _ -> -1 + | _, None -> 1 + | Some x, Some y -> P.compare x y + let (=) xs ys = compare xs ys = 0 + let (<>) xs ys = compare xs ys <> 0 + let (<) xs ys = compare xs ys < 0 + let (<=) xs ys = compare xs ys <= 0 + let (>=) xs ys = compare xs ys >= 0 + let (>) xs ys = compare xs ys > 0 + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y +end diff --git a/src/utils/compare.mli b/src/utils/compare.mli new file mode 100644 index 000000000..887131002 --- /dev/null +++ b/src/utils/compare.mli @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type S = sig + type t + val (=) : t -> t -> bool + val (<>) : t -> t -> bool + val (<) : t -> t -> bool + val (<=) : t -> t -> bool + val (>=) : t -> t -> bool + val (>) : t -> t -> bool + val compare : t -> t -> int + val max : t -> t -> t + val min : t -> t -> t +end + +module Char : S with type t = char +module Bool : S with type t = bool +module Int : S with type t = int +module Int32 : S with type t = int32 +module Int64 : S with type t = int64 +module Float : S with type t = float +module String : S with type t = string +module List(P : S) : S with type t = P.t list +module Option(P : S) : S with type t = P.t option diff --git a/src/utils/data_encoding.ml b/src/utils/data_encoding.ml new file mode 100644 index 000000000..9e601a3fc --- /dev/null +++ b/src/utils/data_encoding.ml @@ -0,0 +1,1171 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Utils + +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +and document = + [ `O of (string * json) list + | `A of json list ] + +type json_schema = Json_schema.schema + +exception No_case_matched +exception Unexpected_tag of int +exception Duplicated_tag of int +exception Invalid_tag of int * [ `Int8 | `Int16 ] +exception Unexpected_enum of string * string list + +let apply fs v = + let rec loop = function + | [] -> raise No_case_matched + | f :: fs -> + match f v with + | Some l -> l + | None -> loop fs in + loop fs + +module Size = struct + let bool = 1 + let int8 = 1 + let int16 = 2 + let int31 = 4 + let int32 = 4 + let int64 = 8 + let float = 8 +end + +type tag_size = [ `Int8 | `Int16 ] + +let tag_size = function + | `Int8 -> Size.int8 + | `Int16 -> Size.int16 + +module Kind = struct + + type t = + [ `Fixed of int + | `Dynamic + | `Variable ] + + type length = + [ `Fixed of int + | `Variable ] + + type enum = + [ `Dynamic + | `Variable ] + + let combine name : t -> t -> t = fun k1 k2 -> + match k1, k2 with + | `Fixed n1, `Fixed n2 -> `Fixed (n1 + n2) + | `Dynamic, `Dynamic | `Fixed _, `Dynamic + | `Dynamic, `Fixed _ -> `Dynamic + | `Variable, (`Dynamic | `Fixed _) + | (`Dynamic | `Fixed _), `Variable -> `Variable + | `Variable, `Variable -> + Printf.ksprintf invalid_arg + "Cannot merge two %s with variable length. \ + You should wrap one of them with Data_encoding.dynamic_size." + name + + let merge : t -> t -> t = fun k1 k2 -> + match k1, k2 with + | `Fixed n1, `Fixed n2 when n1 = n2 -> `Fixed n1 + | `Fixed _, `Fixed _ -> `Dynamic + | `Dynamic, `Dynamic | `Fixed _, `Dynamic + | `Dynamic, `Fixed _ -> `Dynamic + | `Variable, (`Dynamic | `Fixed _) + | (`Dynamic | `Fixed _), `Variable + | `Variable, `Variable -> `Variable + + let merge_list sz : t list -> t = function + | [] -> assert false (* should be rejected by Data_encoding.union *) + | k :: ks -> + match List.fold_left merge k ks with + | `Fixed n -> `Fixed (n + tag_size sz) + | k -> k + +end + +type 'a desc = + | Null : unit desc + | Empty : unit desc + | Ignore : unit desc + | Constant : string -> unit desc + | Bool : bool desc + | Int8 : int desc + | Int16 : int desc + | Int31 : int desc + | Int32 : Int32.t desc + | Int64 : Int64.t desc + | Float : float desc + | Bytes : Kind.length -> MBytes.t desc + | String : Kind.length -> string desc + | String_enum : Kind.length * (string * 'a) list -> 'a desc + | Array : 'a t -> 'a array desc + | List : 'a t -> 'a list desc + | Obj : 'a field -> 'a desc + | Objs : Kind.t * 'a t * 'b t -> ('a * 'b) desc + | Tup : 'a t -> 'a desc + | Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc + | Union : Kind.t * tag_size * 'a case list -> 'a desc + | Mu : Kind.enum * string * ('a t -> 'a t) -> 'a desc + | Conv : + { proj : ('a -> 'b) ; + inj : ('b -> 'a) ; + encoding : 'b t ; + schema : Json_schema.schema option } -> 'a desc + | Describe : + { title : string option ; + description : string option ; + encoding : 'a t } -> 'a desc + | Def : { name : string ; + encoding : 'a t } -> 'a desc + | Splitted : + { encoding : 'a t ; + json_encoding : 'a Json_encoding.encoding } -> 'a desc + | Dynamic_size : 'a t -> 'a desc + +and _ field = + | Req : string * 'a t -> 'a field + | Opt : Kind.enum * string * 'a t -> 'a option field + | Dft : string * 'a t * 'a -> 'a field + +and 'a case = + | Case : { encoding : 'a t ; + proj : ('t -> 'a option) ; + inj : ('a -> 't) ; + tag : int option } -> 't case + +and 'a t = { + encoding: 'a desc ; + mutable json_encoding: 'a Json_encoding.encoding option ; +} + +type 'a encoding = 'a t + +let rec classify : type a l. a t -> Kind.t = fun e -> + let open Kind in + match e.encoding with + (* Fixed *) + | Null -> `Fixed 0 + | Empty -> `Fixed 0 + | Constant _ -> `Fixed 0 + | Bool -> `Fixed Size.bool + | Int8 -> `Fixed Size.int8 + | Int16 -> `Fixed Size.int16 + | Int31 -> `Fixed Size.int31 + | Int32 -> `Fixed Size.int32 + | Int64 -> `Fixed Size.int64 + | Float -> `Fixed Size.float + (* Tagged *) + | Bytes kind -> (kind :> Kind.t) + | String kind -> (kind :> Kind.t) + | String_enum (kind, _) -> (kind :> Kind.t) + | Obj (Opt (kind, _, _)) -> (kind :> Kind.t) + | Objs (kind, _, _) -> kind + | Tups (kind, _, _) -> kind + | Union (kind, _, _) -> (kind :> Kind.t) + | Mu (kind, _, _) -> (kind :> Kind.t) + (* Variable *) + | Ignore -> `Variable + | Array _ -> `Variable + | List _ -> `Variable + (* Recursive *) + | Obj (Req (_, encoding)) -> classify encoding + | Obj (Dft (_, encoding, _)) -> classify encoding + | Tup encoding -> classify encoding + | Conv { encoding } -> classify encoding + | Describe { encoding } -> classify encoding + | Def { encoding } -> classify encoding + | Splitted { encoding } -> classify encoding + | Dynamic_size _ -> `Dynamic + +let make ?json_encoding encoding = { encoding ; json_encoding } + +module Json = struct + + type pair_builder = { + build: 'a 'b. Kind.t -> 'a t -> 'b t -> ('a * 'b) t + } + + exception Parse_error of string + + type nonrec json = json + + let to_root = function + | `O ctns -> `O ctns + | `A ctns -> `A ctns + | `Null -> `O [] + | oth -> `A [ oth ] + + let to_string j = Ezjsonm.to_string ~minify:false (to_root j) + + let from_string s = + try Ok (Ezjsonm.from_string s :> json) + with Ezjsonm.Parse_error (_, msg) -> Error msg + + let from_stream (stream: string Lwt_stream.t) = + let buffer = ref "" in + Lwt_stream.filter_map + (fun str -> + buffer := !buffer ^ str ; + try + let json = Ezjsonm.from_string !buffer in + buffer := "" ; + Some (Ok json) + with Ezjsonm.Parse_error (_, msg) -> + if String.length str = 32 * 1024 then None + else Some (Error msg)) + stream + + let write_file file json = + let json = to_root json in + let open Lwt in + catch + (fun () -> + Lwt_io.(with_file ~mode:Output file (fun chan -> + let str = to_string json in + write chan str >>= fun _ -> + return true))) + (fun _ -> return false) + + let read_file file = + let open Lwt in + catch + (fun () -> + Lwt_io.(with_file ~mode:Input file (fun chan -> + read chan >>= fun str -> + return (Some (Ezjsonm.from_string str :> json))))) + (fun _ -> + (* TODO log error or use Error_monad. *) + return None) + + let wrap_error f = + fun str -> + try f str + with exn -> raise (Json_encoding.Cannot_destruct ([], exn)) + + let int64_encoding = + let open Json_encoding in + union [ + case + int32 + (fun i -> + let j = Int64.to_int32 i in + if Compare.Int64.(=) (Int64.of_int32 j) i then Some j else None) + Int64.of_int32 ; + case + string + (fun i -> Some (Int64.to_string i)) + Int64.of_string + ] + + let bytes_jsont = + let open Json_encoding in + let schema = + let open Json_schema in + create + { title = None ; + description = None ; + default = None; + enum = None; + kind = String { + pattern = Some "^[a-zA-Z0-9]+$"; + min_length = 0; + max_length = None; + }; + format = None ; + id = None } in + conv ~schema + Hex_encode.hex_of_bytes + (wrap_error Hex_encode.bytes_of_hex) + string + + let rec lift_union : type a. a t -> a t = fun e -> + match e.encoding with + | Conv { proj ; inj ; encoding = e ; schema } -> begin + match lift_union e with + | { encoding = Union (kind, tag, cases) } -> + make @@ + Union (kind, tag, + List.map + (fun (Case { encoding ; proj = proj' ; inj = inj' ; tag }) -> + Case { encoding ; + proj = (fun x -> proj' (proj x)); + inj = (fun x -> inj (inj' x)) ; + tag }) + cases) + | e -> make @@ Conv { proj ; inj ; encoding = e ; schema } + end + | Objs (p, e1, e2) -> + lift_union_in_pair + { build = fun p e1 e2 -> make @@ Objs (p, e1, e2) } + p e1 e2 + | Tups (p, e1, e2) -> + lift_union_in_pair + { build = fun p e1 e2 -> make @@ Tups (p, e1, e2) } + p e1 e2 + | _ -> e + + and lift_union_in_pair + : type a a_l b b_l. pair_builder -> Kind.t -> a t -> b t -> (a * b) t + = fun b p e1 e2 -> + match lift_union e1, lift_union e2 with + | e1, { encoding = Union (_kind, tag, cases) } -> + make @@ + Union (`Dynamic (* ignored *), tag, + List.map + (fun (Case { encoding = e2 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + proj = (fun (x, y) -> + match proj y with + | None -> None + | Some y -> Some (x, y)) ; + inj = (fun (x, y) -> (x, inj y)) ; + tag }) + cases) + | { encoding = Union (_kind, tag, cases) }, e2 -> + make @@ + Union (`Dynamic (* ignored *), tag, + List.map + (fun (Case { encoding = e1 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + proj = (fun (x, y) -> + match proj x with + | None -> None + | Some x -> Some (x, y)) ; + inj = (fun (x, y) -> (inj x, y)) ; + tag }) + cases) + | e1, e2 -> b.build p e1 e2 + + let rec json : type a l. a desc -> a Json_encoding.encoding = + let open Json_encoding in + function + | Null -> null + | Empty -> empty + | Constant s -> string_enum [s, ()] + | Ignore -> unit + | Int8 -> int + | Int16 -> int + | Int31 -> int + | Int32 -> int32 + | Int64 -> int64_encoding + | Bool -> bool + | Float -> float + | String _ -> string (* TODO: check length *) + | Bytes _ -> bytes_jsont (* TODO check length *) + | String_enum (_, l) -> string_enum l + | Array e -> array (get_json e) + | List e -> list (get_json e) + | Obj f -> obj1 (field_json f) + | Objs (_, e1, e2) -> + merge_objs (get_json e1) (get_json e2) + | Tup e -> tup1 (get_json e) + | Tups (_, e1, e2) -> + merge_tups (get_json e1) (get_json e2) + | Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e) + | Describe { title ; description ; encoding = e } -> + describe ?title ?description (get_json e) + | Def { name ; encoding = e } -> def name (get_json e) + | Mu (_, name, self) as ty -> + mu name (fun json_encoding -> get_json @@ self (make ~json_encoding ty)) + | Union (_tag_size, _, cases) -> union (List.map case_json cases) + | Splitted { json_encoding } -> json_encoding + | Dynamic_size e -> get_json e + + and field_json + : type a l. a field -> a Json_encoding.field = + let open Json_encoding in + function + | Req (name, e) -> req name (get_json e) + | Opt (_, name, e) -> opt name (get_json e) + | Dft (name, e, d) -> dft name (get_json e) d + + and case_json : type a l. a case -> a Json_encoding.case = + let open Json_encoding in + function + | Case { encoding = e ; proj ; inj ; _ } -> case (get_json e) proj inj + + and get_json : type a l. a t -> a Json_encoding.encoding = fun e -> + match e.json_encoding with + | None -> + let json_encoding = json (lift_union e).encoding in + e.json_encoding <- Some json_encoding ; + json_encoding + | Some json_encoding -> json_encoding + + let convert = get_json + + type path = path_item list + and path_item = + [ `Field of string + (** A field in an object. *) + | `Index of int + (** An index in an array. *) + | `Star + (** Any / every field or index. *) + | `Next + (** The next element after an array. *) ] + + include Json_encoding + + let construct e v = construct (get_json e) v + let destruct e v = destruct (get_json e) v + let schema e = schema (get_json e) + + let cannot_destruct fmt = + Format.kasprintf + (fun msg -> raise (Cannot_destruct ([], Failure msg))) + fmt + +end + +module Encoding = struct + + module Fixed = struct + let string n = make @@ String (`Fixed n) + let bytes n = make @@ Bytes (`Fixed n) + end + + module Variable = struct + let string = make @@ String `Variable + let bytes = make @@ Bytes `Variable + let check_not_variable name e = + match classify e with + | `Variable -> + Printf.ksprintf invalid_arg + "Cannot insert variable length element in %s. \ + You should wrap the contents using Data_encoding.dynamic_size." name + | `Dynamic | `Fixed _ -> () + let array e = + check_not_variable "an array" e ; + make @@ Array e + let list e = + check_not_variable "a list" e ; + make @@ List e + let string_enum l = make @@ String_enum (`Variable, l) + end + + let dynamic_size e = + make @@ Dynamic_size e + + let null = make @@ Null + let empty = make @@ Empty + let constant s = make @@ Constant s + let bool = make @@ Bool + let int8 = make @@ Int8 + let int16 = make @@ Int16 + let int31 = make @@ Int31 + let int32 = make @@ Int32 + let int64 = make @@ Int64 + let float = make @@ Float + + let string = dynamic_size Variable.string + let bytes = dynamic_size Variable.bytes + let array e = dynamic_size (Variable.array e) + let list e = dynamic_size (Variable.list e) + + let conv (type l) proj inj ?schema encoding = + make @@ Conv { proj ; inj ; encoding ; schema } + + let string_enum l = dynamic_size (Variable.string_enum l) + + let describe ?title ?description encoding = + match title, description with + | None, None -> encoding + | _, _ -> make @@ Describe { title ; description ; encoding } + + let def name encoding = make @@ Def { name ; encoding } + + let req ?title ?description n t = + Req (n, describe ?title ?description t) + let opt ?title ?description n encoding = + let kind = + match classify encoding with + | `Variable -> `Variable + | `Fixed _ | `Dynamic -> `Dynamic in + Opt (kind, n, make @@ Describe { title ; description ; encoding }) + let varopt ?title ?description n encoding = + Opt (`Variable, n, make @@ Describe { title ; description ; encoding }) + let dft ?title ?description n t d = + Dft (n, describe ?title ?description t, d) + + let raw_splitted ~json ~binary = + make @@ Splitted { encoding = binary ; json_encoding = json } + + let splitted ~json ~binary = + let json = Json.convert json in + raw_splitted ~binary ~json + + let raw_json json = + let binary = + conv + (fun v -> Json_encoding.construct json v |> Json.to_string) + (fun s -> + match Json.from_string s with + | Error msg -> raise (Json.Parse_error msg) + | Ok v -> Json_encoding.destruct json v) + string in + raw_splitted ~binary ~json + + let json = raw_json Json_encoding.any_ezjson_value + let json_schema = raw_json Json_encoding.any_schema + + let raw_merge_objs e1 e2 = + let kind = Kind.combine "objects" (classify e1) (classify e2) in + make @@ Objs (kind, e1, e2) + + let obj1 f1 = make @@ Obj f1 + let obj2 f2 f1 = + raw_merge_objs (obj1 f2) (obj1 f1) + let obj3 f3 f2 f1 = + raw_merge_objs (obj1 f3) (obj2 f2 f1) + let obj4 f4 f3 f2 f1 = + raw_merge_objs (obj2 f4 f3) (obj2 f2 f1) + let obj5 f5 f4 f3 f2 f1 = + raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1) + let obj6 f6 f5 f4 f3 f2 f1 = + raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1) + let obj7 f7 f6 f5 f4 f3 f2 f1 = + raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1) + let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = + raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1) + let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1) + let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1) + + let merge_objs o1 o2 = + let rec is_obj : type a l. a t -> bool = fun e -> + match e.encoding with + | Obj _ -> true + | Objs _ (* by construction *) -> true + | Conv { encoding = e } -> is_obj e + | Union (_,_,cases) -> + List.for_all (fun (Case { encoding = e }) -> is_obj e) cases + | Empty -> true + | Ignore -> true + | _ -> false in + if is_obj o1 && is_obj o2 then + raw_merge_objs o1 o2 + else + invalid_arg "Json_encoding.merge_objs" + + let raw_merge_tups e1 e2 = + let kind = Kind.combine "tuples" (classify e1) (classify e2) in + make @@ Tups (kind, e1, e2) + + let tup1 e1 = make @@ Tup e1 + let tup2 e2 e1 = + raw_merge_tups (tup1 e2) (tup1 e1) + let tup3 e3 e2 e1 = + raw_merge_tups (tup1 e3) (tup2 e2 e1) + let tup4 e4 e3 e2 e1 = + raw_merge_tups (tup2 e4 e3) (tup2 e2 e1) + let tup5 e5 e4 e3 e2 e1 = + raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1) + let tup6 e6 e5 e4 e3 e2 e1 = + raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1) + let tup7 e7 e6 e5 e4 e3 e2 e1 = + raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1) + let tup8 e8 e7 e6 e5 e4 e3 e2 e1 = + raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1) + let tup9 e9 e8 e7 e6 e5 e4 e3 e2 e1 = + raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1) + let tup10 e10 e9 e8 e7 e6 e5 e4 e3 e2 e1 = + raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1) + + let merge_tups t1 t2 = + let rec is_tup : type a l. a t -> bool = fun e -> + match e.encoding with + | Tup _ -> true + | Tups _ (* by construction *) -> true + | Conv { encoding = e } -> is_tup e + | Union (_,_,cases) -> + List.for_all (function Case { encoding = e} -> is_tup e) cases + | _ -> false in + if is_tup t1 && is_tup t2 then + raw_merge_tups t1 t2 + else + invalid_arg "Tezos_serial.Encoding.merge_tups" + + let conv3 ty = + conv + (fun (c, b, a) -> (c, (b, a))) + (fun (c, (b, a)) -> (c, b, a)) + ty + let obj3 f3 f2 f1 = conv3 (obj3 f3 f2 f1) + let tup3 f3 f2 f1 = conv3 (tup3 f3 f2 f1) + let conv4 ty = + conv + (fun (d, c, b, a) -> ((d, c), (b, a))) + (fun ((d, c), (b, a)) -> (d, c, b, a)) + ty + let obj4 f4 f3 f2 f1 = conv4 (obj4 f4 f3 f2 f1) + let tup4 f4 f3 f2 f1 = conv4 (tup4 f4 f3 f2 f1) + let conv5 ty = + conv + (fun (e, d, c, b, a) -> (e, ((d, c), (b, a)))) + (fun (e, ((d, c), (b, a))) -> (e, d, c, b, a)) + ty + let obj5 f5 f4 f3 f2 f1 = conv5 (obj5 f5 f4 f3 f2 f1) + let tup5 f5 f4 f3 f2 f1 = conv5 (tup5 f5 f4 f3 f2 f1) + let conv6 ty = + conv + (fun (f, e, d, c, b, a) -> ((f, e), ((d, c), (b, a)))) + (fun ((f, e), ((d, c), (b, a))) -> (f, e, d, c, b, a)) + ty + let obj6 f6 f5 f4 f3 f2 f1 = conv6 (obj6 f6 f5 f4 f3 f2 f1) + let tup6 f6 f5 f4 f3 f2 f1 = conv6 (tup6 f6 f5 f4 f3 f2 f1) + let conv7 ty = + conv + (fun (g, f, e, d, c, b, a) -> ((g, (f, e)), ((d, c), (b, a)))) + (fun ((g, (f, e)), ((d, c), (b, a))) -> (g, f, e, d, c, b, a)) + ty + let obj7 f7 f6 f5 f4 f3 f2 f1 = conv7 (obj7 f7 f6 f5 f4 f3 f2 f1) + let tup7 f7 f6 f5 f4 f3 f2 f1 = conv7 (tup7 f7 f6 f5 f4 f3 f2 f1) + let conv8 ty = + conv (fun (h, g, f, e, d, c, b, a) -> + (((h, g), (f, e)), ((d, c), (b, a)))) + (fun (((h, g), (f, e)), ((d, c), (b, a))) -> + (h, g, f, e, d, c, b, a)) + ty + let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1) + let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1) + let conv9 ty = + conv + (fun (i, h, g, f, e, d, c, b, a) -> + (i, (((h, g), (f, e)), ((d, c), (b, a))))) + (fun (i, (((h, g), (f, e)), ((d, c), (b, a)))) -> + (i, h, g, f, e, d, c, b, a)) + ty + let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1) + let tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1) + let conv10 ty = + conv + (fun (j, i, h, g, f, e, d, c, b, a) -> + ((j, i), (((h, g), (f, e)), ((d, c), (b, a))))) + (fun ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) -> + (j, i, h, g, f, e, d, c, b, a)) + ty + let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1) + let tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 = + conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1) + + let check_cases tag_size cases = + if cases = [] then + invalid_arg "Data_encoding.union: empty list of cases." ; + let max_tag = + match tag_size with + | `Int8 -> 256 + | `Int16 -> 256 * 256 in + ignore @@ + List.fold_left + (fun others (Case { tag }) -> + match tag with + | None -> others + | Some tag -> + if List.mem tag others then raise (Duplicated_tag tag) ; + if tag < 0 || max_tag <= tag then + raise (Invalid_tag (tag, tag_size)) ; + tag :: others + ) + [] cases + + let union ?(tag_size = `Int8) cases = + check_cases tag_size cases ; + let kinds = + List.map (fun (Case { encoding }) -> classify encoding) cases in + let kind = Kind.merge_list tag_size kinds in + make @@ Union (kind, tag_size, cases) + let case ?tag encoding proj inj = Case { encoding ; proj ; inj ; tag } + let option ty = + union + ~tag_size:`Int8 + [ case ~tag:1 ty + (fun x -> x) + (fun x -> Some x) ; + case ~tag:0 empty + (function None -> Some () | Some _ -> None) + (fun () -> None) ; + ] + let mu name self = + let kind = + try + match classify (self (make @@ Mu (`Dynamic, name, self))) with + | `Fixed _ | `Dynamic -> `Dynamic + | `Variable -> raise Exit + with Exit | _ (* TODO variability error *) -> + ignore @@ classify (self (make @@ Mu (`Variable, name, self))) ; + `Variable in + make @@ Mu (kind, name, self) + +end + +include Encoding + +module Binary = struct + + type 'l writer = { + write: 'a. 'a t -> 'a -> MBytes.t -> int -> int ; + } + + type 'l reader = { + read: 'a. 'a t -> MBytes.t -> int -> int -> (int * 'a) ; + } + +let rec length : type x. x t -> x -> int = fun e -> + let open Kind in + match e.encoding with + (* Fixed *) + | Null -> fun _ -> 0 + | Empty -> fun _ -> 0 + | Constant _ -> fun _ -> 0 + | Bool -> fun _ -> Size.bool + | Int8 -> fun _ -> Size.int8 + | Int16 -> fun _ -> Size.int16 + | Int31 -> fun _ -> Size.int31 + | Int32 -> fun _ -> Size.int32 + | Int64 -> fun _ -> Size.int64 + | Float -> fun _ -> Size.float + | Bytes `Fixed n -> fun _ -> n + | String `Fixed n -> fun _ -> n + | String_enum (`Fixed n, _) -> fun _ -> n + | Objs (`Fixed n, _, _) -> fun _ -> n + | Tups (`Fixed n, _, _) -> fun _ -> n + | Union (`Fixed n, _, _) -> fun _ -> n + (* Dynamic *) + | Objs (`Dynamic, e1, e2) -> + let length1 = length e1 in + let length2 = length e2 in + fun (v1, v2) -> length1 v1 + length2 v2 + | Tups (`Dynamic, e1, e2) -> + let length1 = length e1 in + let length2 = length e2 in + fun (v1, v2) -> length1 v1 + length2 v2 + | Union (`Dynamic, sz, cases) -> + let case_length = function + | Case { tag = None } -> None + | Case { encoding = e ; proj ; tag = Some _ } -> + let length v = tag_size sz + length e v in + Some (fun v -> Utils.map_option length (proj v)) in + apply (Utils.filter_map case_length cases) + | Mu (`Dynamic, _name, self) -> + fun v -> length (self e) v + | Obj (Opt (`Dynamic, _, e)) -> + let length = length e in + (function None -> 1 | Some x -> 1 + length x) + (* Variable *) + | Ignore -> fun _ -> 0 + | Bytes `Variable -> MBytes.length + | String `Variable -> String.length + | String_enum (`Variable, l) -> begin + fun v -> + try + let l = List.map (fun (x,y) -> (y,x)) l in + String.length (List.assoc v l) + with Not_found -> raise No_case_matched + end + | Array e -> + let length = length e in + fun v -> + Array.fold_left + (fun acc v -> length v + acc) + 0 v + | List e -> + let length = length e in + fun v -> + List.fold_left + (fun acc v -> length v + acc) + 0 v + | Objs (`Variable, e1, e2) -> + let length1 = length e1 in + let length2 = length e2 in + fun (v1, v2) -> length1 v1 + length2 v2 + | Tups (`Variable, e1, e2) -> + let length1 = length e1 + and length2 = length e2 in + fun (v1, v2) -> length1 v1 + length2 v2 + | Obj (Opt (`Variable, _, e)) -> + let length = length e in + (function None -> 0 | Some x -> length x) + | Union (`Variable, sz, cases) -> + let case_length = function + | Case { tag = None } -> None + | Case { encoding = e ; proj ; tag = Some _ } -> + let length v = tag_size sz + length e v in + Some (fun v -> + match proj v with + | None -> None + | Some v -> Some (length v)) in + apply (Utils.filter_map case_length cases) + | Mu (`Variable, _name, self) -> + fun v -> length (self e) v + (* Recursive*) + | Obj (Req (_, e)) -> length e + | Obj (Dft (_, e, _)) -> length e + | Tup e -> length e + | Conv { encoding = e ; proj } -> + let length = length e in + fun v -> length (proj v) + | Describe { encoding = e } -> length e + | Def { encoding = e } -> length e + | Splitted { encoding = e } -> length e + | Dynamic_size e -> + let length = length e in + fun v -> Size.int32 + length v + + (** Writer *) + + module Writer = struct + + let int8 v buf ofs = + MBytes.set_int8 buf ofs v; + ofs + Size.int8 + + let char v buf ofs = + int8 (Char.code v) buf ofs + + let bool v buf ofs = + int8 (if v then 255 else 0) buf ofs + + let int16 v buf ofs = + MBytes.set_int16 buf ofs v; + ofs + Size.int16 + + let int31 v buf ofs = + MBytes.set_int32 buf ofs (Int32.of_int v); + ofs + Size.int31 + + let int32 v buf ofs = + MBytes.set_int32 buf ofs v; + ofs + Size.int32 + + let int64 v buf ofs = + MBytes.set_int64 buf ofs v; + ofs + Size.int64 + + let float v buf ofs = + MBytes.set_float buf ofs v; + ofs + Size.float + + let fixed_kind_bytes length s buf ofs = + MBytes.blit s 0 buf ofs length; + ofs + length + + let variable_length_bytes s buf ofs = + let length = MBytes.length s in + MBytes.blit s 0 buf ofs length ; + ofs + length + + let fixed_kind_string length s buf ofs = + if String.length s <> length then invalid_arg "fixed_kind_string"; + MBytes.blit_from_string s 0 buf ofs length; + ofs + length + + let variable_length_string s buf ofs = + let length = String.length s in + MBytes.blit_from_string s 0 buf ofs length ; + ofs + length + + let objs w1 w2 (v1,v2) buf ofs = + w1 v1 buf ofs |> w2 v2 buf + + let array w a buf ofs = + Array.fold_left (fun ofs v -> w v buf ofs) ofs a + + let list w l buf ofs = + List.fold_left (fun ofs v -> w v buf ofs) ofs l + + let conv proj w v buf ofs = + w (proj v) buf ofs + + let write_tag = function + | `Int8 -> int8 + | `Int16 -> int16 + + let union w sz cases = + let writes_case = function + | Case { tag = None } -> + (fun _ -> None) + | Case { encoding = e ; proj ; tag = Some tag } -> + let write = w.write e in + let write v buf ofs = + write_tag sz tag buf ofs |> write v buf in + fun v -> + match proj v with + | None -> None + | Some v -> Some (write v) in + apply (List.map writes_case cases) + + end + + let rec write_rec + : type a l. a t -> a -> MBytes.t -> int -> int = fun e -> + let open Kind in + let open Writer in + match e.encoding with + | Null -> (fun () _buf ofs -> ofs) + | Empty -> (fun () _buf ofs -> ofs) + | Constant _ -> (fun () _buf ofs -> ofs) + | Ignore -> (fun () _buf ofs -> ofs) + | Bool -> bool + | Int8 -> int8 + | Int16 -> int16 + | Int31 -> int31 + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | Bytes (`Fixed n) -> fixed_kind_bytes n + | String (`Fixed n) -> fixed_kind_string n + | Bytes `Variable -> variable_length_bytes + | String `Variable -> variable_length_string + | Array t -> array (write_rec t) + | List t -> list (write_rec t) + | String_enum (kind, l) -> begin + fun v -> + try + let l = List.map (fun (x,y) -> (y,x)) l in + write_rec (make @@ String kind) (List.assoc v l) + with Not_found -> raise No_case_matched + end + | Obj (Req (_, e)) -> write_rec e + | Obj (Opt (`Dynamic, _, e)) -> + let write = write_rec e in + (function None -> int8 0 + | Some x -> fun buf ofs -> int8 1 buf ofs |> write x buf) + | Obj (Opt (`Variable, _, e)) -> + let write = write_rec e in + (function None -> fun _buf ofs -> ofs + | Some x -> write x) + | Obj (Dft (_, e, _)) -> write_rec e + | Objs (_, e1, e2) -> + objs (write_rec e1) (write_rec e2) + | Tup e -> write_rec e + | Tups (_, e1, e2) -> + objs (write_rec e1) (write_rec e2) + | Conv { encoding = e; proj } -> conv proj (write_rec e) + | Describe { encoding = e } -> write_rec e + | Def { encoding = e } -> write_rec e + | Splitted { encoding = e } -> write_rec e + | Union (_, sz, cases) -> union { write = write_rec } sz cases + | Mu (_, _, self) -> fun v buf ofs -> write_rec (self e) v buf ofs + | Dynamic_size e -> + let length = length e + and write = write_rec e in + fun v buf ofs -> + int32 (Int32.of_int @@ length v) buf ofs |> write v buf + + let write t v buf ofs = + try Some (write_rec t v buf ofs) + with _ -> None + + let to_bytes t v = + let length = length t v in + let bytes = MBytes.create length in + let ofs = write_rec t v bytes 0 in + assert(ofs = length); + bytes + + (** Reader *) + + module Reader = struct + + let int8 buf ofs _len = + ofs + Size.int8, MBytes.get_int8 buf ofs + + let char buf ofs len = + let ofs, v = int8 buf ofs len in + ofs, Char.chr v + + let bool buf ofs len = + let ofs, v = int8 buf ofs len in + ofs, v <> 0 + + let int16 buf ofs _len = + ofs + Size.int16, MBytes.get_int16 buf ofs + + let int31 buf ofs _len = + ofs + Size.int31, Int32.to_int (MBytes.get_int32 buf ofs) + + let int32 buf ofs _len = + ofs + Size.int32, MBytes.get_int32 buf ofs + + let int64 buf ofs _len = + ofs + Size.int64, MBytes.get_int64 buf ofs + + let float buf ofs _len = + ofs + Size.float, MBytes.get_float buf ofs + + let int_of_int32 i = + let i' = Int32.to_int i in + let i'' = Int32.of_int i' in + if i'' = i then + i' + else + invalid_arg "int_of_int32 overflow" + + let fixed_length_bytes length buf ofs _len = + let s = MBytes.sub buf ofs length in + ofs + length, s + + let fixed_length_string length buf ofs _len = + let s = MBytes.substring buf ofs length in + ofs + length, s + + let seq r1 r2 buf ofs len = + let ofs', v1 = r1 buf ofs len in + let ofs'', v2 = r2 buf ofs' (len - (ofs' - ofs)) in + ofs'', (v1, v2) + + let varseq r e1 e2 buf ofs len = + let k1 = classify e1 + and k2 = classify e2 in + match k1, k2 with + | (`Dynamic | `Fixed _), `Variable -> + let ofs', v1 = r.read e1 buf ofs len in + let ofs'', v2 = r.read e2 buf ofs' (len - (ofs' - ofs)) in + ofs'', (v1, v2) + | `Variable, `Fixed n -> + let ofs', v1 = r.read e1 buf ofs (len - n) in + let ofs'', v2 = r.read e2 buf ofs' n in + ofs'', (v1, v2) + | _ -> assert false (* Should be rejected by Kind.combine *) + + let list read buf ofs len = + let rec loop acc ofs len = + if len <= 0 + then ofs, List.rev acc + else + let ofs', v = read buf ofs len in + loop (v :: acc) ofs' (len - (ofs' - ofs)) + in + loop [] ofs len + + let array read buf ofs len = + let ofs, l = list read buf ofs len in + ofs, Array.of_list l + + let conv inj r buf ofs len = + let ofs, v = r buf ofs len in + ofs, inj v + + let read_tag = function + | `Int8 -> int8 + | `Int16 -> int16 + + let union r sz cases = + let read_cases = + Utils.filter_map + (function + | (Case { tag = None }) -> None + | (Case { encoding = e ; inj ; tag = Some tag }) -> + let read = r.read e in + Some (tag, fun len buf ofs -> + let ofs, v = read len buf ofs in + ofs, inj v)) + cases in + fun buf ofs len -> + let ofs, tag = read_tag sz buf ofs len in + try List.assoc tag read_cases buf ofs (len - tag_size sz) + with Not_found -> raise (Unexpected_tag tag) + + end + + let rec read_rec : type a l. a t-> MBytes.t -> int -> int -> int * a = fun e -> + let open Kind in + let open Reader in + match e.encoding with + | Null -> (fun _buf ofs _len -> ofs, ()) + | Empty -> (fun _buf ofs _len -> ofs, ()) + | Constant _ -> (fun _buf ofs _len -> ofs, ()) + | Ignore -> (fun _buf ofs len -> ofs + len, ()) + | Bool -> bool + | Int8 -> int8 + | Int16 -> int16 + | Int31 -> int31 + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | Bytes (`Fixed n) -> fixed_length_bytes n + | String (`Fixed n) -> fixed_length_string n + | Bytes `Variable -> fun buf ofs len -> fixed_length_bytes len buf ofs len + | String `Variable -> fun buf ofs len -> fixed_length_string len buf ofs len + | String_enum (kind, l) -> begin + fun buf ofs len -> + let ofs, str = read_rec (make @@ (String kind)) buf ofs len in + try ofs, List.assoc str l + with Not_found -> raise (Unexpected_enum (str, List.map fst l)) + end + | Array e -> array (read_rec e) + | List e -> list (read_rec e) + | Obj (Req (_, e)) -> read_rec e + | Obj (Opt (`Dynamic, _, t)) -> + let read = read_rec t in + (fun buf ofs len -> + let ofs, v = int8 buf ofs len in + if v = 0 then ofs, None + else let ofs, v = read buf ofs (len - Size.int8) in ofs, Some v) + | Obj (Opt (`Variable, _, t)) -> + let read = read_rec t in + (fun buf ofs len -> + if len = 0 then ofs, None + else + let ofs', v = read buf ofs len in + assert (ofs' = ofs + len) ; + ofs + len, Some v) + | Obj (Dft (_, e, _)) -> read_rec e + | Objs ((`Fixed _ | `Dynamic), e1, e2) -> + seq (read_rec e1) (read_rec e2) + | Objs (`Variable, e1, e2) -> + varseq { read = fun t -> read_rec t } e1 e2 + | Tup e -> read_rec e + | Tups ((`Fixed _ | `Dynamic), e1, e2) -> + seq (read_rec e1) (read_rec e2) + | Tups (`Variable, e1, e2) -> + varseq { read = fun t -> read_rec t } e1 e2 + | Conv { inj ; encoding = e } -> conv inj (read_rec e) + | Describe { encoding = e } -> read_rec e + | Def { encoding = e } -> read_rec e + | Splitted { encoding = e } -> read_rec e + | Union (_, sz, cases) -> + union { read = fun t -> read_rec t } sz cases + | Mu (_, _, self) -> fun buf ofs len -> read_rec (self e) buf ofs len + | Dynamic_size e -> + let read = read_rec e in + fun buf ofs len -> + let ofs, sz = int32 buf ofs len in + read buf ofs (Int32.to_int sz) + + let read t buf ofs len = + try Some (read_rec t buf ofs len) + with _ -> None + let write = write + let of_bytes ty buf = + let len = MBytes.length buf in + match read ty buf 0 len with + | None -> None + | Some (read_len, r) -> if read_len <> len then None else Some r + let to_bytes = to_bytes + + let length = length +end diff --git a/src/utils/data_encoding.mli b/src/utils/data_encoding.mli new file mode 100644 index 000000000..130ff4066 --- /dev/null +++ b/src/utils/data_encoding.mli @@ -0,0 +1,253 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** In memory JSON data *) +type json = + [ `O of (string * json) list + | `Bool of bool + | `Float of float + | `A of json list + | `Null + | `String of string ] + +type json_schema = Json_schema.schema + +exception No_case_matched +exception Unexpected_tag of int +exception Duplicated_tag of int +exception Invalid_tag of int * [ `Int8 | `Int16 ] +exception Unexpected_enum of string * string list + +type 'a t +type 'a encoding = 'a t + +val classify : 'a encoding -> [ `Fixed of int | `Dynamic | `Variable ] + +val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding + +val null : unit encoding +val empty : unit encoding +val constant : string -> unit encoding +val int8 : int encoding +val int16 : int encoding +val int31 : int encoding +val int32 : int32 encoding +val int64 : int64 encoding +val bool : bool encoding +val string : string encoding +val bytes : MBytes.t encoding +val float : float encoding +val option : 'a encoding -> 'a option encoding +val string_enum : (string * 'a) list -> 'a encoding + +module Fixed : sig + val string : int -> string encoding + val bytes : int -> MBytes.t encoding +end + +module Variable : sig + val string : string encoding + val bytes : MBytes.t encoding + val array : 'a encoding -> 'a array encoding + val list : 'a encoding -> 'a list encoding +end + +val dynamic_size : 'a encoding -> 'a encoding + +val json : json encoding +val json_schema : json_schema encoding + +type 'a field +val req : + ?title:string -> ?description:string -> + string -> 't encoding -> 't field +val opt : + ?title:string -> ?description:string -> + string -> 't encoding -> 't option field +val varopt : + ?title:string -> ?description:string -> + string -> 't encoding -> 't option field +val dft : + ?title:string -> ?description:string -> + string -> 't encoding -> 't -> 't field + +val obj1 : + 'f1 field -> 'f1 encoding +val obj2 : + 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding +val obj3 : + 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding +val obj4 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> + ('f1 * 'f2 * 'f3 * 'f4) encoding +val obj5 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding +val obj6 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding +val obj7 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding +val obj8 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding +val obj9 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding +val obj10 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 'f10 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val tup1 : + 'f1 encoding -> + 'f1 encoding +val tup2 : + 'f1 encoding -> 'f2 encoding -> + ('f1 * 'f2) encoding +val tup3 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> + ('f1 * 'f2 * 'f3) encoding +val tup4 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + ('f1 * 'f2 * 'f3 * 'f4) encoding +val tup5 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding +val tup6 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding +val tup7 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding +val tup8 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding +val tup9 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + 'f9 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding +val tup10 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + 'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + 'f9 encoding -> 'f10 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding +val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding + +val array : 'a encoding -> 'a array encoding +val list : 'a encoding -> 'a list encoding + +type 't case +val case : + ?tag:int -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case +val union : + ?tag_size:[ `Int8 | `Int16 ] -> 't case list -> 't encoding + +val describe : + ?title:string -> ?description:string -> + 't encoding ->'t encoding + +val def : string -> 'a encoding -> 'a encoding + +val conv : + ('a -> 'b) -> ('b -> 'a) -> + ?schema:Json_schema.schema -> + 'b encoding -> 'a encoding + +val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding + +module Json : sig + + (** Read a JSON document from a string. *) + val from_string : string -> (json, string) result + + (** Read a stream of JSON documents from a stream of strings. + A single JSON document may be represented in multiple consecutive + strings. But only the first document of a string is considered. *) + val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t + + (** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) + val to_string : json -> string + + (** Loads a JSON file in memory *) + val read_file : string -> json option Lwt.t + + (** (Over)write a JSON file from in memory data *) + val write_file : string -> json -> bool Lwt.t + + val convert : 'a encoding -> 'a Json_encoding.encoding + + val schema : 'a encoding -> json_schema + val construct : 't encoding -> 't -> json + val destruct : 't encoding -> json -> 't + + (** JSON Error *) + + type path = path_item list + and path_item = + [ `Field of string + (** A field in an object. *) + | `Index of int + (** An index in an array. *) + | `Star + (** Any / every field or index. *) + | `Next + (** The next element after an array. *) ] + + (** Exception raised by destructors, with the location in the original + JSON structure and the specific error. *) + exception Cannot_destruct of (path * exn) + + (** Unexpected kind of data encountered (w/ the expectation). *) + exception Unexpected of string * string + + (** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *) + exception No_case_matched of exn list + + (** Array of unexpected size encountered (w/ the expectation). *) + exception Bad_array_size of int * int + + (** Missing field in an object. *) + exception Missing_field of string + + (** Supernumerary field in an object. *) + exception Unexpected_field of string + + val print_error : + ?print_unknown: (Format.formatter -> exn -> unit) -> + Format.formatter -> exn -> unit + + (** Helpers for writing encoders. *) + val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a + val wrap_error : ('a -> 'b) -> 'a -> 'b + +end + +module Binary : sig + + val length : 'a encoding -> 'a -> int + val read : 'a encoding -> MBytes.t -> int -> int -> (int * 'a) option + val write : 'a encoding -> 'a -> MBytes.t -> int -> int option + val to_bytes : 'a encoding -> 'a -> MBytes.t + val of_bytes : 'a encoding -> MBytes.t -> 'a option + +end diff --git a/src/utils/ed25519.ml b/src/utils/ed25519.ml new file mode 100644 index 000000000..64fda8a56 --- /dev/null +++ b/src/utils/ed25519.ml @@ -0,0 +1,134 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos - Ed25519 cryptography (simple interface to Sodium) *) + +(*-- Signature ---------------------------------------------------------------*) + +type secret_key = Sodium.Sign.secret_key +type public_key = Sodium.Sign.public_key +type signature = MBytes.t + +let sign key msg = + Sodium.Sign.Bigbytes.(of_signature @@ sign_detached key msg) + +let check_signature public_key signature msg = + try Sodium.Sign.Bigbytes.(verify public_key (to_signature signature) msg) ; true + with _ -> false + +let append_signature key msg = + MBytes.concat msg (sign key msg) + +(*-- Hashed public keys for user ID ------------------------------------------*) + +module Public_key_hash = Hash.Make_SHA256(struct + let name = "Ed25519.Public_key_hash" + let title = "An Ed25519 public key ID" + let prefix = Some Base48.Prefix.public_key_hash + end) + +type public_key_hash = Public_key_hash.t + +let hash v = + Public_key_hash.hash_bytes + [ Sodium.Sign.Bigbytes.of_public_key v ] + +let hash_path = Public_key_hash.to_path +let hash_hex = Public_key_hash.to_hex +let equal_hash = Public_key_hash.equal +let compare_hash = Public_key_hash.compare + +let generate_key () = + let secret, pub = Sodium.Sign.random_keypair () in + (hash pub, pub, secret) + +(*-- JSON Serializers --------------------------------------------------------*) + +type Base48.data += + | Public_key of public_key + | Secret_key of secret_key + | Signature of signature + +let () = + Base48.register + ~prefix:Base48.Prefix.public_key + ~read:(function Public_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) | _ -> None) + ~build:(fun x -> Public_key (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x))) + +let () = + Base48.register + ~prefix:Base48.Prefix.secret_key + ~read:(function Secret_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) | _ -> None) + ~build:(fun x -> Secret_key (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x))) + +let () = + Base48.register + ~prefix:Base48.Prefix.signature + ~read:(function Signature x -> Some (MBytes.to_string x) | _ -> None) + ~build:(fun x -> Signature (MBytes.of_string x)) + +let public_key_hash_encoding = + Public_key_hash.encoding + +let public_key_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 public key (Base48Check encoded)" @@ + conv + (fun s -> Base48.encode (Public_key s)) + (fun s -> + match Base48.decode s with + | Public_key x -> x + | _ -> Data_encoding.Json.cannot_destruct + "Ed25519 public key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_public_key + Sodium.Sign.Bigbytes.to_public_key + bytes) + +let secret_key_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 secret key (Base48Check encoded)" @@ + conv + (fun s -> Base48.encode (Secret_key s)) + (fun s -> + match Base48.decode s with + | Secret_key x -> x + | _ -> Data_encoding.Json.cannot_destruct + "Ed25519 secret key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_secret_key + Sodium.Sign.Bigbytes.to_secret_key + bytes) + +let signature_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 signature (Base48Check encoded)" @@ + conv + (fun s -> Base48.encode (Signature s)) + (fun s -> + match Base48.decode s with + | Signature x -> x + | _ -> + Data_encoding.Json.cannot_destruct + "Ed25519 signature: unexpected prefix.") + string) + ~binary: (Fixed.bytes 64) diff --git a/src/utils/ed25519.mli b/src/utils/ed25519.mli new file mode 100644 index 000000000..4e4b7d560 --- /dev/null +++ b/src/utils/ed25519.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Ed25519 cryptography *) + + +(** {2 Signature} ************************************************************) + +(** An Ed25519 public key *) +type public_key = Sodium.Sign.public_key + +(** An Ed25519 secret key *) +type secret_key = Sodium.Sign.secret_key + +(** The result of signing a sequence of bytes with a secret key *) +type signature + +(** Signs a sequence of bytes with a secret key *) +val sign : secret_key -> MBytes.t -> signature + +val append_signature : secret_key -> MBytes.t -> MBytes.t + +(** Checks a signature *) +val check_signature : public_key -> signature -> MBytes.t -> bool + +(** {2 Hashed public keys for user ID} ***************************************) + +module Public_key_hash : Hash.HASH + +(** A Sha256 hash of an Ed25519 public key for use as an ID *) +type public_key_hash = Public_key_hash.t + +(** Hashes an Ed25519 public key *) +val hash : public_key -> public_key_hash + +(** For using IDs as keys in the database *) +val hash_path : public_key_hash -> string list + +(** ID comparison *) +val equal_hash : public_key_hash -> public_key_hash -> bool + +(** ID comparison *) +val compare_hash : public_key_hash -> public_key_hash -> int + +(** {2 Serializers} **********************************************************) + +val public_key_hash_encoding : public_key_hash Data_encoding.t + +val public_key_encoding : public_key Data_encoding.t + +val secret_key_encoding : secret_key Data_encoding.t + +val signature_encoding : signature Data_encoding.t + +(** {2 Key pairs generation} *************************************************) + +val generate_key : unit -> public_key_hash * public_key * secret_key diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml new file mode 100644 index 000000000..ae32a6cc2 --- /dev/null +++ b/src/utils/error_monad.ml @@ -0,0 +1,346 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Protocol Implementation - Error Monad *) + +(*-- Error classification ----------------------------------------------------*) + +type error_category = [ `Branch | `Temporary | `Permanent ] + +type 'err full_error_category = + [ error_category | `Wrapped of 'err -> error_category ] + +let json_pp encoding ppf x = + Format.pp_print_string ppf @@ + Data_encoding.Json.to_string @@ + Data_encoding.Json.(construct encoding x) + +module Make() = struct + + type error = .. + + (* the toplevel store for error kinds *) + type error_kind = + Error_kind : + { id: string ; + from_error: error -> 'err option ; + category: 'err full_error_category ; + encoding_case: error Data_encoding.case ; + pp: Format.formatter -> 'err -> unit ; } -> + error_kind + + type registred_errors = error_kind list + + let error_kinds + : error_kind list ref + = ref [] + + let error_encoding_cache = ref None + + let string_of_category = function + | `Permanent -> "permanent" + | `Temporary -> "temporary" + | `Branch -> "branch" + | `Wrapped _ -> "wrapped" + let raw_register_error_kind + category ~id:name ~title ~description ?pp + encoding from_error to_error = + if List.exists + (fun (Error_kind { id }) -> name = id) + !error_kinds then + invalid_arg + (Printf.sprintf + "register_error_kind: duplicate error name: %s" name) ; + let encoding_case = + let open Data_encoding in + case + (describe ~title ~description @@ + conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) @@ + merge_objs + (obj2 + (req "kind" (constant (string_of_category category))) + (req "id" (constant name))) + encoding) + from_error to_error in + error_encoding_cache := None ; + error_kinds := + Error_kind { id = name ; + category ; + from_error ; + encoding_case ; + pp = Utils.unopt (json_pp encoding) pp } :: !error_kinds + + let register_wrapped_error_kind + category ~id ~title ~description ?pp + encoding from_error to_error = + raw_register_error_kind + (`Wrapped category) + ~id ~title ~description ?pp + encoding from_error to_error + + let register_error_kind + category ~id ~title ~description ?pp + encoding from_error to_error = + raw_register_error_kind + (category :> _ full_error_category) + ~id ~title ~description ?pp + encoding from_error to_error + + let error_encoding () = + match !error_encoding_cache with + | None -> + let cases = + List.map + (fun (Error_kind { encoding_case }) -> encoding_case ) + !error_kinds in + let encoding = Data_encoding.union cases in + error_encoding_cache := Some encoding ; + encoding + | Some encoding -> encoding + + let json_of_error error = + Data_encoding.Json.(construct (error_encoding ())) error + let error_of_json json = + Data_encoding.Json.(destruct (error_encoding ())) json + + let classify_error error = + let rec find e = function + | [] -> `Temporary + (* assert false (\* See "Generic error" *\) *) + | Error_kind { from_error ; category } :: rest -> + match from_error e with + | Some x -> begin + match category with + | `Wrapped f -> f x + | #error_category as x -> x + end + | None -> find e rest in + find error !error_kinds + + let classify_errors errors = + List.fold_left + (fun r e -> match r, classify_error e with + | `Permanent, _ | _, `Permanent -> `Permanent + | `Branch, _ | _, `Branch -> `Branch + | `Temporary, `Temporary -> `Temporary) + `Temporary errors + + let pp ppf error = + let rec find = function + | [] -> assert false (* See "Generic error" *) + | Error_kind { from_error ; pp } :: errors -> + match from_error error with + | None -> find errors + | Some x -> pp ppf x in + find !error_kinds + + let registred_errors () = !error_kinds + + + (*-- Monad definition --------------------------------------------------------*) + + let (>>=) = Lwt.(>>=) + + type 'a tzresult = ('a, error list) result + + let result_encoding t_encoding = + let open Data_encoding in + let errors_encoding = + describe ~title: "An erroneous result" @@ + obj1 (req "error" (list (error_encoding ()))) in + let t_encoding = + describe ~title: "A successful result" @@ + obj1 (req "result" t_encoding) in + union + ~tag_size:`Int8 + [ case ~tag:0 t_encoding + (function Ok x -> Some x | _ -> None) + (function res -> Ok res) ; + case ~tag:1 errors_encoding + (function Error x -> Some x | _ -> None) + (fun errs -> Error errs) ] + + let return v = Lwt.return (Ok v) + + let error s = Error [ s ] + + let ok v = Ok v + + let fail s = Lwt.return (Error [ s ]) + + let (>>?) v f = + match v with + | Error _ as err -> err + | Ok v -> f v + + let (>>=?) v f = + v >>= function + | Error _ as err -> Lwt.return err + | Ok v -> f v + + let (>>|?) v f = v >>=? fun v -> Lwt.return (Ok (f v)) + let (>|=) = Lwt.(>|=) + + let (>|?) v f = v >>? fun v -> Ok (f v) + + let rec map_s f l = + match l with + | [] -> return [] + | h :: t -> + f h >>=? fun rh -> + map_s f t >>=? fun rt -> + return (rh :: rt) + + let rec map_p f l = + match l with + | [] -> + return [] + | x :: l -> + let tx = f x and tl = map_p f l in + tx >>= fun x -> + tl >>= fun l -> + match x, l with + | Ok x, Ok l -> Lwt.return (Ok (x :: l)) + | Error exn1, Error exn2 -> Lwt.return (Error (exn1 @ exn2)) + | Ok _, Error exn + | Error exn, Ok _ -> Lwt.return (Error exn) + + let rec map2_s f l1 l2 = + match l1, l2 with + | [], [] -> return [] + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.map2_s" + | h1 :: t1, h2 :: t2 -> + f h1 h2 >>=? fun rh -> + map2_s f t1 t2 >>=? fun rt -> + return (rh :: rt) + + let rec map2 f l1 l2 = + match l1, l2 with + | [], [] -> Ok [] + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.map2" + | h1 :: t1, h2 :: t2 -> + f h1 h2 >>? fun rh -> + map2 f t1 t2 >>? fun rt -> + Ok (rh :: rt) + + let rec map_filter_s f l = + match l with + | [] -> return [] + | h :: t -> + f h >>=? function + | None -> map_filter_s f t + | Some rh -> + map_filter_s f t >>=? fun rt -> + return (rh :: rt) + + let rec iter_s f l = + match l with + | [] -> return () + | h :: t -> + f h >>=? fun () -> + iter_s f t + + let rec iter_p f l = + match l with + | [] -> return () + | x :: l -> + let tx = f x and tl = iter_p f l in + tx >>= fun tx_res -> + tl >>= fun tl_res -> + match tx_res, tl_res with + | Ok (), Ok () -> Lwt.return (Ok ()) + | Error exn1, Error exn2 -> Lwt.return (Error (exn1 @ exn2)) + | Ok (), Error exn + | Error exn, Ok () -> Lwt.return (Error exn) + + let rec fold_left_s f init l = + match l with + | [] -> return init + | h :: t -> + f init h >>=? fun acc -> + fold_left_s f acc t + + let rec fold_right_s f l init = + match l with + | [] -> return init + | h :: t -> + fold_right_s f t init >>=? fun acc -> + f h acc + + let record_trace err result = + match result with + | Ok _ as res -> res + | Error errs -> Error (err :: errs) + + let trace err f = + f >>= function + | Error errs -> Lwt.return (Error (err :: errs)) + | ok -> Lwt.return ok + + let fail_unless cond exn = + if cond then return () else fail exn + + let pp_print_error ppf errors = + Format.fprintf ppf "@[Error, dumping error stack:@,%a@]@." + (Format.pp_print_list pp) + (List.rev errors) + +type error += Unclassified of string + +let () = + let id = "" in + let category = `Temporary in + let to_error msg = Unclassified msg in + let from_error = function + | Unclassified msg -> Some msg + | error -> + let msg = Obj.(extension_name @@ extension_constructor error) in + Some ("Unclassified error: " ^ msg ^ ".") in + let title = "Generic error" in + let description = "An unclassified error" in + let encoding_case = + let open Data_encoding in + case + (describe ~title ~description @@ + conv (fun x -> ((), x)) (fun ((), x) -> x) @@ + (obj2 + (req "kind" (constant "generic")) + (req "error" string))) + from_error to_error in + let pp = Format.pp_print_string in + error_kinds := + Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds + +end + +include Make() + +let generic_error s = error (Unclassified s) + +let failwith fmt = + Format.kasprintf (fun s -> fail (Unclassified s)) fmt + +type error += Exn of exn +let error s = Error [ s ] +let error_exn s = Error [ Exn s ] +let trace_exn exn f = trace (Exn exn) f +let record_trace_exn exn f = record_trace (Exn exn) f + +let () = + register_error_kind + `Temporary + ~id:"failure" + ~title:"Generic error" + ~description:"Unclassified error" + Data_encoding.(obj1 (req "msg" string)) + (function + | Exn (Failure msg) -> Some msg + | Exn exn -> Some (Printexc.to_string exn) + | _ -> None) + (fun msg -> Exn (Failure msg)) diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli new file mode 100644 index 000000000..4b3f0e1b4 --- /dev/null +++ b/src/utils/error_monad.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Protocol Implementation - Error Monad *) + +(** Categories of error *) +type error_category = + [ `Branch (** Errors that may not happen in another context *) + | `Temporary (** Errors that may not happen in a later context *) + | `Permanent (** Errors that will happen no matter the context *) + ] + +include Error_monad_sig.S + +(** Erroneous result (shortcut for generic errors) *) +val generic_error : string -> 'a tzresult + +(** Erroneous return (shortcut for generic errors) *) +val failwith : + ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> + 'a + +val error_exn : exn -> 'a tzresult +val record_trace_exn : exn -> 'a tzresult -> 'a tzresult +val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + +type error += Exn of exn +type error += Unclassified of string + +module Make() : Error_monad_sig.S diff --git a/src/utils/error_monad_sig.ml b/src/utils/error_monad_sig.ml new file mode 100644 index 000000000..02964ae79 --- /dev/null +++ b/src/utils/error_monad_sig.ml @@ -0,0 +1,134 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Categories of error *) +type error_category = + [ `Branch (** Errors that may not happen in another context *) + | `Temporary (** Errors that may not happen in a later context *) + | `Permanent (** Errors that will happen no matter the context *) + ] + +module type S = sig + + type error = .. + + val pp: Format.formatter -> error -> unit + val pp_print_error: Format.formatter -> error list -> unit + + (** An error serializer *) + val error_encoding : unit -> error Data_encoding.t + val json_of_error : error -> Data_encoding.json + val error_of_json : Data_encoding.json -> error + + (** {2 Error classification} ***********************************************) + + (** For other modules to register specialized error serializers *) + val register_error_kind : + error_category -> + id:string -> title:string -> description:string -> + ?pp:(Format.formatter -> 'err -> unit) -> + 'err Data_encoding.t -> + (error -> 'err option) -> ('err -> error) -> + unit + + val register_wrapped_error_kind : + ('err -> error_category) -> + id:string -> title:string -> description:string -> + ?pp:(Format.formatter -> 'err -> unit) -> + 'err Data_encoding.t -> + (error -> 'err option) -> ('err -> error) -> + unit + + (** Classify an error using the registered kinds *) + val classify_errors : error list -> error_category + + (** {2 Monad definition} ***************************************************) + + (** The error monad wrapper type, the error case holds a stack of + error, initialized by the first call to {!fail} and completed by + each call to {!trace} as the stack is rewinded. The most general + error is thus at the top of the error stack, going down to the + specific error that actually caused the failure. *) + type 'a tzresult = ('a, error list) result + + (** A serializer for result of a given type *) + val result_encoding : + 'a Data_encoding.t -> + 'a tzresult Data_encoding.t + + (** Sucessful result *) + val ok : 'a -> 'a tzresult + + (** Sucessful return *) + val return : 'a -> 'a tzresult Lwt.t + + (** Erroneous result *) + val error : error -> 'a tzresult + + (** Erroneous return *) + val fail : error -> 'a tzresult Lwt.t + + (** Non-Lwt bind operator *) + val (>>?) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult + + (** Bind operator *) + val (>>=?) : + 'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t + + (** Lwt's bind reexported *) + val (>>=) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + val (>|=) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + + (** To operator *) + val (>>|?) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t + + (** Non-Lwt to operator *) + val (>|?) : 'a tzresult -> ('a -> 'b) -> 'b tzresult + + (** Enrich an error report (or do nothing on a successful result) manually *) + val record_trace : error -> 'a tzresult -> 'a tzresult + + (** Automatically enrich error reporting on stack rewind *) + val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + + (** Erroneous return on failed assertion *) + val fail_unless : bool -> error -> unit tzresult Lwt.t + + (** {2 In-monad list iterators} ********************************************) + + (** A {!List.iter} in the monad *) + val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + + (** A {!List.map} in the monad *) + val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + + (** A {!List.map2} in the monad *) + val map2 : + ('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult + + (** A {!List.map2} in the monad *) + val map2_s : + ('a -> 'b -> 'c tzresult Lwt.t) -> 'a list -> 'b list -> + 'c list tzresult Lwt.t + + (** A {!List.map_filter} in the monad *) + val map_filter_s : + ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + + (** A {!List.fold_left} in the monad *) + val fold_left_s : + ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t + + (** A {!List.fold_right} in the monad *) + val fold_right_s : + ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t + +end diff --git a/src/utils/hash.ml b/src/utils/hash.ml new file mode 100644 index 000000000..4cfd75db3 --- /dev/null +++ b/src/utils/hash.ml @@ -0,0 +1,240 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let (//) = Filename.concat +let (>>=) = Lwt.bind +let (>|=) = Lwt.(>|=) + +open Utils + +(*-- Signatures -------------------------------------------------------------*) + +module type HASH = sig + type t + + val hash_bytes: MBytes.t list -> t + val hash_string: string list -> t + val size: int (* in bytes *) + val compare: t -> t -> int + val equal: t -> t -> bool + val of_raw: string -> t + val to_raw: t -> string + val of_hex: string -> t + val to_hex: t -> string + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string + val to_bytes: t -> MBytes.t + val of_bytes: MBytes.t -> t + val read: MBytes.t -> int -> t + val write: MBytes.t -> int -> t -> unit + val to_path: t -> string list + val of_path: string list -> t + val path_len: int + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit + val pp_short: Format.formatter -> t -> unit + type Base48.data += Hash of t +end + +module type Name = sig + val name : string + val title : string + val prefix : string option +end + +(*-- Type specific Hash builder ---------------------------------------------*) + +module Make_SHA256 (K : Name) = struct + + type t = string + + let size = 32 (* SHA256 *) + + let of_raw s = + if String.length s <> size then begin + let msg = + Printf.sprintf "%s.of_raw: wrong string size for %S (%d)" + K.name s (String.length s) in + raise (Invalid_argument msg) + end; + s + let to_raw s = s + + let of_hex s = of_raw (Hex_encode.hex_decode s) + let to_hex s = Hex_encode.hex_encode s + + type Base48.data += Hash of t + + let () = + match K.prefix with + | Some prefix -> + Base48.register + ~prefix + ~read:(function Hash x -> Some x | _ -> None) + ~build:(fun x -> Hash x) + | None -> () + + let of_b48check s = + match Base48.decode s with + | Hash x -> x + | _ -> Format.kasprintf failwith "Unexpected hash (%s)" K.name + let to_b48check s = Base48.encode (Hash s) + + let to_short_b48check s = String.sub (to_b48check s) 0 8 + + let compare = String.compare + let equal : t -> t -> bool = (=) + + let of_bytes b = + let s = MBytes.to_string b in + if String.length s <> size then begin + let msg = + Printf.sprintf "%s.of_bytes: wrong string size for %S (%d)" + K.name s (String.length s) in + raise (Invalid_argument msg) + end; + s + let to_bytes = MBytes.of_string + + let read src off = MBytes.substring src off size + let write dst off h = MBytes.blit_from_string h 0 dst off size + + let hash_bytes l = + let hash = Cryptokit.Hash.sha256 () in + (* FIXME... bigstring... *) + List.iter (fun b -> hash#add_string (MBytes.to_string b)) l; + let r = hash#result in hash#wipe; r + + let hash_string l = + let hash = Cryptokit.Hash.sha256 () in + List.iter (fun b -> hash#add_string b) l; + let r = hash#result in hash#wipe; r + + module Set = Set.Make(struct type t = string let compare = compare end) + + let fold_read f buf off len init = + let last = off + len * size in + if last > MBytes.length buf then + invalid_arg "Hash.read_set: invalid size."; + let rec loop acc off = + if off >= last then + acc + else + let hash = read buf off in + loop (f hash acc) (off + size) + in + loop init off + + module Map = Map.Make(struct type t = string let compare = compare end) + module Table = + (* TODO improve *) + Hashtbl.Make(struct + type t = string + let hash s = Int64.to_int (EndianString.BigEndian.get_int64 s 0) + let equal = equal + end) + + let path_len = 5 + let to_path key = + let key = to_hex key in + [ String.sub key 0 2 ; String.sub key 2 2 ; + String.sub key 4 2 ; String.sub key 6 2 ; + String.sub key 8 (size * 2 - 8) ] + let of_path path = + let path = String.concat "" path in + of_hex path + + (* Serializers *) + + let encoding = + let open Data_encoding in + splitted + ~binary: + (conv to_bytes of_bytes (Fixed.bytes size)) + ~json: + (describe ~title: (K.title ^ " (Base48Check-encoded Sha256)") @@ + conv to_b48check (Data_encoding.Json.wrap_error of_b48check) string) + + let param ?(name=K.name) ?(desc=K.title) t = + Cli_entries.param ~name ~desc (fun str -> Lwt.return (of_b48check str)) t + + let pp ppf t = + Format.pp_print_string ppf (to_b48check t) + + let pp_short ppf t = + Format.pp_print_string ppf (to_short_b48check t) + +end + +(*-- Hash sets and maps -----------------------------------------------------*) + +module Hash_set (Hash : HASH) = struct + include Set.Make (Hash) + let encoding = + Data_encoding.conv + elements + (fun l -> List.fold_left (fun m x -> add x m) empty l) + Data_encoding.(list Hash.encoding) +end + +module Hash_map (Hash : HASH) = struct + include Map.Make (Hash) + let encoding arg_encoding = + Data_encoding.conv + bindings + (fun l -> List.fold_left (fun m (k,v) -> add k v m) empty l) + Data_encoding.(list (tup2 Hash.encoding arg_encoding)) +end + +module Hash_table (Hash : HASH) + : Hashtbl.S with type key = Hash.t + = Hashtbl.Make (struct + type t = Hash.t + let equal = Hash.equal + let hash v = + let raw_hash = Hash.to_raw v in + let int64_hash = EndianString.BigEndian.get_int64 raw_hash 0 in + Int64.to_int int64_hash + end) + +(*-- Pre-instanciated hashes ------------------------------------------------*) + +module Block_hash = + Make_SHA256 (struct + let name = "Block_hash" + let title = "A Tezos block ID" + let prefix = Some Base48.Prefix.block_hash + end) + +module Block_hash_set = Hash_set (Block_hash) +module Block_hash_map = Hash_map (Block_hash) +module Block_hash_table = Hash_table (Block_hash) + +module Operation_hash = + Make_SHA256 (struct + let name = "Operation_hash" + let title = "A Tezos operation ID" + let prefix = Some Base48.Prefix.operation_hash + end) + +module Operation_hash_set = Hash_set (Operation_hash) +module Operation_hash_map = Hash_map (Operation_hash) +module Operation_hash_table = Hash_table (Operation_hash) + +module Protocol_hash = + Make_SHA256 (struct + let name = "Protocol_hash" + let title = "A Tezos protocol ID" + let prefix = Some Base48.Prefix.protocol_hash + end) + +module Protocol_hash_set = Hash_set (Protocol_hash) +module Protocol_hash_map = Hash_map (Protocol_hash) +module Protocol_hash_table = Hash_table (Protocol_hash) diff --git a/src/utils/hash.mli b/src/utils/hash.mli new file mode 100644 index 000000000..7ca62e7a5 --- /dev/null +++ b/src/utils/hash.mli @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Manipulation and creation of hashes *) + + +(** {2 Hash Types} ************************************************************) + +(** The signature of an abstract hash type, as produced by functor + {!Make_SHA256}. The {!t} type is abstracted for separating the + various kinds of hashes in the system at typing time. Each type is + equipped with functions to use it as is of as keys in the database + or in memory sets and maps. *) +module type HASH = sig + type t + + val hash_bytes: MBytes.t list -> t + val hash_string: string list -> t + val size: int (* in bytes *) + val compare: t -> t -> int + val equal: t -> t -> bool + val of_raw: string -> t + val to_raw: t -> string + val of_hex: string -> t + val to_hex: t -> string + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string + val to_bytes: t -> MBytes.t + val of_bytes: MBytes.t -> t + val read: MBytes.t -> int -> t + val write: MBytes.t -> int -> t -> unit + val to_path: t -> string list + val of_path: string list -> t + val path_len: int + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit + val pp_short: Format.formatter -> t -> unit + type Base48.data += Hash of t +end + +(** {2 Building Hashes} *******************************************************) + +(** The parameters for creating a new Hash type using + {!Make_SHA256}. Both {!name} and {!title} are only informative, + used in error messages and serializers. *) +module type Name = sig + val name : string + val title : string + val prefix : string option +end + +(** Builds a new Hash type using Sha256. *) +module Make_SHA256 (Name:Name) : HASH + +(** Builds a Set of values of some Hash type. *) +module Hash_set (Hash : HASH) : sig + include Set.S with type elt = Hash.t + val encoding: t Data_encoding.t +end + +(** Builds a Map using some Hash type as keys. *) +module Hash_map (Hash : HASH) : sig + include Map.S with type key = Hash.t + val encoding: 'a Data_encoding.t -> 'a t Data_encoding.t +end + +(** Builds a Hashtbl using some Hash type as keys. *) +module Hash_table (Hash : HASH) : Hashtbl.S with type key = Hash.t + +(** {2 Predefined Hashes } ****************************************************) + +(** Blocks hashes / IDs. *) +module Block_hash : sig + include HASH + val param : + ?name:string -> + ?desc:string -> + 'a Cli_entries.params -> + (t -> 'a) Cli_entries.params +end + +module Block_hash_set : module type of Hash_set (Block_hash) +module Block_hash_map : module type of Hash_map (Block_hash) +module Block_hash_table : module type of Hash_table (Block_hash) + +(** Operations hashes / IDs. *) +module Operation_hash : HASH +module Operation_hash_set : Set.S with type elt = Operation_hash.t +module Operation_hash_map : module type of Hash_map (Operation_hash) +module Operation_hash_table : module type of Hash_table (Operation_hash) + +(** Protocol versions / source hashes. *) +module Protocol_hash : HASH +module Protocol_hash_set : module type of Hash_set (Protocol_hash) +module Protocol_hash_map : module type of Hash_map (Protocol_hash) +module Protocol_hash_table : module type of Hash_table (Protocol_hash) diff --git a/src/utils/hex_encode.ml b/src/utils/hex_encode.ml new file mode 100644 index 000000000..65cf85f7f --- /dev/null +++ b/src/utils/hex_encode.ml @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Utility library - Hexadecimal encoding *) + +(* From OCaml's stdlib. See [Digest.to_hex] *) +let gen_encode length get s = + let n = length s in + let result = Bytes.create (n*2) in + for i = 0 to n-1 do + Bytes.blit_string (Printf.sprintf "%02x" (get s i)) 0 result (2*i) 2; + done; + Bytes.unsafe_to_string result + +let hex_of_bytes = gen_encode MBytes.length MBytes.get_uint8 +let hex_encode = gen_encode String.length (fun s i -> int_of_char s.[i]) + +(* From OCaml's stdlib. See [Digest.from_hex]. *) +let gen_decode create set h = + let n = String.length h in + if n mod 2 <> 0 then invalid_arg "hex_decode" ; + let digit c = + match c with + | '0'..'9' -> int_of_char c - int_of_char '0' + | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10 + | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10 + | _c -> invalid_arg "hex_decode" in + let byte i = digit h.[i] lsl 4 + digit h.[i+1] in + let result = create (n / 2) in + for i = 0 to n/2 - 1 do + set result i (byte (2 * i)); + done; + result + +let hex_decode s = + gen_decode Bytes.create (fun s i c -> Bytes.set s i (char_of_int c)) s |> + Bytes.unsafe_to_string + +let bytes_of_hex s = + gen_decode MBytes.create MBytes.set_int8 s + +(* +let hex_bytes = + let open Data_encoding in + let schema = + let open Json_schema in + create + { title = None ; + description = None ; + default = None; + enum = None; + kind = String { + pattern = Some "^[a-zA-Z0-9]+$"; + min_length = 0; + max_length = None; + }; + format = None ; + id = None } in + conv ~schema hex_of_bytes (Json.wrap_error bytes_of_hex) string + +let sha256 = + let open Data_encoding in + let schema = + let open Json_schema in + create + { title = None ; + description = None ; + default = None; + enum = None; + kind = String { + pattern = Some "^[a-zA-Z0-9]+$"; + min_length = 64; + max_length = Some 64; + }; + format = Some "sha256" ; + id = None } in + conv ~schema hex_of_bytes (Json.wrap_error bytes_of_hex) string +*) diff --git a/src/utils/hex_encode.mli b/src/utils/hex_encode.mli new file mode 100644 index 000000000..a3991959e --- /dev/null +++ b/src/utils/hex_encode.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos Utility library - Hexadecimal encoding *) + +(** Parses a sequence of hexadecimal characters pairs as bytes *) +val hex_of_bytes: MBytes.t -> string + +(** Prints a sequence of bytes as hexadecimal characters pairs *) +val bytes_of_hex: string -> MBytes.t + +(** Interprets a sequence of hexadecimal characters pairs representing + bytes as the characters codes of an OCaml string. *) +val hex_decode: string -> string + +(** Formats the codes of the characters of an OCaml string as a + sequence of hexadecimal character pairs. *) +val hex_encode: string -> string diff --git a/src/utils/logging.ml b/src/utils/logging.ml new file mode 100644 index 000000000..dea4cc404 --- /dev/null +++ b/src/utils/logging.ml @@ -0,0 +1,113 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type LOG = sig + + val debug: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ('a, Format.formatter, unit, 'b) format4 -> 'a + + val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + +end + +let log_f + ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = + if level < Lwt_log.Section.level section then + Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format + else + Format.kasprintf + (Lwt_log.log ?exn ~section ?location ?logger ~level) + format + +let ign_log_f + ?exn ?(section = Lwt_log.Section.main) ?location ?logger ~level format = + if level < Lwt_log.Section.level section then + Format.ikfprintf (fun _ -> ()) Format.std_formatter format + else + Format.kasprintf + (fun s -> + Lwt_log.ign_log ?exn ~section ?location ?logger ~level s) + format + +module Make(S : sig val name: string end) : LOG = struct + + let section = Lwt_log.Section.make S.name + + let debug fmt = ign_log_f ~section ~level:Lwt_log.Debug fmt + let log_info fmt = ign_log_f ~section ~level:Lwt_log.Info fmt + let log_notice fmt = ign_log_f ~section ~level:Lwt_log.Notice fmt + let warn fmt = ign_log_f ~section ~level:Lwt_log.Warning fmt + let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt + let fatal_error fmt = + Format.kasprintf + (fun s -> Lwt_log.ign_fatal ~section s; Utils.exit 1) + fmt + + let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt + let lwt_log_info fmt = log_f ~section ~level:Lwt_log.Info fmt + let lwt_log_notice fmt = log_f ~section ~level:Lwt_log.Notice fmt + let lwt_warn fmt = log_f ~section ~level:Lwt_log.Warning fmt + let lwt_log_error fmt = log_f ~section ~level:Lwt_log.Error fmt + +end + +module Core = Make(struct let name = "core" end) +module Net = Make(struct let name = "net" end) +module RPC = Make(struct let name = "rpc" end) +module Db = Make(struct let name = "db" end) +module Updater = Make(struct let name = "updater" end) +module Node = struct + module State = Make(struct let name = "node.state" end) + module Validator = Make(struct let name = "node.validator" end) + module Prevalidator = Make(struct let name = "node.prevalidator" end) + module Discoverer = Make(struct let name = "node.discoverer" end) + module Worker = Make(struct let name = "node.worker" end) + module Main = Make(struct let name = "node.main" end) +end +module Client = struct + module Blocks = Make(struct let name = "client.blocks" end) + module Mining = Make(struct let name = "client.mining" end) + module Endorsement = Make(struct let name = "client.endorsement" end) + module Revelation = Make(struct let name = "client.revealation" end) + module Denunciation = Make(struct let name = "client.denunciation" end) +end + +let default_logger () = + Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () + +type kind = + | Null + | Stdout + | Stderr + | File of string + | Syslog + +let init kind = + let logger = + match kind with + | Stderr -> + default_logger () + | Stdout -> + Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stdout () + | File file_name -> + Lwt_main.run (Lwt_log.file ~file_name ()) + | Null -> + Lwt_log.null + | Syslog -> + Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!"; + default_logger () in + Lwt_log.default := logger diff --git a/src/utils/logging.mli b/src/utils/logging.mli new file mode 100644 index 000000000..7486a0699 --- /dev/null +++ b/src/utils/logging.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type LOG = sig + + val debug: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a + val warn: ('a, Format.formatter, unit, unit) format4 -> 'a + val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a + val fatal_error: ('a, Format.formatter, unit, 'b) format4 -> 'a + + val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + +end + +module Core : LOG +module Net : LOG +module RPC : LOG +module Db : LOG +module Updater : LOG +module Node : sig + module State : LOG + module Validator : LOG + module Prevalidator : LOG + module Discoverer : LOG + module Worker : LOG + module Main : LOG +end +module Client : sig + module Blocks : LOG + module Mining : LOG + module Endorsement : LOG + module Revelation : LOG + module Denunciation : LOG +end + +module Make(S: sig val name: string end) : LOG + +type kind = + | Null + | Stdout + | Stderr + | File of string + | Syslog + +val init: kind -> unit diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml new file mode 100644 index 000000000..b2fcf5e15 --- /dev/null +++ b/src/utils/lwt_utils.ml @@ -0,0 +1,225 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module LC = Lwt_condition +open Logging.Core + +let (>>=) = Lwt.(>>=) +let (>|=) = Lwt.(>|=) + +let never_ending = fst (Lwt.wait ()) + +(* A non exception-based cancelation mechanism. Builds a [cancelation] + thread to bind / pick on, awoken when a cancelation is requested by + [cancel ()]. [on_cancel cb] registers a callback to be called at + cancelation. [cancel ()] finishes when all calbacks have completed + (sequentially), instantly when called more than once. *) +let canceler () + : (unit -> unit Lwt.t) * + (unit -> unit Lwt.t) * + ((unit -> unit Lwt.t) -> unit) = + let cancelation = LC.create () in + let cancelation_complete = LC.create () in + let cancel_hook = ref (fun () -> Lwt.return ()) in + let canceling = ref false and canceled = ref false in + let cancel () = + if !canceled then + Lwt.return () + else if !canceling then + LC.wait cancelation_complete + else begin + canceling := true ; + LC.broadcast cancelation () ; + !cancel_hook () >>= fun () -> + canceled := true ; + LC.broadcast cancelation_complete () ; + Lwt.return () + end + in + let on_cancel cb = + let hook = !cancel_hook in + cancel_hook := (fun () -> hook () >>= cb) ; + in + let cancelation () = + if !canceling then Lwt.return () + else LC.wait cancelation + in + cancelation, cancel, on_cancel + +type trigger = + | Absent + | Present + | Waiting of unit Lwt.u + +let trigger () : (unit -> unit) * (unit -> unit Lwt.t) = + let state = ref Absent in + let trigger () = + match !state with + | Absent -> state := Present + | Present -> () + | Waiting u -> + state := Absent; + Lwt.wakeup u () + in + let wait () = + match !state with + | Absent -> + let waiter, u = Lwt.wait () in + state := Waiting u; + waiter + | Present -> + state := Absent; + Lwt.return_unit + | Waiting u -> + Lwt.waiter_of_wakener u + in + trigger, wait + +type 'a queue = + | Absent + | Present of 'a list ref + | Waiting of 'a list Lwt.u + +let queue () : ('a -> unit) * (unit -> 'a list Lwt.t) = + let state = ref Absent in + let queue v = + match !state with + | Absent -> state := Present (ref [v]) + | Present r -> r := v :: !r + | Waiting u -> + state := Absent; + Lwt.wakeup u [v] + in + let wait () = + match !state with + | Absent -> + let waiter, u = Lwt.wait () in + state := Waiting u; + waiter + | Present r -> + state := Absent; + Lwt.return (List.rev !r) + | Waiting u -> + Lwt.waiter_of_wakener u + in + queue, wait + +(* A worker launcher, takes a cancel callback to call upon *) +let worker name ~run ~cancel = + let stop = LC.create () in + let fail e = + log_error "%s worker failed with %s" name (Printexc.to_string e) ; + cancel () >>= fun () -> Lwt.fail e + in + let waiter = LC.wait stop in + log_info "%s worker started" name ; + Lwt.async + (fun () -> + Lwt.catch run fail >>= fun () -> + LC.signal stop (); + Lwt.return ()) ; + waiter >>= fun () -> + log_info "%s worker ended" name ; + Lwt.return () + + +let rec chop k l = + if k = 0 then l else begin + match l with + | _::t -> chop (k-1) t + | _ -> assert false + end +let stable_sort cmp l = + let rec rev_merge l1 l2 accu = + match l1, l2 with + | [], l2 -> Lwt.return (List.rev_append l2 accu) + | l1, [] -> Lwt.return (List.rev_append l1 accu) + | h1::t1, h2::t2 -> + cmp h1 h2 >>= function + | x when x <= 0 -> rev_merge t1 l2 (h1::accu) + | _ -> rev_merge l1 t2 (h2::accu) + in + let rec rev_merge_rev l1 l2 accu = + match l1, l2 with + | [], l2 -> Lwt.return (List.rev_append l2 accu) + | l1, [] -> Lwt.return (List.rev_append l1 accu) + | h1::t1, h2::t2 -> + cmp h1 h2 >>= function + | x when x > 0 -> rev_merge_rev t1 l2 (h1::accu) + | _ -> rev_merge_rev l1 t2 (h2::accu) + in + let rec sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> begin + cmp x1 x2 >|= function + | x when x <= 0 -> [x1; x2] + | _ -> [x2; x1] + end + | 3, x1 :: x2 :: x3 :: _ -> begin + cmp x1 x2 >>= function + | x when x <= 0 -> begin + cmp x2 x3 >>= function + | x when x <= 0 -> Lwt.return [x1; x2; x3] + | _ -> cmp x1 x3 >|= function + | x when x <= 0 -> [x1; x3; x2] + | _ -> [x3; x1; x2] + end + | _ -> begin + cmp x1 x3 >>= function + | x when x <= 0 -> Lwt.return [x2; x1; x3] + | _ -> cmp x2 x3 >|= function + | x when x <= 0 -> [x2; x3; x1] + | _ -> [x3; x2; x1] + end + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + rev_sort n1 l >>= fun s1 -> + rev_sort n2 l2 >>= fun s2 -> + rev_merge_rev s1 s2 [] + and rev_sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> begin + cmp x1 x2 >|= function + | x when x > 0 -> [x1; x2] + | _ -> [x2; x1] + end + | 3, x1 :: x2 :: x3 :: _ -> begin + cmp x1 x2 >>= function + | x when x > 0 -> begin + cmp x2 x3 >>= function + | x when x > 0 -> Lwt.return [x1; x2; x3] + | _ -> + cmp x1 x3 >|= function + | x when x > 0 -> [x1; x3; x2] + | _ -> [x3; x1; x2] + end + | _ -> begin + cmp x1 x3 >>= function + | x when x > 0 -> Lwt.return [x2; x1; x3] + | _ -> + cmp x2 x3 >|= function + | x when x > 0 -> [x2; x3; x1] + | _ -> [x3; x2; x1] + end + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + sort n1 l >>= fun s1 -> + sort n2 l2 >>= fun s2 -> + rev_merge s1 s2 [] + in + let len = List.length l in + if len < 2 then Lwt.return l else sort len l + +let sort = stable_sort diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli new file mode 100644 index 000000000..7f42580b7 --- /dev/null +++ b/src/utils/lwt_utils.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val never_ending: 'a Lwt.t + +val canceler : unit -> + (unit -> unit Lwt.t) * + (unit -> unit Lwt.t) * + ((unit -> unit Lwt.t) -> unit) + +val worker: + string -> + run:(unit -> unit Lwt.t) -> + cancel:(unit -> unit Lwt.t) -> + unit Lwt.t + +val trigger: unit -> (unit -> unit) * (unit -> unit Lwt.t) +val queue: unit -> ('a -> unit) * (unit -> 'a list Lwt.t) +val sort: ('a -> 'a -> int Lwt.t) -> 'a list -> 'a list Lwt.t diff --git a/src/utils/mBytes.ml b/src/utils/mBytes.ml new file mode 100644 index 000000000..53b7eed6f --- /dev/null +++ b/src/utils/mBytes.ml @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Bigarray + +type t = (char, int8_unsigned_elt, c_layout) Array1.t + +let create sz = Array1.create char c_layout sz +let length = Array1.dim +let sub = Array1.sub +let shift ba off = sub ba off (length ba - off) +let blit src srcoff dst dstoff len = + Array1.blit (sub src srcoff len) (sub dst dstoff len) +let copy ba = + let ba' = create (Array1.dim ba) in + Array1.blit ba ba'; + ba' + +(** Adapted from ocaml-cstruct. *) + +external unsafe_blit_string_to_bigstring + : string -> int -> t -> int -> int -> unit + = "caml_blit_string_to_bigstring" [@@noalloc] + +external unsafe_blit_bigstring_to_bytes + : t -> int -> bytes -> int -> int -> unit + = "caml_blit_bigstring_to_string" [@@noalloc] + +(** HACK: force Cstruct at link which provides the previous primitives. *) +let dummy = Cstruct.byte_to_int + +let invalid_bounds j l = + invalid_arg (Printf.sprintf "invalid bounds (index %d, length %d)" j l) + +let blit_from_string src srcoff dst dstoff len = + if len < 0 || srcoff < 0 || dstoff < 0 || String.length src - srcoff < len then + raise (Invalid_argument (invalid_bounds srcoff len)); + if length dst - dstoff < len then + raise (Invalid_argument (invalid_bounds dstoff len)); + unsafe_blit_string_to_bigstring src srcoff dst dstoff len + +let blit_to_bytes src srcoff dst dstoff len = + if len < 0 || srcoff < 0 || dstoff < 0 || length src - srcoff < len then + raise (Invalid_argument (invalid_bounds srcoff len)); + if Bytes.length dst - dstoff < len then + raise (Invalid_argument (invalid_bounds dstoff len)); + unsafe_blit_bigstring_to_bytes src srcoff dst dstoff len + +let to_string buf = + let sz = length buf in + let s = Bytes.create sz in + unsafe_blit_bigstring_to_bytes buf 0 s 0 sz; + Bytes.unsafe_to_string s + +let of_string buf = + let buflen = String.length buf in + let c = create buflen in + unsafe_blit_string_to_bigstring buf 0 c 0 buflen; + c + +let substring src srcoff len = + if len < 0 || srcoff < 0 || length src - srcoff < len then + raise (Invalid_argument (invalid_bounds srcoff len)); + let s = Bytes.create len in + unsafe_blit_bigstring_to_bytes src srcoff s 0 len; + Bytes.unsafe_to_string s + +include EndianBigstring.BigEndian + +let get_bool s off = + ((get_uint8 s (off / 8)) lsr (off mod 8)) land 1 = 1 + +let of_float f = + let buf = create 8 in + set_float buf 0 f; + buf + +module LE = struct + include EndianBigstring.LittleEndian +end + + +let (=) = ((=) : t -> t -> bool) +let (<>) = ((<>) : t -> t -> bool) +let (<) = ((<) : t -> t -> bool) +let (<=) = ((<=) : t -> t -> bool) +let (>=) = ((>=) : t -> t -> bool) +let (>) = ((>) : t -> t -> bool) +let compare = Pervasives.compare + +let concat b1 b2 = + let l1 = length b1 in + let l2 = length b2 in + let b = create (l1 + l2) in + blit b1 0 b 0 l1 ; + blit b2 0 b l1 l2 ; + b + diff --git a/src/utils/mBytes.mli b/src/utils/mBytes.mli new file mode 100644 index 000000000..18f5b65ea --- /dev/null +++ b/src/utils/mBytes.mli @@ -0,0 +1,148 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Bigarray + +type t = (char, int8_unsigned_elt, c_layout) Array1.t + +val create: int -> t + +val length: t -> int + +val copy: t -> t + +val sub: t -> int -> int -> t +(** [sub src ofs len] extract a sub-array of [src] starting at [ofs] + and of length [len]. No copying of elements is involved: the + sub-array and the original array share the same storage space. *) + +val shift: t -> int -> t +(** [shift src ofs] is equivalent to [sub src ofs (length src - ofs)] *) + +val blit: t -> int -> t -> int -> int -> unit +(** [blit src ofs_src dst ofs_dst len] copy [len] bytes from [src] + starting at [ofs_src] into [dst] starting at [ofs_dst].] *) + +val blit_from_string: string -> int -> t -> int -> int -> unit +(** See [blit] *) + +val blit_to_bytes: t -> int -> bytes -> int -> int -> unit +(** See [blit] *) + +val of_string: string -> t +(** [of_string s] create an byte array filled with the same content than [s]. *) + +val to_string: t -> string +(** [to_string b] dump the array content in a [string]. *) + +val substring: t -> int -> int -> string +(** [substring b ofs len] is equivalent to [to_string (sub b ofs len)]. *) + +(** Functions reading and writing bytes *) + +val get_char: t -> int -> char +(** [get_char buff i] reads 1 byte at offset i as a char *) + +val get_bool: t -> int -> bool +(** [get_bool buff i] reads 1 bit at offset i as an unsigned int bit. *) + +val get_uint8: t -> int -> int +(** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + +val get_int8: t -> int -> int +(** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + +val set_char: t -> int -> char -> unit +(** [set_char buff i v] writes [v] to [buff] at offset [i] *) + +val set_int8: t -> int -> int -> unit +(** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + +(** Functions reading according to Big Endian byte order *) + +val get_uint16: t -> int -> int +(** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + +val get_int16: t -> int -> int +(** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + +val get_int32: t -> int -> int32 +(** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + +val get_int64: t -> int -> int64 +(** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + +val get_float: t -> int -> float +(** [get_float buff i] reads 4 bytes at offset i as an IEEE754 float. *) + +val get_double: t -> int -> float +(** [get_float buff i] reads 8 bytes at offset i as an IEEE754 double. *) + +val set_int16: t -> int -> int -> unit +(** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + +val set_int32: t -> int -> int32 -> unit +(** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + +val set_int64: t -> int -> int64 -> unit +(** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + +val set_float: t -> int -> float -> unit +(** [set_float buff i v] writes [v] to [buff] at offset [i] *) + +val set_double: t -> int -> float -> unit +(** [set_double buff i v] writes [v] to [buff] at offset [i] *) + +val of_float: float -> t + +module LE: sig + + (** Functions reading according to Little Endian byte order *) + + val get_uint16: t -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16: t -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32: t -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64: t -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val set_int16: t -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32: t -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64: t -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + +end + +val (=) : t -> t -> bool +val (<>) : t -> t -> bool +val (<) : t -> t -> bool +val (<=) : t -> t -> bool +val (>=) : t -> t -> bool +val (>) : t -> t -> bool +val compare : t -> t -> int + +val concat: t -> t -> t diff --git a/src/utils/time.ml b/src/utils/time.ml new file mode 100644 index 000000000..e52fa775a --- /dev/null +++ b/src/utils/time.ml @@ -0,0 +1,115 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open CalendarLib + +type t = int64 + +let compare = Int64.compare +let (=) x y = compare x y = 0 +let equal = (=) +let (<>) x y = compare x y <> 0 +let (<) x y = compare x y < 0 +let (<=) x y = compare x y <= 0 +let (>=) x y = compare x y >= 0 +let (>) x y = compare x y > 0 +let min x y = if x <= y then x else y +let max x y = if x <= y then y else x + +let add = Int64.add +let diff = Int64.sub + +let now () = Int64.of_float (Unix.gettimeofday ()) + +let of_seconds x = x +let to_seconds x = x + +let formats = + [ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ"; + "%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ] + +let int64_of_calendar c = + let round fc = + let f, i = modf fc in + Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in + round @@ Calendar.Precise.to_unixfloat c + +let rec iter_formats s = function + | [] -> None + | f :: fs -> + try + Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s) + with _ -> iter_formats s fs + +let of_notation s = + iter_formats s formats +let of_notation_exn s = + match of_notation s with + | None -> invalid_arg "Time.of_notation: can't parse." + | Some t -> t + +let to_notation t = + let ft = Int64.to_float t in + if Int64.of_float ft <> t then + "out_of_range" + else + Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (Calendar.Precise.from_unixfloat ft) + +let rfc_encoding = + let open Data_encoding in + def + "timestamp" @@ + describe + ~title: + "RFC 339 formatted timestamp" + ~description: + "A date in human readble form as specified in RFC 3339." @@ + conv + to_notation + (fun s -> match of_notation s with + | Some s -> s + | None -> Data_encoding.Json.cannot_destruct "Time.of_notation") + string + +let encoding = + let open Data_encoding in + splitted + ~binary: int64 + ~json: + (union [ + case + rfc_encoding + (fun i -> Some i) + (fun i -> i) ; + case + int64 + (fun _ -> None) + (fun i -> i) ; + ]) + +type 'a timed_data = { + data: 'a ; + time: t ; +} + +let timed_encoding arg_encoding = + let open Data_encoding in + conv + (fun {time; data} -> (time, data)) + (fun (time, data) -> {time; data}) + (tup2 encoding arg_encoding) + +let make_timed data = { + data ; time = now () ; +} + +let pp_hum ppf t = Format.pp_print_string ppf (to_notation t) diff --git a/src/utils/time.mli b/src/utils/time.mli new file mode 100644 index 000000000..8d209894e --- /dev/null +++ b/src/utils/time.mli @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t + +val add : t -> int64 -> t +val diff : t -> t -> int64 + +val equal : t -> t -> bool +val compare : t -> t -> int + +val (=) : t -> t -> bool +val (<>) : t -> t -> bool +val (<) : t -> t -> bool +val (<=) : t -> t -> bool +val (>=) : t -> t -> bool +val (>) : t -> t -> bool +val min : t -> t -> t +val max : t -> t -> t + +val of_seconds : int64 -> t +val to_seconds : t -> int64 + +val of_notation : string -> t option +val of_notation_exn : string -> t +val to_notation : t -> string + +val now : unit -> t + +val encoding : t Data_encoding.t +val rfc_encoding : t Data_encoding.t + +val pp_hum : Format.formatter -> t -> unit + +type 'a timed_data = { + data: 'a ; + time: t ; +} + +val make_timed : 'a -> 'a timed_data + +val timed_encoding : 'a Data_encoding.t -> 'a timed_data Data_encoding.t diff --git a/src/utils/utils.ml b/src/utils/utils.ml new file mode 100644 index 000000000..b97ef87e1 --- /dev/null +++ b/src/utils/utils.ml @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let (>>=) = Lwt.bind + +let remove_dir dir = + let rec remove dir = + let files = Lwt_unix.files_of_directory dir in + Lwt_stream.iter_s + (fun file -> + if file = "." || file = ".." then + Lwt.return () + else begin + let file = Filename.concat dir file in + if Sys.is_directory file + then remove file + else Lwt_unix.unlink file + end) + files >>= fun () -> + Lwt_unix.rmdir dir in + if Sys.file_exists dir && Sys.is_directory dir then + remove dir + else + Lwt.return () + +let rec create_dir ?(perm = 0o755) dir = + if Sys.file_exists dir then + Lwt.return () + else begin + create_dir (Filename.dirname dir) >>= fun () -> + Lwt_unix.mkdir dir perm + end + +let create_file ?(perm = 0o644) name content = + Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> + Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> + Lwt_unix.close fd + + +exception Exit +let termination_thread, exit_wakener = Lwt.wait () +let exit x = Lwt.wakeup exit_wakener x; raise Exit + +let () = + Lwt.async_exception_hook := + (function + | Exit -> () + | exn -> + Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" + (Printexc.to_string exn) (Printexc.get_backtrace ()); + exit 1) + +module StringMap = Map.Make (String) + +let split delim ?(limit = max_int) path = + let l = String.length path in + let rec do_slashes acc limit i = + if i >= l then + List.rev acc + else if String.get path i = delim then + do_slashes acc limit (i + 1) + else + do_split acc limit i + and do_split acc limit i = + if limit <= 0 then + if i = l then + List.rev acc + else + List.rev (String.sub path i (l - i) :: acc) + else + do_component acc (pred limit) i i + and do_component acc limit i j = + if j >= l then + if i = j then + List.rev acc + else + List.rev (String.sub path i (j - i) :: acc) + else if String.get path j = delim then + do_slashes (String.sub path i (j - i) :: acc) limit j + else + do_component acc limit i (j + 1) in + if limit > 0 then + do_slashes [] limit 0 + else + [ path ] + +let split_path path = split '/' path + +let map_option ~f = function + | None -> None + | Some x -> Some (f x) + +let iter_option ~f = function + | None -> () + | Some x -> f x + +let unopt x = function + | None -> x + | Some x -> x + +let unopt_list l = + let may_cons xs x = match x with None -> xs | Some x -> x :: xs in + List.rev @@ List.fold_left may_cons [] l + +let filter_map f l = + let may_cons xs x = match f x with None -> xs | Some x -> x :: xs in + List.rev @@ List.fold_left may_cons [] l + +let display_paragraph ppf description = + Format.fprintf ppf "@[%a@]" + (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words) + (split ' ' description) + +let rec remove_elem_from_list nb = function + | [] -> [] + | l when nb <= 0 -> l + | _ :: tl -> remove_elem_from_list (nb - 1) tl diff --git a/src/utils/utils.mli b/src/utils/utils.mli new file mode 100644 index 000000000..a027b783f --- /dev/null +++ b/src/utils/utils.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val remove_dir: string -> unit Lwt.t + +val create_dir: ?perm:int -> string -> unit Lwt.t +val create_file: ?perm:int -> string -> string -> unit Lwt.t + +val termination_thread: int Lwt.t +val exit: int -> 'a + +module StringMap : Map.S with type key = string + +(** Splits a string on slashes, grouping multiple slashes, and + ignoring slashes at the beginning and end of string. *) +val split_path: string -> string list + +(** Splits a string on a delimier character, grouping multiple + delimiters, and ignoring delimiters at the beginning and end of + string, if [limit] is passed, stops after [limit] split(s). *) +val split: char -> ?limit: int -> string -> string list + +val map_option: f:('a -> 'b) -> 'a option -> 'b option +val iter_option: f:('a -> unit) -> 'a option -> unit +val unopt: 'a -> 'a option -> 'a +val unopt_list: 'a option list -> 'a list + +val display_paragraph: Format.formatter -> string -> unit + +(** [remove nb list] remove the first [nb] elements from the list [list]. *) +val remove_elem_from_list: int -> 'a list -> 'a list + +val filter_map: ('a -> 'b option) -> 'a list -> 'b list + diff --git a/test/.merlin b/test/.merlin new file mode 100644 index 000000000..eb974a4dc --- /dev/null +++ b/test/.merlin @@ -0,0 +1,22 @@ +REC +S . +B . +S ../src/utils +B ../src/utils +S ../src/node/db +B ../src/node/db +S ../src/node/net +B ../src/node/net +S ../src/node/updater +B ../src/node/updater +S ../src/node/shell +B ../src/node/shell +S ../src/proto +B ../src/proto +S ../src/client +B ../src/client +S ../src/client/embedded +B ../src/client/embedded +FLG -w -40 +PKG lwt +PKG sodium \ No newline at end of file diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 000000000..893f8015a --- /dev/null +++ b/test/Makefile @@ -0,0 +1,187 @@ + +TESTS := store context state basic basic.sh + +all: test + +INCLUDES = $(patsubst %, -I %, $(SOURCE_DIRECTORIES)) +OCAMLFLAGS = \ + -g -safe-string -w -40 \ + ${INCLUDES} \ + $(patsubst %, -package %, $(PACKAGES)) \ + ${EXTRA_OCAMLFLAGS} + +SOURCE_DIRECTORIES := $(addprefix ../src/, \ + utils \ + compiler \ + node/db \ + node/net \ + node/updater \ + node/shell \ + proto \ +) + +PACKAGES := \ + base64 \ + calendar \ + cohttp.lwt \ + compiler-libs.optcomp \ + config-file \ + cryptokit \ + cstruct \ + dynlink \ + ezjsonm \ + git \ + irmin.unix \ + lwt \ + lwt.unix \ + ocplib-endian \ + ocplib-ocamlres \ + ocplib-json-typed \ + ocplib-resto.directory \ + sodium \ + unix + +############################################################################ +## External packages + +NODELIB := ../src/utils.cmxa ../src/compiler.cmxa ../src/node.cmxa +CLIENTLIB := ../src/client.cmxa \ + $(patsubst ../src/client/embedded/%/, \ + ../src/proto/client_embedded_proto_%.cmxa, \ + $(shell ls -d ../src/client/embedded/*/)) \ + $(patsubst ../src/client/embedded/%/, \ + ../src/client/embedded/client_%.cmx, \ + $(shell ls -d ../src/client/embedded/*/)) + +${NODELIB} ${CLIENTLIB}: + ${MAKE} -C ../src $@ + +.PHONY: build-test run-test test +build-test: ${addprefix build-test-,${TESTS}} +run-test: + @$(patsubst %,${MAKE} run-test-% &&, ${TESTS}) \ + echo && echo "Success" && echo +test: + @${MAKE} --no-print-directory build-test + @${MAKE} --no-print-directory run-test + +############################################################################ +## Store test program + +.PHONY:build-test-store run-test-store +build-test-store: test-store +run-test-store: + ./test-store + +TEST_STORE_INTFS = + +TEST_STORE_IMPLS = \ + test.ml \ + test_store.ml \ + +${TEST_STORE_IMPLS:.ml=.cmx}: ${NODELIB} +test-store: ${NODELIB} ${TEST_STORE_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + rm -f test-store + + +############################################################################ +## Context test program + +.PHONY:build-test-context run-test-context +build-test-context: test-context +run-test-context: + ./test-context + +TEST_CONTEXT_INTFS = + +TEST_CONTEXT_IMPLS = \ + test.ml \ + test_context.ml \ + +${TEST_CONTEXT_IMPLS:.ml=.cmx}: ${NODELIB} +test-context: ${NODELIB} ${TEST_CONTEXT_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + rm -f test-context + + +############################################################################ +## State test program + +.PHONY:build-test-state run-test-state +build-test-state: test-state +run-test-state: + ./test-state + +TEST_STATE_INTFS = + +TEST_STATE_IMPLS = \ + test.ml \ + test_state.ml \ + +${TEST_STATE_IMPLS:.ml=.cmx}: ${NODELIB} +test-state: ${NODELIB} ../src/proto/embedded_proto_demo.cmxa ${TEST_STATE_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + rm -f test-state + + +############################################################################ +## Basic-client-functionality test program + +.PHONY:build-test-basic.sh run-test-basic.sh +build-test-basic.sh: +run-test-basic.sh: + ./test-basic.sh + +.PHONY:build-test-basic run-test-basic +build-test-basic: test-basic +run-test-basic: + ./test-basic + +TEST_BASIC_INTFS = + +TEST_BASIC_IMPLS = \ + test.ml \ + test_basic.ml \ + +test-basic \ +${TEST_BASIC_IMPLS:.ml=.cmx}: \ + SOURCE_DIRECTORIES+=../src/client ../src/client/embedded/ + +${TEST_BASIC_IMPLS:.ml=.cmx}: ${NODELIB} ${CLIENTLIB} +test-basic: ${NODELIB} ${CLIENTLIB} ${TEST_BASIC_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + rm -f test-basic + + +############################################################################ +## Generic rules + +test.cmx: test.cmi + +%.cmx: %.ml + ocamlfind ocamlopt ${OCAMLFLAGS} -c $< + +%.cmo: %.ml + ocamlfind ocamlc ${OCAMLFLAGS} -c $< + +%.cmi: %.mli + ocamlfind ocamlc ${OCAMLFLAGS} -c $< + +clean:: + -rm -f *.cm* + +-include .depend +.depend: $(wildcard *.ml *.mli) + ocamldep $^ > .depend + +clean:: + -rm .depend diff --git a/test/launch.sh b/test/launch.sh new file mode 100755 index 000000000..c8f13b7a8 --- /dev/null +++ b/test/launch.sh @@ -0,0 +1,9 @@ +COMMAND='gnome-terminal' +COUNT=2 +for i in $(seq 1 $COUNT) +do + SUBCOMMAND="./tezos-node -net-port $((9900 + i)) -net-local-discovery true -rpc-port $((8800 + i)) -net-expected-connections $(($COUNT - 1)) -base-dir /tmp/tezos_$i" + COMMAND="$COMMAND --tab -e '$SUBCOMMAND'" +done +echo $COMMAND +eval $COMMAND diff --git a/test/launch_daemon.sh b/test/launch_daemon.sh new file mode 100755 index 000000000..0c9f348b8 --- /dev/null +++ b/test/launch_daemon.sh @@ -0,0 +1,19 @@ +#! /bin/sh + +set -e + +DIR=$(dirname "$0") +cd "${DIR}" + +CLIENT_DIR=$(mktemp -d /tmp/tezos_client.XXXXXXXXXX) + +cleanup() { + rm -fr ${CLIENT_DIR} +} +trap cleanup EXIT QUIT INT + +# export LWT_LOG="client.endorsement -> info; client.mining -> info" + +CLIENT="../tezos-client -base-dir ${CLIENT_DIR}" +${CLIENT} bootstrap +${CLIENT} launch daemon $@ diff --git a/test/myocaml-parser b/test/myocaml-parser new file mode 100755 index 000000000..1fd800768 --- /dev/null +++ b/test/myocaml-parser @@ -0,0 +1,9 @@ +#! /bin/sh + +TESTDIR="$(dirname $0)" +TEZOSDIR="$(dirname $TESTDIR)" + +export OCAMLRUNPARAM=b +export LWT_LOG="* -> debug" + +opam config --switch 4.01.0 exec -- make -C ${TEZOSDIR} top-parser diff --git a/test/sandbox.json b/test/sandbox.json new file mode 100644 index 000000000..cd431ad24 --- /dev/null +++ b/test/sandbox.json @@ -0,0 +1,5 @@ +{ + "time_between_slots" : 10, + "cycle_length" : 128, + "first_free_mining_slot" : 4 +} diff --git a/test/scripts/fail.tez b/test/scripts/fail.tez new file mode 100644 index 000000000..1ac2a4188 --- /dev/null +++ b/test/scripts/fail.tez @@ -0,0 +1,9 @@ +parameter void +code + { # This contract will never accept a incoming transaction + FAIL ; + # Alas, FAIL is not (yet?) polymorphic, and we need to keep unused + # instructions for the sake of typing... + CDR ; PUSH VOID ; PAIR } +return void +storage VOID \ No newline at end of file diff --git a/test/scripts/hardlimit.tez b/test/scripts/hardlimit.tez new file mode 100644 index 000000000..3d47d9c88 --- /dev/null +++ b/test/scripts/hardlimit.tez @@ -0,0 +1,8 @@ +parameter void +code + { # This contract stop to accept transactions after N incoming transactions + CDR ; PUSH (Uint32 1) ; SWAP ; SUB ; + DUP ; PUSH (Uint32 0) ; COMPARE ; EQ ; IF { FAIL } {} ; + PUSH VOID ; PAIR } +return void +storage uint32 \ No newline at end of file diff --git a/test/scripts/noop.tez b/test/scripts/noop.tez new file mode 100644 index 000000000..72c865098 --- /dev/null +++ b/test/scripts/noop.tez @@ -0,0 +1,7 @@ +parameter void +code + { # This is a noop contract + CDR ; PUSH VOID ; PAIR + } +return void +storage VOID \ No newline at end of file diff --git a/test/test-basic.sh b/test/test-basic.sh new file mode 100755 index 000000000..835824a0c --- /dev/null +++ b/test/test-basic.sh @@ -0,0 +1,79 @@ +#! /bin/sh + +set -e + +DIR=$(dirname "$0") +cd "${DIR}" + +DATA_DIR=$(mktemp -d /tmp/tezos_node.XXXXXXXXXX) +CLIENT_DIR=$(mktemp -d /tmp/tezos_client.XXXXXXXXXX) + +cleanup() { + rm -fr ${DATA_DIR} ${CLIENT_DIR} + [ -z "${NODE_PID}" ] || kill -9 ${NODE_PID} +} +trap cleanup EXIT QUIT INT + +NODE=../tezos-node +CLIENT="../tezos-client -base-dir ${CLIENT_DIR}" + +CUSTOM_PARAM="-sandbox-param ./sandbox.json " +${NODE} -sandbox ${DATA_DIR} ${CUSTOM_PARAM} -rpc-port 8732 > LOG 2>&1 & +NODE_PID="$!" + +sleep 3 + +${CLIENT} list versions +${CLIENT} bootstrap + +KEY1=foo +KEY2=bar + +${CLIENT} gen keys ${KEY1} +${CLIENT} gen keys ${KEY2} + +${CLIENT} list known identities + +${CLIENT} transfer 1000 from bootstrap1 to ${KEY1} +${CLIENT} transfer 2000 from bootstrap1 to ${KEY2} + +assert() { + local expected="$1" + local result="$(cat)" + if [ "${result}" != "${expected}" ]; then + echo "Unexpected result: \"${result}\"" + echo "Expected: \"${expected}\"" + exit 2 + fi +} + +${CLIENT} get balance ${KEY1} | assert "1,000.00 ꜩ" +${CLIENT} get balance ${KEY2} | assert "2,000.00 ꜩ" + +${CLIENT} transfer 1000 from ${KEY2} to ${KEY1} + +${CLIENT} get balance ${KEY1} | assert "2,000.00 ꜩ" +${CLIENT} get balance ${KEY2} | assert "999.95 ꜩ" + +# Should fail +# ${CLIENT} transfer 999.95 from ${KEY2} to ${KEY1} + +${CLIENT} mine for bootstrap1 + +${CLIENT} remember program noop file:scripts/noop.tez +${CLIENT} typecheck program noop +${CLIENT} originate contract noop \ + for ${KEY1} transfering 1000 from bootstrap1 \ + running noop +${CLIENT} transfer 10 from bootstrap1 to noop -arg "void" + +${CLIENT} originate contract hardlimit \ + for ${KEY1} transfering 1000 from bootstrap1 \ + running file:scripts/hardlimit.tez -init "3" +${CLIENT} transfer 10 from bootstrap1 to hardlimit -arg "void" +${CLIENT} transfer 10 from bootstrap1 to hardlimit -arg "void" +# ${CLIENT} transfer 10 from bootstrap1 to hardlimit -arg "void" # should fail + +echo +echo End of test +echo diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 000000000..1aab1716f --- /dev/null +++ b/test/test.ml @@ -0,0 +1,57 @@ + +let (>>=) = Lwt.bind + +let keep_dir = try ignore (Sys.getenv "KEEPDIR") ; true with _ -> false + +let () = Printexc.record_backtrace true + +(** Helpers for tests *) + +let log fmt = Format.eprintf fmt +let fail fmt = Format.kasprintf failwith fmt + +let run_test name f = + let base_dir = Filename.temp_file "tezos_test_" "" in + log "---- beginning of test %S in %s ----\n%!" name base_dir ; + Lwt_unix.unlink base_dir >>= fun () -> + Lwt_unix.mkdir base_dir 0o777 >>= fun () -> + Lwt.catch + (fun () -> f base_dir >>= fun () -> + log "[test succeeded]\n%!" ; + Lwt.return (Ok ())) + (function + | Failure msg -> + log "[test FAILED with %s]\n%!" msg ; + Printexc.print_backtrace stderr ; + flush stderr ; + Lwt.return (Error name) + | e -> + log "[test FAILED with exception %s]\n%!" (Printexc.to_string e) ; + Printexc.print_backtrace stderr ; + flush stderr ; + Lwt.return (Error name)) >>= fun r -> + (if not keep_dir then + Utils.remove_dir base_dir + else + Lwt.return_unit) >>= fun () -> + log "---- end of test %S ----\n%!" name ; + Lwt.return r + +let run prefix l = + let results = + List.map (fun (name, f) -> Lwt_main.run (run_test (prefix ^ name) f)) l in + let failed = + List.fold_left + (fun acc r -> + match r with + | Ok () -> acc + | Error name -> name :: acc) + [] results in + match failed with + | [] -> + Printf.printf "All tests succeeded\n%!" + | failed -> + Printf.printf "Some tests failed:\n"; + List.iter (Printf.printf "- %s\n") failed; + Printf.printf "%!"; + exit 1 diff --git a/test/test.mli b/test/test.mli new file mode 100644 index 000000000..2d122e38b --- /dev/null +++ b/test/test.mli @@ -0,0 +1,3 @@ +val log : ('a, Format.formatter, unit) format -> 'a +val fail : ('a, Format.formatter, unit, 'b) format4 -> 'a +val run : string -> (string * (string -> unit Lwt.t)) list -> unit diff --git a/test/test_basic.ml b/test/test_basic.ml new file mode 100644 index 000000000..e024a716c --- /dev/null +++ b/test/test_basic.ml @@ -0,0 +1,154 @@ + +open Client_embedded_proto_bootstrap +open Client_bootstrap +open Tezos_context +open Error_monad +open Hash + +let () = Random.self_init () + +let should_fail f t = + t >>= function + | Ok _ -> failwith "Expected error found success." + | Error error -> + if not (List.exists f error) then + failwith "@[Unexpected error@ %a@]" pp_print_error error + else begin + Format.printf "-> Failure (as expected)\n%!" ; + return () + end + +let fork_node () = + let init_timeout = 4 in + let data_dir = + Printf.sprintf + "%s/tezos_node_%6X" + (Filename.get_temp_dir_name ()) + (Random.int 0xFF_FF_FF) in + let log_file_name, log_file = Filename.open_temp_file "tezos_node_" ".log" in + let log_fd = Unix.descr_of_out_channel log_file in + let null_fd = Unix.(openfile "/dev/null" [O_RDONLY] 0o644) in + let pid = + Unix.create_process + Filename.(concat (dirname (Sys.getcwd ())) "tezos-node") + [| "tezos-node" ; + "-sandbox"; data_dir ; + "-sandbox-param"; "./sandbox.json"; + "-rpc-port"; "8732" |] + null_fd log_fd log_fd in + Printf.printf "Created node, pid: %d, log: %s\n%!" pid log_file_name ; + at_exit + (fun () -> + Unix.kill pid Sys.sigkill; + ignore (Sys.command (Printf.sprintf "rm -fr \"%s\"" data_dir))) ; + Printf.printf "Waiting %d seconds for its initialisation\n%!" init_timeout; + Unix.sleep init_timeout ; + match Unix.waitpid [Unix.WNOHANG] pid with + | 0, _ -> () + | pid, Unix.WEXITED x -> Printf.eprintf "Wait: %d, exit %d\n%!" pid x + | pid, Unix.WSIGNALED x -> Printf.eprintf "Wait: %d, signaled %d\n%!" pid x + | pid, Unix.WSTOPPED x -> Printf.eprintf "Wait: %d, stopped %d \n%!" pid x + +type account = { + name : string ; + secret_key : Sodium.secret Sodium.Sign.key ; + public_key : Sodium.public Sodium.Sign.key ; + public_key_hash : public_key_hash ; + contract : Contract.t ; +} + +let bootstrap_accounts () = + Client_proto_rpcs.Constants.bootstrap `Genesis + >>= fun accounts -> + let cpt = ref 0 in + Lwt.return + (List.map + (fun { Bootstrap.public_key_hash ; public_key ; secret_key } -> + incr cpt ; + let name = Printf.sprintf "bootstrap%d" !cpt in + { name ; contract = Contract.default_contract public_key_hash; + public_key_hash ; public_key ; secret_key }) + accounts) + +let create_account name = + let secret_key, public_key = Sodium.Sign.random_keypair () in + let public_key_hash = Ed25519.hash public_key in + let contract = Contract.default_contract public_key_hash in + Lwt.return { name ; contract ; public_key_hash ; public_key ; secret_key } + +let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount = + Cli_entries.message "Transfer %Ld from %s to %s (fee: %Ld)" + amount src.name target.name fee; + let fee = + match Tez.of_cents fee with + | Some x -> x + | None -> assert false in + let amount = + match Tez.of_cents amount with + | Some x -> x + | None -> assert false in + Client_proto_context.transfer + block + ~source:src.contract + ~src_pk:src.public_key + ~src_sk:src.secret_key + ~destination:target.contract + ~amount ~fee () + +let check_balance ?(block = `Prevalidation) account expected = + Client_proto_rpcs.Context.Contract.balance block account.contract >>=? fun balance -> + let balance = Tez.to_cents balance in + if balance <> expected then + failwith + "Unexpected balance for %s: %Ld (expected: %Ld)" + account.name balance expected + else begin + Cli_entries.message "Balance for %s: %Ld" account.name balance ; + return () + end + +let mine contract = + let block = `Head 0 in + Client_proto_rpcs.Context.level block >>=? fun level -> + let seed_nonce = Client_mining_forge.generate_seed_nonce () in + Client_mining_forge.forge_block + ~timestamp:(Time.now ()) ~seed_nonce ~src_sk:contract.secret_key + block contract.public_key_hash >>=? fun block_hash -> + Cli_entries.message "Injected %a" Block_hash.pp_short block_hash ; + return () + +let ecoproto_error f = function + | Register_client_embedded_proto_bootstrap.Ecoproto_error errors -> List.exists f errors + | _ -> false + +let main () = + fork_node () ; + bootstrap_accounts () >>= fun bootstrap_accounts -> + let bootstrap = List.hd bootstrap_accounts in + Format.printf "Received bootstrap key %a@." + Ed25519.Public_key_hash.pp_short bootstrap.public_key_hash ; + create_account "foo" >>= fun foo -> + create_account "bar" >>= fun bar -> + transfer ~src:bootstrap ~target:foo 1000_00L >>=? fun () -> + transfer ~src:bootstrap ~target:bar 2000_00L >>=? fun () -> + check_balance foo 1000_00L >>=? fun () -> + transfer ~src:bar ~target:foo 999_95L >>=? fun () -> + check_balance foo 1999_95L >>=? fun () -> + check_balance bar 1000_00L >>=? fun () -> + should_fail + (ecoproto_error (function Contract.Too_low_balance -> true | _ -> false)) + @@ transfer ~src:bar ~target:foo 1000_00L >>=? fun () -> + mine bootstrap >>=? fun () -> + print_endline "\nEnd of test\n" ; + return () + +let () = + try + Lwt_main.run ( + main () >>= function + | Error exns -> + Format.eprintf "%a@." pp_print_error exns ; + exit 1 + | Ok () -> Lwt.return_unit) + with Cli_entries.Command_failed msg -> + Format.eprintf "Error: %s@." msg ; diff --git a/test/test_context.ml b/test/test_context.ml new file mode 100644 index 000000000..c177207a9 --- /dev/null +++ b/test/test_context.ml @@ -0,0 +1,219 @@ + +open Utils +open Hash +open Context + +let (>>=) = Lwt.bind +let (>|=) = Lwt.(>|=) +let (//) = Filename.concat + +(** Basic blocks *) + +let genesis_block = + Block_hash.of_b48check + "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_protocol = + Protocol_hash.of_b48check + "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_time = + Time.of_seconds 0L + +let genesis = { + Store.time = genesis_time ; + block = genesis_block ; + protocol = genesis_protocol ; +} + +(** Context creation *) + +let block2 = + Block_hash.of_hex + "2222222222222222222222222222222222222222222222222222222222222222" + +let faked_block : Store.block_header = { + shell = { + net_id = Net genesis_block ; + predecessor = genesis_block ; + operations = [] ; + fitness = [] ; + timestamp = Time.of_seconds 0L ; + } ; + proto = MBytes.of_string "" ; +} + +let create_block2 idx = + checkout idx genesis_block >>= function + | None | Some (Error _) -> + Test.fail "checkout genesis_block" + | Some (Ok ctxt) -> + set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> + set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> + set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt -> + commit idx faked_block block2 ctxt + +let block3a = + Block_hash.of_hex + "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a" + +let create_block3a idx = + checkout idx block2 >>= function + | None | Some (Error _) -> + Test.fail "checkout block2" + | Some (Ok ctxt) -> + del ctxt ["a"; "b"] >>= fun ctxt -> + set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt -> + commit idx faked_block block3a ctxt + +let block3b = + Block_hash.of_hex + "3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b" + +let block3c = + Block_hash.of_hex + "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c" + +let create_block3b idx = + checkout idx block2 >>= function + | None | Some (Error _) -> + Test.fail "checkout block3b" + | Some (Ok ctxt) -> + del ctxt ["a"; "c"] >>= fun ctxt -> + set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt -> + commit idx faked_block block3b ctxt + +let wrap_context_init f base_dir = + let root = base_dir // "context" in + Context.init root >>= fun idx -> + Context.create_genesis_context idx genesis genesis_protocol >>= fun _ -> + create_block2 idx >>= fun () -> + create_block3a idx >>= fun () -> + create_block3b idx >>= fun () -> + commit_invalid idx faked_block block3c [Error_monad.Unclassified "TEST"] >>= fun () -> + f idx + + +(** Simple test *) + +let c = function + | None -> None + | Some s -> Some (MBytes.to_string s) + +let test_simple idx = + checkout idx block2 >>= function + | None | Some (Error _) -> + Test.fail "checkout block2" + | Some (Ok ctxt) -> + get ctxt ["version"] >>= fun version -> + assert (c version = Some "0.0"); + get ctxt ["a";"b"] >>= fun novembre -> + assert (c novembre = Some "Novembre"); + get ctxt ["a";"c"] >>= fun juin -> + assert (c juin = Some "Juin"); + Lwt.return () + +let test_continuation idx = + checkout idx block3a >>= function + | None | Some (Error _) -> + Test.fail "checkout block3a" + | Some (Ok ctxt) -> + get ctxt ["version"] >>= fun version -> + assert (c version = Some "0.0"); + get ctxt ["a";"b"] >>= fun novembre -> + assert (c novembre = None); + get ctxt ["a";"c"] >>= fun juin -> + assert (c juin = Some "Juin"); + get ctxt ["a";"d"] >>= fun mars -> + assert (c mars = Some "Mars"); + Lwt.return () + +let test_fork idx = + checkout idx block3b >>= function + | None | Some (Error _) -> + Test.fail "checkout block3b" + | Some (Ok ctxt) -> + get ctxt ["version"] >>= fun version -> + assert (c version = Some "0.0"); + get ctxt ["a";"b"] >>= fun novembre -> + assert (c novembre = Some "Novembre"); + get ctxt ["a";"c"] >>= fun juin -> + assert (c juin = None); + get ctxt ["a";"d"] >>= fun mars -> + assert (c mars = Some "Février"); + Lwt.return () + +let test_replay idx = + checkout idx genesis_block >>= function + | None | Some (Error _) -> + Test.fail "checkout genesis_block" + | Some (Ok ctxt0) -> + set ctxt0 ["version"] (MBytes.of_string "0.0") >>= fun ctxt1 -> + set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt2 -> + set ctxt2 ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt3 -> + set ctxt3 ["a"; "d"] (MBytes.of_string "July") >>= fun ctxt4a -> + set ctxt3 ["a"; "d"] (MBytes.of_string "Juillet") >>= fun ctxt4b -> + set ctxt4a ["a"; "b"] (MBytes.of_string "November") >>= fun ctxt5a -> + get ctxt4a ["a";"b"] >>= fun novembre -> + assert (c novembre = Some "Novembre"); + get ctxt5a ["a";"b"] >>= fun november -> + assert (c november = Some "November"); + get ctxt5a ["a";"d"] >>= fun july -> + assert (c july = Some "July"); + get ctxt4b ["a";"b"] >>= fun novembre -> + assert (c novembre = Some "Novembre"); + get ctxt4b ["a";"d"] >>= fun juillet -> + assert (c juillet = Some "Juillet"); + Lwt.return () + +let test_list idx = + checkout idx genesis_block >>= function + | None | Some (Error _) -> + Test.fail "checkout genesis_block" + | Some (Ok ctxt) -> + set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> + set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> + set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre") >>= fun ctxt -> + set ctxt ["f";] (MBytes.of_string "Avril") >>= fun ctxt -> + set ctxt ["g"; "h"] (MBytes.of_string "Avril") >>= fun ctxt -> + list ctxt [[]] >>= fun l -> + assert (l = [["a"];["f"];["g"]]); + list ctxt [["a"]] >>= fun l -> + assert (l = [["a";"b"]; ["a";"c"]; ["a";"d"]]); + list ctxt [["f"]] >>= fun l -> + assert (l = []); + list ctxt [["g"]] >>= fun l -> + assert (l = [["g";"h"]]); + list ctxt [["i"]] >>= fun l -> + assert (l = []); + list ctxt [["a"];["g"]] >>= fun l -> + assert (l = [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]]); + Lwt.return () + +let test_invalid idx = + checkout idx block3c >>= function + | Some (Error [exn]) -> + assert (exn = Error_monad.Unclassified "TEST") ; + Lwt.return_unit + | Some (Error _) -> + Test.fail "checkout unexpected error in block3c" + | Some (Ok _) -> + Test.fail "checkout valid block3c" + | None -> + Test.fail "checkout absent block3c" + + + +(******************************************************************************) + +let tests : (string * (index -> unit Lwt.t)) list = [ + "simple", test_simple ; + "continuation", test_continuation ; + "fork", test_fork ; + "replay", test_replay ; + "list", test_list ; + "invalid", test_invalid ; +] + +let res = + Test.run "context." (List.map (fun (s, f) -> s, wrap_context_init f) tests) diff --git a/test/test_p2p.ml b/test/test_p2p.ml new file mode 100644 index 000000000..a1bde819e --- /dev/null +++ b/test/test_p2p.ml @@ -0,0 +1,151 @@ +(* +ocamlfind ocamlopt \ + -package 'lwt,lwt.unix,lwt.log,ezjsonm,ocplib-endian,config-file,cryptokit,cstruct' \ + ../core/utils.cmx ../core/logs.cmx ../core/mMBytes.cmx ../core/json.cmx \ + netbits.cmx p2p.cmx test_p2p.ml -linkpkg \ + -o test_p2p && ./test_p2p +*) + +open Lwt +open P2p +open Netbits +open Printf + +let interval min max cb = + let rec loop acc n = + if n > max then List.rev acc + else loop ((n, cb n) :: acc) (n + 1) in + loop [] min + +let rec join_map acc = function + | [] -> return (List.rev acc) + | (i, t) :: ts -> t >>= fun v -> join_map ((i, v) :: acc) ts + +let show_peers creds net = + Printf.printf " - Network of %s\n%!" creds ; + let peers = peers net in + peers |> List.iter @@ fun peer -> + let addr, port, _ = peer_info peer net in + Printf.printf " * %s @ %s:%i\n%!" creds addr port + + +(* launch 15 peers who originally know all the others, make everyone + send toto, and wait for everyone to receive one toto *) +let toto () = + let known_peers = + interval 0 15 (fun i -> ("127.0.0.1", 4440 + i)) |> List.split |> snd + in + let net i = + bootstrap + { incoming_port = Some (4440 + i) ; + discovery_port = None ; + supported_versions = [ "TEST", 0, 0 ] ; + known_peers; + peers_file = sprintf "test_peers_toto_%d.json" i } + { max_packet_size = 10_000 ; + peer_answer_timeout = 2. ; + expected_connections = 5 ; + min_connections = 2 ; + max_connections = 20 ; + blacklist_time = 30. } + in + let nets = interval 0 15 (fun i -> net i) in + printf "---- Networks created\n%!" ; + join_map [] nets >>= fun nets -> + printf "---- Networks bootstrapped\n%!" ; + List.iter (fun (_, net) -> broadcast [ B (MBytes.of_string "TOTO") ] net) nets ; + printf "---- Messages sent\n%!" ; + let recv (i, net) = i, recv net >>= fun (_, m) -> + Printf.printf "user_%d received %s\n%!" i (Netbits.to_string m) ; + return m + in + let receptions = List.map recv nets in + join_map [] receptions >>= fun msgs -> + printf "---- Messages received\n%!" ; + let shutdowns = List.map (fun (i, net) -> i, shutdown net) nets in + join_map [] shutdowns >>= fun _ -> + printf "---- Networks shutdown\n%!" ; + return () + +(* launch 15 peers who originally know only one another, make everyone + connect to at least 10 others *) +let boot () = + let net i = + bootstrap + { incoming_port = Some (4440 + i) ; + discovery_port = None ; + supported_versions = [ "TEST", 0, 0 ] ; + known_peers = [ "127.0.0.1", 4440 + ((i + 1) mod 16) ] ; + peers_file = sprintf "test_peers_boot_%d.json" i } + { max_packet_size = 10_000 ; + peer_answer_timeout = 2. ; + expected_connections = 10 ; + min_connections = 2 ; + max_connections = 20 ; + blacklist_time = 30. } + in + let nets = interval 0 15 (fun i -> net i) in + printf "---- Networks created\n%!" ; + join_map [] nets >>= fun nets -> + printf "---- Networks bootstrapped\n%!" ; + List.iter (fun (i, net) -> show_peers (sprintf "user_%d" i) net) nets ; + let shutdowns = List.map (fun (i, net) -> i, shutdown net) nets in + join_map [] shutdowns >>= fun _ -> + printf "---- Networks shutdown\n%!" ; + return () + +(* the same as above, but five nodes have no input port, and some + known addresses are bad ones *) +let boot_with_unreachable () = + let net i = + bootstrap + { incoming_port = if i > 10 then None else Some (4440 + i) ; + discovery_port = None ; + supported_versions = [ "TEST", 0, 0 ] ; + known_peers = [ "127.0.0.1", 4440 + ((i + 1) mod 10) ; + "127.0.0.1", 9999 ] ; + peers_file = sprintf "test_peers_boot_%d.json" i } + { max_packet_size = 10_000 ; + peer_answer_timeout = 2. ; + expected_connections = 10 ; + min_connections = 5 ; + max_connections = 15 ; + blacklist_time = 30. } + in + let nets = interval 0 15 (fun i -> net i) in + printf "---- Networks created\n%!" ; + join_map [] nets >>= fun nets -> + printf "---- Networks bootstrapped\n%!" ; + List.iter (fun (i, net) -> show_peers (sprintf "user_%d" i) net) nets ; + let shutdowns = List.map (fun (i, net) -> i, shutdown net) nets in + join_map [] shutdowns >>= fun _ -> + printf "---- Networks shutdown\n%!" ; + return () + +(* connect to ten peers, only by using local discovery *) +let boot_by_discovery () = + let net i = + bootstrap + { incoming_port = Some (4440 + i) ; + discovery_port = Some 121212 ; + supported_versions = [ "TEST", 0, 0 ] ; + known_peers = [] ; + peers_file = sprintf "test_peers_boot_%d.json" i } + { max_packet_size = 10_000 ; + peer_answer_timeout = 2. ; + expected_connections = 10 ; + min_connections = 5 ; + max_connections = 15 ; + blacklist_time = 30. } + in + let nets = interval 0 15 (fun i -> net i) in + printf "---- Networks created\n%!" ; + join_map [] nets >>= fun nets -> + printf "---- Networks bootstrapped\n%!" ; + List.iter (fun (i, net) -> show_peers (sprintf "user_%d" i) net) nets ; + let shutdowns = List.map (fun (i, net) -> i, shutdown net) nets in + join_map [] shutdowns >>= fun _ -> + printf "---- Networks shutdown\n%!" ; + return () + +let _ = Lwt_main.run (boot_by_discovery ()) diff --git a/test/test_state.ml b/test/test_state.ml new file mode 100644 index 000000000..791e5ded3 --- /dev/null +++ b/test/test_state.ml @@ -0,0 +1,653 @@ + + +open Utils +open Hash +open Error_monad + +let (//) = Filename.concat + +(** Basic blocks *) + +let genesis_block = + Block_hash.of_b48check + "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_protocol = + Protocol_hash.of_b48check + "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_time = + Time.of_seconds 0L + +module Proto = (val Updater.get_exn genesis_protocol) + +let genesis = { + Store.time = genesis_time ; + block = genesis_block ; + protocol = genesis_protocol ; +} + +let incr_fitness fitness = + let new_fitness = + match fitness with + | [ _ ; fitness ] -> + Data_encoding.Binary.of_bytes Data_encoding.int64 fitness + |> Utils.unopt 0L + |> Int64.succ + |> Data_encoding.Binary.to_bytes Data_encoding.int64 + | _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L + in + [ MBytes.of_string "\000" ; new_fitness ] + +let incr_timestamp timestamp = + Time.add timestamp (Random.int64 10L) + +let operation op = + let op : Store.operation = { + shell = { net_id = Net genesis_block } ; + proto = MBytes.of_string op ; + } in + Store.Operation.hash op, + op, + Store.Operation.to_bytes op + +let block state ?(operations = []) pred_hash pred name : Store.block_header = + let fitness = incr_fitness pred.Store.shell.fitness in + let timestamp = incr_timestamp pred.Store.shell.timestamp in + { shell = { + net_id = pred.shell.net_id ; + predecessor = pred_hash ; + timestamp ; operations; fitness } ; + proto = MBytes.of_string name ; + } + +let build_chain state tbl otbl pred names = + Lwt_list.fold_left_s + (fun (pred_hash, pred) name -> + begin + let oph, op, bytes = operation name in + State.Operation.store state bytes >>=? fun _changed -> + assert (_changed = Some (oph, op)) ; + State.Operation.mark_invalid state oph [] >>= fun _changed -> + assert _changed; + Hashtbl.add otbl name (oph, Error []) ; + let block = block ~operations:[oph] state pred_hash pred name in + let hash = Store.Block.hash block in + State.Block.store state (Store.Block.to_bytes block) >>=? fun _changed -> + assert (_changed = Some (hash, block)) ; + State.Valid_block.store_invalid state hash [] >>= fun _changed -> + assert _changed ; + Hashtbl.add tbl name (hash, block) ; + return (hash, block) + end >>= function + | Ok v -> Lwt.return v + | Error err -> + Error_monad.pp_print_error Format.err_formatter err ; + assert false) + pred + names >>= fun _ -> + Lwt.return () + +let block state ?(operations = []) (pred: State.Valid_block.t) name + : State.Block. t = + let fitness = incr_fitness pred.fitness in + let timestamp = incr_timestamp pred.timestamp in + { shell = { net_id = pred.net_id ; + predecessor = pred.hash ; + timestamp ; operations; fitness } ; + proto = MBytes.of_string name ; + } + +let build_valid_chain state net tbl vtbl otbl pred names = + Lwt_list.fold_left_s + (fun pred name -> + begin + let oph, op, bytes = operation name in + State.Operation.store state bytes >>=? fun _changed -> + assert (_changed = Some (oph, op)) ; + State.Net.Mempool.add net oph >>= fun _changed -> + assert _changed ; + Hashtbl.add otbl name (oph, Ok op) ; + let block = block state ~operations:[oph] pred name in + let hash = Store.Block.hash block in + State.Block.store state (Store.Block.to_bytes block) >>=? fun _changed -> + assert (_changed = Some (hash, block)) ; + Hashtbl.add tbl name (hash, block) ; + Lwt.return (Proto.parse_block_header block) >>=? fun block_header -> + Proto.apply pred.context block_header [] >>=? fun ctxt -> + State.Valid_block.store state hash ctxt >>=? fun vblock -> + Hashtbl.add vtbl name vblock ; + return vblock + end >>= function + | Ok v -> Lwt.return v + | Error err -> + Error_monad.pp_print_error Format.err_formatter err ; + assert false) + pred + names >>= fun _ -> + Lwt.return () + +let build_example_tree state net = + let tbl = Hashtbl.create 23 in + let vtbl = Hashtbl.create 23 in + let otbl = Hashtbl.create 23 in + State.Net.Blockchain.genesis net >>= fun genesis -> + let chain = [ "A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ] in + build_valid_chain state net tbl vtbl otbl genesis chain >>= fun () -> + let a3 = Hashtbl.find vtbl "A3" in + let chain = [ "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] in + build_valid_chain state net tbl vtbl otbl a3 chain >>= fun () -> + let b7 = Hashtbl.find tbl "B7" in + let chain = [ "C1" ; "C2" ; "C3" ; "C4" ; "C5" ; "C6" ; "C7" ; "C8" ] in + build_chain state tbl otbl b7 chain >>= fun () -> + let pending_op = "PP" in + let oph, op, bytes = operation pending_op in + State.Operation.store state bytes >>= fun _changed -> + assert (_changed = Ok (Some (oph, op))) ; + Hashtbl.add otbl pending_op (oph, Ok op) ; + State.Net.Mempool.add net oph >>= fun _changed -> + assert _changed ; + Lwt.return (tbl, vtbl, otbl) + +type state = { + block: (string, Block_hash.t * Store.block_header) Hashtbl.t ; + operation: (string, Operation_hash.t * Store.operation tzresult) Hashtbl.t ; + vblock: (string, State.Valid_block.t) Hashtbl.t ; + state: State.t ; + net: State.Net.t ; + init: unit -> State.t Lwt.t; +} + +let block s = Hashtbl.find s.block +let vblock s = Hashtbl.find s.vblock +let operation s = Hashtbl.find s.operation + +exception Found of string +let rev_find s h = + try + Hashtbl.iter (fun k (bh,_) -> + if Block_hash.equal bh h then raise (Found k)) + s.block ; + Format.asprintf "genesis(%a)" Block_hash.pp_short h + with Found s -> s + +let blocks s = + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block [] + |> List.sort Pervasives.compare + +let vblocks s = + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock [] + |> List.sort Pervasives.compare + +let operations s = + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation [] + |> List.sort Pervasives.compare + +let wrap_state_init f base_dir = + begin + let store_root = base_dir // "store" in + let context_root = base_dir // "context" in + let init () = + State.read + ~ttl:(3600 * 24) + ~request_operations: (fun _ -> assert false) + ~request_blocks: (fun _ -> assert false) + ~store_root + ~context_root + () in + init () >>= fun state -> + State.Net.create state genesis >>=? fun net -> + State.Net.activate net ; + build_example_tree state net >>= fun (block, vblock, operation) -> + f { state ; net ; block ; vblock ; operation ; init } >>=? fun s -> + State.shutdown s.state >>= fun () -> + return () + end >>= function + | Ok () -> Lwt.return_unit + | Error err -> + Test.fail "%a@." Error_monad.pp_print_error err + +let save_reload s = + State.shutdown s.state >>= fun () -> + s.init () >>= fun state -> + State.Net.create state genesis >>=? fun net -> + let s = { s with state ; net } in + return s + +let test_init (s: state) = + return s + +let test_read_operation (s: state) = + Lwt_list.iter_s (fun (name, (oph, op)) -> + State.Operation.read s.state oph >>= function + | None -> + Test.fail "Cannot read block %s" name + | Some { Time.data } -> + if op <> data then + Test.fail "Incorrect operation read %s" name ; + Lwt.return_unit) + (operations s) >>= fun () -> + return s + + + +(****************************************************************************) + +(** State. *) + +let test_read_block (s: state) = + Lwt_list.iter_s (fun (name, (hash, block)) -> + begin + State.Block.read s.state hash >>= function + | None -> + Test.fail "Cannot read block %s" name + | Some { Time.data = block' ; time } -> + if not (Store.Block.equal block block') then + Test.fail "Error while reading block %s" name ; + Test.log "Read block %s %a\n" name Time.pp_hum time; + Lwt.return_unit + end >>= fun () -> + let vblock = + try Some (vblock s name) + with Not_found -> None in + State.Valid_block.read s.state hash >>= function + | None -> + Test.fail "Cannot read %s" name + | Some (Error _) -> + if vblock <> None then + Test.fail "Error while reading valid block %s" name ; + Test.log "Read invalid block %s\n" name ; + Lwt.return_unit + | Some (Ok _vblock') -> + match vblock with + | None -> + Test.fail "Error while reading invalid block %s" name + | Some _vblock -> + Test.log "Read valid block %s\n" name ; + Lwt.return_unit + ) (blocks s) >>= fun () -> + return s + + +(****************************************************************************) + +(** State.successors *) + +let compare s kind name succs l = + if Block_hash_set.cardinal succs <> List.length l then + Test.fail "unexpected %ssuccessors size (%s: %d %d)" + kind name (Block_hash_set.cardinal succs) (List.length l) ; + List.iter + (fun bname -> + let bh = fst @@ block s bname in + if not (Block_hash_set.mem bh succs) then + Test.fail "missing block in %ssuccessors (%s: %s)" kind name bname) + l +let test_successors s = + let test s name expected invalid_expected = + let b = vblock s name in + State.Valid_block.read s.state b.hash >>= function + | None | Some (Error _) -> + Test.fail "Failed while reading block %s" name + | Some (Ok { successors ; invalid_successors}) -> + compare s "" name successors expected ; + compare s "invalid " name invalid_successors invalid_expected ; + Lwt.return_unit + + in + test s "A1" ["A2"] [] >>= fun () -> + test s "A3" ["A4";"B1"] [] >>= fun () -> + test s "A8" [] [] >>= fun () -> + test s "B1" ["B2"] [] >>= fun () -> + test s "B7" ["B8"] ["C1"] >>= fun () -> + return s + + +(****************************************************************************) + +(** State.path *) + +let rec compare_path p1 p2 = match p1, p2 with + | [], [] -> true + | h1 :: p1, h2 :: p2 -> Block_hash.equal h1 h2 && compare_path p1 p2 + | _ -> false + +let test_path (s: state) = + let check_path h1 h2 p2 = + Test.log "check_path %s -> %s\n" h1 h2 ; + State.Block.path s.state (fst @@ block s h1) (fst @@ block s h2) >>= function + | Error _ -> + Test.fail "cannot compute path %s -> %s" h1 h2 ; + | Ok p1 -> + let p2 = List.map (fun b -> fst (block s b)) p2 in + if not (compare_path p1 p2) then Test.fail "bad path %s -> %s" h1 h2 ; + Lwt.return_unit in + check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () -> + check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () -> + check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> + check_path "A1" "C2" ["A2"; "A3"; "B1"; "B2"; "B3" ; "B4" ; + "B5" ; "B6" ; "B7" ; "C1" ; "C2" ] >>= fun () -> + return s + +let test_valid_path (s: state) = + let check_path h1 h2 p2 = + Test.log "check_path %s -> %s\n" h1 h2 ; + State.Valid_block.path s.state (vblock s h1) (vblock s h2) >>= function + | None -> + Test.fail "cannot compute path %s -> %s" h1 h2 ; + | Some (p: State.Valid_block.t list) -> + let p = List.map (fun b -> b.State.Valid_block.hash) p in + let p2 = List.map (fun b -> (vblock s b).hash) p2 in + if not (compare_path p p2) then Test.fail "bad path %s -> %s" h1 h2 ; + Lwt.return_unit in + check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () -> + check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () -> + check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> + return s + + +(****************************************************************************) + +(** State.ancestor *) + +let test_ancestor s = + let check_ancestor h1 h2 expected = + State.Block.common_ancestor + s.state (fst @@ block s h1) (fst @@ block s h2) >>= function + | Error _ -> + Test.fail "Cannot compure ancestor for %s %s" h1 h2 + | Ok a -> + if not (Block_hash.equal a (fst expected)) then + Test.fail "bad ancestor %s %s: found %s, expected %s" + h1 h2 (rev_find s a) (rev_find s @@ fst expected); + Test.log "Found the expected ancestor %s %s\n" h1 h2 ; + Lwt.return_unit in + let check_valid_ancestor h1 h2 expected = + State.Valid_block.common_ancestor + s.state (vblock s h1) (vblock s h2) >>= fun a -> + if not (Block_hash.equal a.hash expected.State.Valid_block.hash) then + Test.fail "bad ancestor %s %s" h1 h2 ; + Test.log "Found the expected valid ancestor %s %s\n" h1 h2 ; + Lwt.return_unit in + check_ancestor "A6" "B6" (block s "A3") >>= fun () -> + check_ancestor "B6" "A6" (block s "A3") >>= fun () -> + check_ancestor "A4" "B1" (block s "A3") >>= fun () -> + check_ancestor "B1" "A4" (block s "A3") >>= fun () -> + check_ancestor "A3" "B1" (block s "A3") >>= fun () -> + check_ancestor "B1" "A3" (block s "A3") >>= fun () -> + check_ancestor "A2" "B1" (block s "A2") >>= fun () -> + check_ancestor "B1" "A2" (block s "A2") >>= fun () -> + check_ancestor "C4" "B8" (block s "B7") >>= fun () -> + check_ancestor "B8" "C4" (block s "B7") >>= fun () -> + check_ancestor "C4" "A8" (block s "A3") >>= fun () -> + check_ancestor "A8" "C4" (block s "A3") >>= fun () -> + check_valid_ancestor "A6" "B6" (vblock s "A3") >>= fun () -> + check_valid_ancestor "B6" "A6" (vblock s "A3") >>= fun () -> + check_valid_ancestor "A4" "B1" (vblock s "A3") >>= fun () -> + check_valid_ancestor "B1" "A4" (vblock s "A3") >>= fun () -> + check_valid_ancestor "A3" "B1" (vblock s "A3") >>= fun () -> + check_valid_ancestor "B1" "A3" (vblock s "A3") >>= fun () -> + check_valid_ancestor "A2" "B1" (vblock s "A2") >>= fun () -> + check_valid_ancestor "B1" "A2" (vblock s "A2") >>= fun () -> + return s + + +(****************************************************************************) + +(** State.locator *) + +let test_locator s = + let check_locator h1 expected = + State.Block.block_locator + s.state (List.length expected) (fst @@ block s h1) >>= function + | Error _ -> + Test.fail "Cannot compute locator for %s" h1 + | Ok l -> + if List.length l <> List.length expected then + Test.fail "Invalid locator length %s (found: %d, expected: %d)" + h1 (List.length l) (List.length expected) ; + List.iter2 + (fun h h2 -> + if not (Block_hash.equal h (fst @@ block s h2)) then + Test.fail "Invalid locator %s (expectd: %s)" h1 h2) + l expected; + Lwt.return_unit in + let check_valid_locator h1 expected = + State.Valid_block.block_locator + s.state (List.length expected) (vblock s h1) >>= fun l -> + if List.length l <> List.length expected then + Test.fail "Invalid locator length %s (found: %d, expected: %d)" + h1 (List.length l) (List.length expected) ; + List.iter2 + (fun h h2 -> + if not (Block_hash.equal h (fst @@ block s h2)) then + Test.fail "Invalid locator %s (expectd: %s)" h1 h2) + l expected ; + Lwt.return_unit in + Printf.eprintf "Checking Block\n%!" ; + check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2";"A1"] >>= fun () -> + check_locator "B8" + ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () -> + check_locator "C8" + ["C8";"C7";"C6";"C5";"C4";"C3";"C2";"C1"; + "B7";"B6";"B4";"B2";"A3";"A1"] >>= fun () -> + check_locator "C8" ["C8";"C7";"C6";"C5";"C4"] >>= fun () -> + Printf.eprintf "Checking Valid_block\n%!" ; + check_valid_locator "A8" + ["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () -> + check_valid_locator "B8" + ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () -> + check_valid_locator "B8" ["B8";"B7";"B6";"B5";"B4"] >>= fun () -> + return s + + +(****************************************************************************) + +(** State.known_heads *) + +let compare s name heads l = + if Block_hash_map.cardinal heads <> List.length l then + Test.fail "unexpected known_heads size (%s: %d %d)" + name (Block_hash_map.cardinal heads) (List.length l) ; + List.iter + (fun bname -> + let hash = (vblock s bname).hash in + if not (Block_hash_map.mem hash heads) then + Test.fail "missing block in known_heads (%s: %s)" name bname) + l + +let test_known_heads s = + State.Valid_block.known_heads s.state >>= fun heads -> + compare s "initial" heads ["A8";"B8"] ; + State.shutdown s.state >>= fun () -> + s.init () >>= fun state -> + let s = { s with state } in + compare s "initial" heads ["A8";"B8"] ; + return s + + +(****************************************************************************) + +(** State.head/set_head *) + +let test_head s = + State.Net.Blockchain.head s.net >>= fun head -> + if not (Block_hash.equal head.hash genesis_block) then + Test.fail "unexpected head" ; + State.Net.Blockchain.set_head s.net (vblock s "A6") >>= fun _ -> + State.Net.Blockchain.head s.net >>= fun head -> + if not (Block_hash.equal head.hash (vblock s "A6").hash) then + Test.fail "unexpected head" ; + save_reload s >>=? fun s -> + State.Net.Blockchain.head s.net >>= fun head -> + if not (Block_hash.equal head.hash (vblock s "A6").hash) then + Test.fail "unexpected head" ; + return s + + +(****************************************************************************) + +(** State.mem *) + +let test_mem s = + let mem s x = + State.Net.Blockchain.mem s.net (fst @@ block s x) in + let test_mem s x = + mem s x >>= function + | true -> Lwt.return_unit + | false -> Test.fail "mem %s" x in + let test_not_mem s x = + mem s x >>= function + | false -> Lwt.return_unit + | true -> Test.fail "not (mem %s)" x in + test_not_mem s "A3" >>= fun () -> + test_not_mem s "A6" >>= fun () -> + test_not_mem s "A8" >>= fun () -> + test_not_mem s "B1" >>= fun () -> + test_not_mem s "B6" >>= fun () -> + test_not_mem s "B8" >>= fun () -> + State.Net.Blockchain.set_head s.net (vblock s "A8") >>= fun _ -> + test_mem s "A3" >>= fun () -> + test_mem s "A6" >>= fun () -> + test_mem s "A8" >>= fun () -> + test_not_mem s "B1" >>= fun () -> + test_not_mem s "B6" >>= fun () -> + test_not_mem s "B8" >>= fun () -> + State.Net.Blockchain.set_head s.net (vblock s "A6") >>= fun _ -> + test_mem s "A3" >>= fun () -> + test_mem s "A6" >>= fun () -> + test_not_mem s "A8" >>= fun () -> + test_not_mem s "B1" >>= fun () -> + test_not_mem s "B6" >>= fun () -> + test_not_mem s "B8" >>= fun () -> + State.Net.Blockchain.set_head s.net (vblock s "B6") >>= fun _ -> + test_mem s "A3" >>= fun () -> + test_not_mem s "A4" >>= fun () -> + test_not_mem s "A6" >>= fun () -> + test_not_mem s "A8" >>= fun () -> + test_mem s "B1" >>= fun () -> + test_mem s "B6" >>= fun () -> + test_not_mem s "B8" >>= fun () -> + State.Net.Blockchain.set_head s.net (vblock s "B8") >>= fun _ -> + test_mem s "A3" >>= fun () -> + test_not_mem s "A4" >>= fun () -> + test_not_mem s "A6" >>= fun () -> + test_not_mem s "A8" >>= fun () -> + test_mem s "B1" >>= fun () -> + test_mem s "B6" >>= fun () -> + test_mem s "B8" >>= fun () -> + save_reload s >>=? fun s -> + State.Net.Blockchain.head s.net >>= fun head -> + if not (Block_hash.equal head.hash (vblock s "B8").hash) then + Test.fail "Invalid head after save/load" ; + return s + + +(****************************************************************************) + +(** State.new *) + +let test_new s = + let test s h expected = + State.Valid_block.block_locator s.state 50 (vblock s h) >>= fun loc -> + State.Net.Blockchain.find_new s.net loc (List.length expected) >>= function + | Error _ -> + Test.fail "Failed to compute new blocks %s" h + | Ok blocks -> + if List.length blocks <> List.length expected then + Test.fail "Invalid locator length %s (found: %d, expected: %d)" + h (List.length blocks) (List.length expected) ; + List.iter2 + (fun h1 h2 -> + if not (Block_hash.equal h1 (vblock s h2).hash) then + Test.fail "Invalid locator %s (expected: %s)" h h2) + blocks expected ; + Lwt.return_unit + in + test s "A6" [] >>= fun () -> + Printf.eprintf "Set_head A8.\n%!" ; + State.Net.Blockchain.set_head s.net (vblock s "A8") >>= fun _ -> + test s "A6" ["A7";"A8"] >>= fun () -> + test s "A6" ["A7"] >>= fun () -> + test s "B4" ["A4"] >>= fun () -> + test s "B7" ["A4";"A5";"A6";"A7"] >>= fun () -> + return s + + +(****************************************************************************) + +(** State.mempool *) + +let compare s name mempool l = + if Operation_hash_set.cardinal mempool <> List.length l then + Test.fail "unexpected mempool size (%s: %d %d)" + name (Operation_hash_set.cardinal mempool) (List.length l) ; + List.iter + (fun oname -> + let oph = fst @@ operation s oname in + if not (Operation_hash_set.mem oph mempool) then + Test.fail "missing operation in mempool (%s: %s)" name oname) + l + +let test_mempool s = + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "initial" mempool + ["PP"; + "A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ; + "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ; + State.Net.Blockchain.set_head s.net (vblock s "A8") >>= fun _ -> + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "A8" mempool + ["PP"; "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ; + State.Net.Blockchain.set_head s.net (vblock s "A6") >>= fun _ -> + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "A6" mempool + ["PP"; + "A7" ; "A8" ; + "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ; + State.Net.Blockchain.set_head s.net (vblock s "B6") >>= fun _ -> + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "B6" mempool + ["PP"; + "A4" ; "A5" ; "A6" ; "A7" ; "A8" ; + "B7" ; "B8" ] ; + State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun _changed -> + assert _changed ; + State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun _changed -> + assert (not _changed) ; + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "B6.remove" mempool + ["A4" ; "A5" ; "A6" ; "A7" ; "A8" ; + "B7" ; "B8" ] ; + save_reload s >>=? fun s -> + State.Net.Mempool.get s.net >>= fun mempool -> + compare s "B6.saved" mempool + ["A4" ; "A5" ; "A6" ; "A7" ; "A8" ; + "B7" ; "B8" ] ; + State.Net.Mempool.for_block s.net (vblock s "A4") >>= fun mempool -> + compare s "A4.for_block" mempool + ["A5" ; "A6" ; "A7" ; "A8" ; + "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ; + return s + +(****************************************************************************) + + +let tests : (string * (state -> state tzresult Lwt.t)) list = [ + "init", test_init ; + "read_operation", test_read_operation; + "read_block", test_read_block ; + "successors", test_successors ; + "path", test_path ; + "valid_path", test_valid_path ; + "ancestor", test_ancestor ; + "locator", test_locator ; + "known_heads", test_known_heads ; + "head", test_head ; + "mem", test_mem ; + "new", test_new ; + "mempool", test_mempool; +] + +let res = + Test.run "state." (List.map (fun (s, f) -> s, wrap_state_init f) tests) diff --git a/test/test_store.ml b/test/test_store.ml new file mode 100644 index 000000000..da839c0df --- /dev/null +++ b/test/test_store.ml @@ -0,0 +1,238 @@ + +open Utils +open Hash +open Store + +let (>>=) = Lwt.bind +let (>|=) = Lwt.(>|=) +let (//) = Filename.concat + +(** Basic blocks *) + +let genesis_block = + Block_hash.of_b48check + "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_protocol = + Protocol_hash.of_b48check + "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + +let genesis_time = + Time.of_seconds 0L + +let genesis = { + Store.time = genesis_time ; + block = genesis_block ; + protocol = genesis_protocol ; +} + +(** *) + +let wrap_store_init f base_dir = + let root = base_dir // "store" in + Store.init root >>= fun store -> + f store + +let test_init _ = Lwt.return_unit + +(** Operation store *) + +let make proto : Store.operation = + { shell = { net_id = Net genesis_block } ; proto } + +let op1 = make (MBytes.of_string "Capadoce") +let oph1 = Operation.hash op1 +let op2 = make (MBytes.of_string "Kivu") +let oph2 = Operation.hash op2 + +let check_operation s h b = + Operation.get s h >>= function + | Some { Time.data = Ok b' } when Operation.equal b b' -> Lwt.return_unit + | _ -> + Printf.eprintf "Error while reading operation %s\n%!" + (Operation_hash.to_hex h); + exit 1 + +let test_operation s = + Persist.use s.operation (fun s -> + Operation.set s oph1 (Time.make_timed (Ok op1)) >>= fun () -> + Operation.set s oph2 (Time.make_timed (Ok op2)) >>= fun () -> + check_operation s oph1 op1 >>= fun () -> + check_operation s oph2 op2) + +(** Block store *) + +let lolblock ?(operations = []) header = + { Time.time = Time.of_seconds (Random.int64 1500L) ; + data = + { shell = + { timestamp = Time.of_seconds (Random.int64 1500L) ; + net_id = Store.Net genesis_block ; + predecessor = genesis_block ; operations; + fitness = [MBytes.of_string @@ string_of_int @@ String.length header; + MBytes.of_string @@ string_of_int @@ 12] } ; + proto = MBytes.of_string header ; + } ; + } + +let b1 = lolblock "Blop !" +let bh1 = Store.Block.hash b1.data +let b2 = lolblock "Tacatlopo" +let bh2 = Store.Block.hash b2.data +let b3 = lolblock ~operations:[oph1;oph2] "Persil" +let bh3 = Store.Block.hash b3.data + +let check_block s h b = + Block.full_get s h >>= function + | Some b' when Store.Block.equal b.Time.data b'.Time.data + && Time.equal b.time b'.time -> Lwt.return_unit + | Some b' -> + Printf.eprintf "Error while reading block %s\n%!" (Block_hash.to_hex h); + exit 1 + | None -> + Printf.eprintf "Error while reading block %s (not found)\n%!" + (Block_hash.to_hex h); + exit 1 + +let test_block (s: Store.store) = + Persist.use s.block (fun s -> + Block.full_set s bh1 b1 >>= fun () -> + Block.full_set s bh2 b2 >>= fun () -> + Block.full_set s bh3 b3 >>= fun () -> + check_block s bh1 b1 >>= fun () -> + check_block s bh2 b2 >>= fun () -> + check_block s bh3 b3) + + +(** Generic store *) + +let check s k d = + get s k >|= fun d' -> + if d' <> Some d then begin + Test.fail + "Error while reading key %S\n%!" + (String.concat Filename.dir_sep k); + end + +let check_none s k = + get s k >|= function + | None -> () + | Some _ -> + Test.fail + "Error while reading non-existent key %S\n%!" + (String.concat Filename.dir_sep k) + +let test_generic (s: Store.store) = + Persist.use s.global_store (fun s -> + set s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> + set s ["day";"next"] (MBytes.of_string "Jeudi") >>= fun () -> + set s ["day";"truc";"chose"] (MBytes.of_string "Vendredi") >>= fun () -> + check s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> + check s ["day";"next"] (MBytes.of_string "Jeudi") >>= fun () -> + check_none s ["day"]) + +let test_generic_list (s: Store.store) = + Persist.use s.global_store (fun s -> + set s ["a"; "b"] (MBytes.of_string "Novembre") >>= fun () -> + set s ["a"; "c"] (MBytes.of_string "Juin") >>= fun () -> + set s ["a"; "d"; "e"] (MBytes.of_string "Septembre") >>= fun () -> + set s ["f";] (MBytes.of_string "Avril") >>= fun () -> + set s ["g"; "h"] (MBytes.of_string "Avril") >>= fun () -> + list s [] >>= fun l -> + assert (l = []); + list s [[]] >>= fun l -> + assert (l = [["a"];["f"];["g"];["version"]]); + list s [["a"]] >>= fun l -> + assert (l = [["a";"b"]; ["a";"c"]; ["a";"d"]]); + list s [["f"]] >>= fun l -> + assert (l = []); + list s [["g"]] >>= fun l -> + assert (l = [["g";"h"]]); + list s [["i"]] >>= fun l -> + assert (l = []); + list s [["a"];["g"]] >>= fun l -> + assert (l = [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]]); + Lwt.return_unit) + +(** HashSet *) + +let test_hashset (s: Store.store) = + let test name b = + if b then Lwt.return_unit else Test.fail name in + let module BlockSet = Hash_set(Block_hash) in + let module StoreSet = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) + (struct + include Block_hash + let prefix = [ "test_set" ] + let length = path_len + end)(BlockSet) in + let bhset = BlockSet.empty |> BlockSet.add bh1 |> BlockSet.add bh2 in + Persist.use s.global_store (fun s -> + StoreSet.write s bhset >>= fun s -> + StoreSet.read s >>= fun bhset' -> + test "init" (BlockSet.compare bhset bhset' = 0) >>= fun () -> + let bhset2 = bhset |> BlockSet.add bh3 |> BlockSet.remove bh1 in + StoreSet.write s bhset2 >>= fun s -> + StoreSet.read s >>= fun bhset2' -> + test "add/del" (BlockSet.compare bhset2 bhset2' = 0) >>= fun () -> + StoreSet.fold s BlockSet.empty + (fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' -> + test "fold" (BlockSet.compare bhset2 bhset2'' = 0) >>= fun () -> + set s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> + StoreSet.clear s >>= fun s -> + StoreSet.read s >>= fun empty -> + test "clean" (BlockSet.compare empty BlockSet.empty = 0) >>= fun () -> + check s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> + Lwt.return_unit) + + +(** HashMap *) + +let test_hashmap (s: Store.store) = + let test name b = + if b then Lwt.return_unit else Test.fail name in + let module BlockMap = Hash_map(Block_hash) in + let module StoreMap = + Persist.MakeBufferedPersistentTypedMap + (Store.Faked_functional_store) + (struct + include Block_hash + let prefix = [ "test_map" ] + let length = path_len + end) + (struct + type value = int * char + let encoding = + Data_encoding.(tup2 int31 (conv int_of_char char_of_int int8)) + end) + (BlockMap) in + let map = + BlockMap.empty |> BlockMap.add bh1 (1, 'a') |> BlockMap.add bh2 (2, 'b') in + Persist.use s.global_store (fun s -> + StoreMap.write s map >>= fun s -> + StoreMap.read s >>= fun map' -> + test "init" (BlockMap.compare Pervasives.compare map map' = 0) >>= fun () -> + let map2 = map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1 in + StoreMap.write s map2 >>= fun s -> + StoreMap.read s >>= fun map2' -> + test "add/del" + (BlockMap.compare Pervasives.compare map2 map2' = 0) >>= fun () -> + Lwt.return_unit) + +(** *) + +let tests : (string * (store -> unit Lwt.t)) list = [ + "init", test_init ; + "operation", test_operation ; + "block", test_block ; + "generic", test_generic ; + "generic_list", test_generic_list ; + "hashset", test_hashset ; + "hashmap", test_hashmap ; + ] + +let res = + Test.run "store." (List.map (fun (s, f) -> s, wrap_store_init f) tests) +