First public release

.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

.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

.ocp-indent

@@ -0,0 +1 @@
+match_clause = 4

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

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
+```
+

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.
+

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.
+
+
+
+
+
+
+
+
+

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 <<EOF
+FROM ocaml/opam:${ocaml_version}
+COPY install_build_deps.sh /tmp
+COPY tezos-deps.opam /tmp/src/tezos-deps.opam
+RUN cd /tmp && opam config exec -- ./install_build_deps.sh pin \
+            && rm -fr ~/.opam/log/
+USER root
+ENV HOME /home/opam
+RUN cd /tmp && opam config exec -- ./install_build_deps.sh depext \
+            && rm -fr ~/.opam/log/
+RUN apk add libsodium-dev
+USER opam
+RUN cd /tmp && opam config exec -- ./install_build_deps.sh install \
+            && rm -fr ~/.opam/log/
+EOF
+
+docker build -t ${image_name}:${ocaml_version}${image_version} ${dir}

scripts/install_build_deps.sh

@@ -0,0 +1,59 @@
+#! /bin/sh
+
+OCAML_VERSION=4.03.0
+if [ "$(ocaml -vnum)" != "${OCAML_VERSION}" ]; then
+  echo ;
+  echo "   Unexpected compiler version ($(ocaml -vnum))";
+  echo "   You should use ocaml-${OCAML_VERSION}.";
+  echo ;
+  exit 1;
+fi
+
+cmd=$1
+if [ -z "$cmd" ] ; then cmd=all ; fi
+
+case $cmd in
+    pin)
+	pin=yes
+	;;
+    depext)
+	depext=yes
+	;;
+    install)
+	install=yes
+	;;
+    all)
+	pin=yes
+	depext=yes
+	install=yes
+	;;
+    *)
+	echo "Unknown command '$cmd'."
+        echo "Usage: $0 [pin|depext|install|all]"
+	exit 1
+esac
+
+set -e
+set -x
+
+if [ ! -z "$pin" ] ; then
+    opam pin --yes remove --no-action --dev-repo ocplib-json-typed || true
+    opam pin --yes remove --no-action --dev-repo ocplib-resto || true
+    opam pin --yes add --no-action --dev-repo sodium
+    opam pin --yes add --no-action --dev-repo ocp-ocamlres
+    opam pin --yes add --no-action --dev-repo ocplib-resto
+    opam pin --yes add --no-action tezos-deps src
+fi
+
+if [ ! -z "$depext" ] ; then
+    opam list --installed depext || opam install depext
+    opam depext ${DEPEXTOPT} tezos-deps
+fi
+
+if [ ! -z "$install" ] ; then
+    if opam list --installed tezos-deps ; then
+	opam upgrade $(shell opam list -s --required-by tezos-deps)
+    else
+	opam install tezos-deps
+    fi
+fi

src/.merlin

@@ -0,0 +1,40 @@
+S node/net
+B node/net
+S node/updater
+B node/updater
+S node/shell
+B node/shell
+S node/db
+B node/db
+S utils
+B utils
+S proto/environment
+B proto/environment
+S compiler
+B compiler
+S client
+B client
+FLG -open Result
+FLG -w -30
+FLG -w -40
+PKG base64
+PKG calendar
+PKG cohttp
+PKG compiler-libs.optcomp
+PKG conduit
+PKG config-file
+PKG cryptokit
+PKG cstruct
+PKG dynlink
+PKG ezjsonm
+PKG git
+PKG irmin
+PKG lwt
+PKG ocplib-endian
+PKG ocplib-json-typed
+PKG ocplib-ocamlres
+PKG ocplib-resto.directory
+PKG result
+PKG sodium
+PKG unix
+PKG zarith

src/Makefile

@@ -0,0 +1,467 @@
+
+include Makefile.config
+
+TZCOMPILER=../tezos-protocol-compiler
+TZNODE=../tezos-node
+TZCLIENT=../tezos-client
+
+all: ${TZCOMPILER} ${TZNODE} ${TZCLIENT}
+
+
+############################################################################
+## Protocol environment
+############################################################################
+
+PROTOCOL_ENV_INTFS := $(addprefix proto/environment/, \
+  pervasives.mli \
+  compare.mli \
+  \
+  array.mli list.mli bytes.mli string.mli \
+  set.mli map.mli \
+  int32.mli int64.mli \
+  buffer.mli \
+  format.mli \
+  \
+  lwt_sequence.mli lwt.mli lwt_list.mli \
+  \
+  mBytes.mli \
+  hex_encode.mli \
+  \
+  uri.mli \
+  data_encoding.mli \
+  time.mli \
+  base48.mli \
+  hash.mli \
+  ed25519.mli \
+  persist.mli \
+  context.mli \
+  RPC.mli \
+  \
+  fitness.mli \
+  updater.mli \
+) \
+utils/logging.mli \
+utils/error_monad_sig.ml \
+utils/error_monad.mli
+
+.INTERMEDIATE: node/updater/environment_gen
+.SECONDARY: node/updater/proto_environment.mli
+
+node/updater/environment_gen: node/updater/environment_gen.ml
+	@echo LINK $(notdir $@)
+	@$(OCAMLOPT) -o $@ $^
+
+node/updater/proto_environment.mli: \
+	node/updater/environment_gen $(PROTOCOL_ENV_INTFS)
+	@echo GENERATING $(notdir $@)
+	@node/updater/environment_gen node/updater/proto_environment.mli \
+	  $(PROTOCOL_ENV_INTFS)
+
+node/updater/proto_environment.cmi: \
+  node/updater/proto_environment.mli node/updater/protocol.cmi
+	@echo OCAMLOPT ${TARGET} $@
+	@$(OCAMLOPT) -nopervasives -nostdlib -opaque -I tmp -I node/updater -c $<
+
+clean::
+	rm -f node/updater/proto_environment.mli
+	rm -f node/updater/environment_gen
+
+############################################################################
+## Protocol environment
+############################################################################
+
+
+EMBEDDED_PROTOCOL_LIB_CMIS := \
+  tmp/camlinternalFormatBasics.cmi \
+  utils/error_monad.cmi \
+  proto/environment/error_monad.mli \
+  proto/environment/logging.mli \
+  node/updater/proto_environment.cmi \
+  node/updater/register.cmi
+
+node/updater/register.cmi: EXTRA_OCAMLFLAGS = -opaque
+node/updater/environment.cmi: node/updater/environment.cmx
+
+tmp/camlinternalFormatBasics.cmi:
+	mkdir -p tmp
+	ln -sf $(shell ocamlc -where)/camlinternalFormatBasics.cmi $@
+
+.INTERMEDIATE: compiler/embedded_cmis.ml
+compiler/embedded_cmis.cmx: compiler/embedded_cmis.cmi
+compiler/embedded_cmis.ml: ${EMBEDDED_PROTOCOL_LIB_CMIS}
+	@echo OCAMLRES ${TARGET} $(notdir $@)
+	@$(OCAMLRES) -format ocaml -o $@ $^
+clean::
+	rm -f compiler/embedded_cmis.ml
+	rm -rf tmp
+
+
+############################################################################
+## Node protocol compiler (also embedded in the main program)
+############################################################################
+
+UTILS_LIB_INTFS := \
+  utils/mBytes.mli \
+  utils/base48.mli \
+  utils/hex_encode.mli \
+  utils/utils.mli \
+  utils/cli_entries.mli \
+  utils/compare.mli \
+  utils/data_encoding.mli \
+  utils/time.mli \
+  utils/hash.mli \
+  utils/ed25519.mli \
+  utils/error_monad.mli \
+  utils/logging.mli \
+  utils/lwt_utils.mli \
+  utils/IO.mli \
+
+UTILS_LIB_IMPLS := \
+  utils/mBytes.ml \
+  utils/base48.ml \
+  utils/hex_encode.ml \
+  utils/utils.ml \
+  utils/cli_entries.ml \
+  utils/compare.ml \
+  utils/data_encoding.ml \
+  utils/time.ml \
+  utils/hash.ml \
+  utils/ed25519.ml \
+  utils/error_monad_sig.ml \
+  utils/error_monad.ml \
+  utils/logging.ml \
+  utils/lwt_utils.ml \
+  utils/IO.ml \
+
+UTILS_PACKAGES := \
+  base64 \
+  calendar \
+  cryptokit \
+  cstruct \
+  ezjsonm \
+  lwt  \
+  ocplib-json-typed \
+  sodium \
+  zarith
+
+UTILS_OBJS := \
+  ${UTILS_LIB_IMPLS:.ml=.cmx} ${UTILS_LIB_IMPLS:.ml=.ml.deps} \
+  ${UTILS_LIB_INTFS:.mli=.cmi} ${UTILS_LIB_INTFS:.mli=.mli.deps}
+${UTILS_OBJS}: PACKAGES=${UTILS_PACKAGES}
+${UTILS_OBJS}: SOURCE_DIRECTORIES=utils
+${UTILS_OBJS}: TARGET="(utils.cmxa)"
+${UTILS_OBJS}: OPENED_MODULES=
+
+utils.cmxa: ${UTILS_LIB_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
+
+
+############################################################################
+## Node protocol compiler (also embedded in the main program)
+############################################################################
+
+COMPILER_LIB_INTFS := \
+  compiler/tezos_compiler.mli \
+  compiler/embedded_cmis.mli \
+
+COMPILER_LIB_IMPLS := \
+  compiler/embedded_cmis.ml \
+  compiler/tezos_compiler.ml
+
+COMPILER_IMPLS := \
+  compiler_main.ml
+
+COMPILER_PACKAGES := \
+  ${UTILS_PACKAGES} \
+  compiler-libs.optcomp \
+  config-file \
+  lwt.unix \
+  ocplib-endian \
+  ocplib-ocamlres \
+  unix
+
+COMPILER_OBJS := \
+  ${COMPILER_IMPLS:.ml=.cmx} ${COMPILER_IMPLS:.ml=.ml.deps} \
+  ${COMPILER_LIB_IMPLS:.ml=.cmx} ${COMPILER_LIB_IMPLS:.ml=.ml.deps} \
+  ${COMPILER_LIB_INTFS:.mli=.cmi} ${COMPILER_LIB_INTFS:.mli=.mli.deps} \
+  ${TZCOMPILER}
+${COMPILER_OBJS}: PACKAGES=${COMPILER_PACKAGES}
+${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils compiler
+${COMPILER_OBJS}: TARGET="(compiler.cmxa)"
+${COMPILER_OBJS}: \
+  OPENED_MODULES=Error_monad Hash Utils
+
+compiler.cmxa: ${COMPILER_LIB_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
+
+${TZCOMPILER}: utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@$(OCAMLOPT) -linkpkg $(patsubst %, -package %, $(COMPILER_PACKAGES)) -o $@ $^
+
+clean::
+	rm -f ${TZCOMPILER}
+
+
+############################################################################
+## Node program
+############################################################################
+
+NODE_LIB_INTFS := \
+  node/net/netbits.mli \
+  node/net/p2p.mli \
+  node/net/RPC.mli \
+  \
+  node/updater/fitness.mli \
+  \
+  node/db/ir_funview.mli \
+  node/db/persist.mli \
+  node/db/context.mli \
+  node/db/store.mli \
+  node/db/db_proxy.mli \
+  \
+  node/updater/protocol.mli \
+  node/updater/updater.mli \
+  node/updater/proto_environment.mli \
+  node/updater/register.mli \
+  \
+  node/shell/state.mli \
+  node/shell/prevalidator.mli \
+  node/shell/validator.mli \
+  \
+  node/shell/messages.mli \
+  node/shell/discoverer.mli \
+  node/shell/node_rpc_services.mli \
+  node/shell/node.mli \
+  node/shell/node_rpc.mli \
+
+NODE_LIB_IMPLS := \
+  compiler/node_compiler_main.ml \
+  \
+  node/net/netbits.ml \
+  node/net/p2p.ml \
+  node/net/RPC.ml \
+  \
+  node/updater/fitness.ml \
+  \
+  node/db/ir_funview.ml \
+  node/db/persist.ml \
+  node/db/store.ml \
+  node/db/context.ml \
+  node/db/db_proxy.ml \
+  \
+  node/updater/updater.ml \
+  node/updater/environment.ml \
+  node/updater/proto_environment.ml \
+  node/updater/register.ml \
+  \
+  node/shell/state.ml \
+  \
+  node/shell/messages.ml \
+  node/shell/prevalidator.ml \
+  node/shell/validator.ml \
+  \
+  node/shell/discoverer.ml \
+  node/shell/node_rpc_services.ml \
+  node/shell/node.ml \
+  node/shell/node_rpc.ml \
+
+NODE_IMPLS := \
+  node_main.ml \
+
+NODE_PACKAGES := \
+  $(COMPILER_PACKAGES) \
+  calendar \
+  cohttp.lwt \
+  dynlink \
+  git \
+  irmin.unix \
+  ocplib-resto.directory
+
+EMBEDDED_NODE_PROTOCOLS := \
+  $(patsubst proto/%/,proto/embedded_proto_%.cmxa, \
+  $(filter-out proto/environment/,$(shell ls -d proto/*/)))
+
+NODE_OBJS := \
+  ${NODE_IMPLS:.ml=.cmx} ${NODE_IMPLS:.ml=.ml.deps} \
+  ${NODE_LIB_IMPLS:.ml=.cmx} ${NODE_LIB_IMPLS:.ml=.ml.deps} \
+  ${NODE_LIB_INTFS:.mli=.cmi} ${NODE_LIB_INTFS:.mli=.mli.deps} \
+  ${TZNODE}
+${NODE_OBJS}: PACKAGES=${NODE_PACKAGES}
+${NODE_OBJS}: SOURCE_DIRECTORIES=utils compiler node/db node/net node/updater node/shell
+${NODE_OBJS}: TARGET="(node.cmxa)"
+${NODE_OBJS}: OPENED_MODULES=Error_monad Hash Utils
+
+node.cmxa: ${NODE_LIB_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
+
+ ${NODE_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS}
+${TZNODE}: utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
+
+clean::
+	-rm -f proto/*.cm* proto/*.a
+
+## Embedded protocol modules
+
+.SECONDEXPANSION:
+proto/embedded_proto_%.cmxa: \
+  ${TZCOMPILER} \
+  proto/%/TEZOS_PROTOCOL \
+  $$(wildcard proto/%/*.ml) \
+  $$(wildcard proto/%/*.mli)
+	@${TZCOMPILER} --build-dir proto/$*/_tzbuild $@ proto/$*/
+
+CLIENT_PROTO_INCLUDES := \
+  utils node/updater node/db node/net node/shell client \
+  $(shell ocamlfind query lwt ocplib-json-typed)
+
+proto/client_embedded_proto_%.cmxa: \
+  ${TZCOMPILER} \
+  node/updater/environment.cmi \
+  node/updater/environment.cmx \
+  proto/%/TEZOS_PROTOCOL \
+  $$(wildcard proto/%/*.ml) \
+  $$(wildcard proto/%/*.mli)
+	@./${TZCOMPILER} --client --build-dir client/embedded/$*/_tzbuild \
+	   $(addprefix -I , ${CLIENT_PROTO_INCLUDES}) \
+	   $@ proto/$*
+
+
+
+clean::
+	rm -f ${TZNODE}
+
+
+############################################################################
+## Client program
+############################################################################
+
+CLIENT_LIB_INTFS := \
+  client/client_version.mli \
+  client/client_node_rpcs.mli \
+  client/client_generic_rpcs.mli \
+  client/client_aliases.mli \
+  client/client_keys.mli \
+
+CLIENT_LIB_IMPLS := \
+  client/client_version.ml \
+  client/client_config.ml \
+  client/client_node_rpcs.ml \
+  client/client_generic_rpcs.ml \
+  client/client_aliases.ml \
+  client/client_keys.ml \
+
+CLIENT_IMPLS := \
+  client_main.ml
+
+CLIENT_PACKAGES := \
+  ${NODE_PACKAGES}
+
+EMBEDDED_CLIENT_PROTOCOLS := \
+  $(patsubst client/embedded/%/, \
+	     proto/client_embedded_proto_%.cmxa, \
+             $(shell ls -d client/embedded/*/)) \
+  $(patsubst client/embedded/%/, \
+	     client/embedded/client_%.cmx , \
+             $(shell ls -d client/embedded/*/))
+
+
+CLIENT_OBJS := \
+  ${CLIENT_IMPLS:.ml=.cmx} ${CLIENT_IMPLS:.ml=.ml.deps} \
+  ${CLIENT_LIB_IMPLS:.ml=.cmx} ${CLIENT_LIB_IMPLS:.ml=.ml.deps} \
+  ${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \
+  ${TZCLIENT}
+${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES}
+${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db
+${CLIENT_OBJS}: TARGET="(client.cmxa)"
+${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils
+
+client.cmxa: ${CLIENT_LIB_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
+
+${EMBEDDED_CLIENT_PROTOCOLS}: client.cmxa
+${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS}
+
+${TZCLIENT}: utils.cmxa compiler.cmxa node.cmxa \
+             client.cmxa ${EMBEDDED_CLIENT_PROTOCOLS} \
+	     ${CLIENT_IMPLS:.ml=.cmx}
+	@echo LINK $(notdir $@)
+	@${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^
+
+clean::
+	-rm -f ${TZCLIENT}
+
+## Embedded client protocol modules
+
+.SECONDEXPANSION:
+client/embedded/client_%.cmx: \
+  $(patsubst %.ml, %.cmx, $(NODE_LIB_IMPLS) $(CLIENT_LIB_IMPLS)) \
+  proto/client_embedded_proto_%.cmxa \
+  $$(shell find client/embedded/% -name \*.ml -or -name \*.mli)
+	@$(MAKE) -C client/embedded/$* ../client_$*.cmx
+clean::
+	-for d in $$(ls -d client/embedded/*/) ; do make clean -C $$d ; done
+	-rm -f client/embedded/*.cm* client/embedded/*.o
+
+## Generic rules
+
+%.cmx: %.ml
+	@echo OCAMLOPT ${TARGET} $(notdir $@)
+	@$(OCAMLOPT) ${OCAMLFLAGS} -c $<
+
+%.cmo: %.ml
+	@echo OCAMLOPT ${TARGET} $(notdir $@)
+	@$(OCAMLC) ${OCAMLFLAGS} -c $<
+
+%.cmi: %.mli
+	@echo OCAMLOPT ${TARGET} $(notdir $@)
+	@$(OCAMLOPT) ${OCAMLFLAGS} -c $<
+
+## Cleaning
+
+.PHONY: clean
+clean::
+	-find \( -name \*.cm\* -or -name \*~ -or -name \*.o -or -name \*.a \) -delete
+
+## Dependencies
+
+NO_DEPS := \
+   compiler/embedded_cmis.ml \
+   compiler/embedded_cmis.mli
+compiler/embedded_cmis.cmx compiler/embedded_cmis.cmi: OPENED_MODULES=
+
+ifneq ($(MAKECMDGOALS),clean)
+ifneq ($(MAKECMDGOALS),build-deps)
+-include .depend
+endif
+endif
+DEPENDS := $(filter-out $(NO_DEPS), $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \
+                                    $(COMPILER_LIB_INTFS) $(COMPILER_LIB_IMPLS) \
+                                    $(COMPILER_INTFS) $(COMPILER_IMPLS) \
+                                    $(NODE_LIB_INTFS) $(NODE_LIB_IMPLS) \
+                                    $(NODE_INTFS) $(NODE_IMPLS) \
+                                    $(CLIENT_LIB_INTFS) $(CLIENT_LIB_IMPLS) \
+                                    $(CLIENT_INTFS) $(CLIENT_IMPLS))
+
+predepend: node/updater/proto_environment.mli
+compiler/tezos_compiler.cmo compiler/tezos_compiler.cmx: \
+	compiler/embedded_cmis.cmi compiler/embedded_cmis.cmx
+
+.SECONDARY: $(patsubst %,%.deps,${DEPENDS})
+.depend: $(patsubst %,%.deps,${DEPENDS})
+	@cat $^ > .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

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

src/client/.merlin

@@ -0,0 +1,4 @@
+REC
+FLG -open Error_monad -open Hash -open Utils
+S embedded
+B embedded

src/client/client_aliases.ml

@@ -0,0 +1,198 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_aliases.mli

@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_config.ml

@@ -0,0 +1,202 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_generic_rpcs.ml

@@ -0,0 +1,347 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 <dynamic>" (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 "@[<v 2>+ %s/@,%a@]"
+              (String.concat "/" path) (display_list tpath) items
+        | Some service, items when count tree >= 3 && path <> [] ->
+            Format.fprintf ppf "@[<v 2>+ %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 "@ @[<v 2>Available services:@ @ %a@]@."
+    display (args, args, tree) ;
+  if !collected_args <> [] then
+    Format.printf "@,@[<v 2>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
+  ])

src/client/client_generic_rpcs.mli

@@ -0,0 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val commands: Cli_entries.command list

src/client/client_keys.ml

@@ -0,0 +1,137 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 []) ;
+     ]

src/client/client_keys.mli

@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_node_rpcs.ml

@@ -0,0 +1,209 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_node_rpcs.mli

@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_version.ml

@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/client_version.mli

@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

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} $^ > $@

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

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

src/client/embedded/bootstrap/client_proto_aliases.ml

@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+
+(* -- aliases ----------------------------------------------------------------- *)
+
+
+(* -- parsing ----------------------------------------------------------------- *)
+

src/client/embedded/bootstrap/client_proto_aliases.mli

@@ -0,0 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Contract : Client_aliases.Alias with type t = Contract_repr.contract

src/client/embedded/bootstrap/client_proto_args.ml

@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_args.mli

@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_context.ml

@@ -0,0 +1,275 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ())
+  ]

src/client/embedded/bootstrap/client_proto_context.mli

@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_contracts.ml

@@ -0,0 +1,182 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()) ;
+  ]

src/client/embedded/bootstrap/client_proto_contracts.mli

@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_main.ml

@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/client/embedded/bootstrap/client_proto_main.mli

@@ -0,0 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val protocol: Protocol_hash.t

src/client/embedded/bootstrap/client_proto_nonces.ml

@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_nonces.mli

@@ -0,0 +1,14 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_programs.ml

@@ -0,0 +1,179 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 "{ @[<v>" ;
+      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 @[<v 2>%s@," name ;
+      do_args seq
+  | Prim (_, name, seq) ->
+      Format.fprintf ppf "@[<v 2>%s@," name ;
+      do_args seq
+
+let print_program ppf c =
+  Format.fprintf ppf
+    "@[<v 2>storage@,%a@]@."
+    print_ir (c : Script.code).Script.storage_type ;
+  Format.fprintf ppf
+    "@[<v 2>parameter@,%a@]@."
+    print_ir (c : Script.code).Script.arg_type ;
+  Format.fprintf ppf
+    "@[<v 2>return@,%a@]@."
+    print_ir (c : Script.code).Script.ret_type ;
+  Format.fprintf ppf
+    "@[<v 2>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") ;
+  ]

src/client/embedded/bootstrap/client_proto_programs.mli

@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/client_proto_rpcs.ml

@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let string_of_errors exns =
+  Format.asprintf "  @[<v>%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) *)

src/client/embedded/bootstrap/client_proto_rpcs.mli

@@ -0,0 +1,217 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

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
+
+}

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 <string> FLOAT
+%token <string> INT
+%token <string> PRIM
+%token <string> STRING
+
+%left PRIM INT FLOAT LPAREN LBRACE STRING
+%left apply
+
+%start <Script_located_ir.node list> 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) }
+
+%%

src/client/embedded/bootstrap/local_error_monad.ml

@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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]

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 \
+

src/client/embedded/bootstrap/mining/client_mining_blocks.ml

@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_blocks.mli

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_daemon.ml

@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_daemon.mli

@@ -0,0 +1,13 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val run:
+  ?max_priority: int ->
+  delay: int ->
+  public_key_hash list -> unit Lwt.t

src/client/embedded/bootstrap/mining/client_mining_denunciation.ml

@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 @[<h>%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 ()

src/client/embedded/bootstrap/mining/client_mining_denunciation.mli

@@ -0,0 +1,12 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val create:
+  Client_mining_operations.valid_endorsement Lwt_stream.t ->
+  unit Lwt.t

src/client/embedded/bootstrap/mining/client_mining_endorsement.ml

@@ -0,0 +1,345 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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
+        "@[<v 2>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 ()

src/client/embedded/bootstrap/mining/client_mining_endorsement.mli

@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_forge.ml

@@ -0,0 +1,454 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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
+              "@[<hov 2>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

src/client/embedded/bootstrap/mining/client_mining_forge.mli

@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_main.ml

@@ -0,0 +1,166 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/client/embedded/bootstrap/mining/client_mining_main.mli

@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_operations.ml

@@ -0,0 +1,102 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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
+                   "@[<v 2>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
+                  "@[<v 2>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
+                      "@[<v 2>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

src/client/embedded/bootstrap/mining/client_mining_operations.mli

@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/mining/client_mining_revelation.ml

@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/client/embedded/bootstrap/mining/client_mining_revelation.mli

@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/bootstrap/script_located_ir.ml

@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

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

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

src/client/embedded/demo/client_proto_main.ml

@@ -0,0 +1,92 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/client/embedded/demo/client_proto_main.mli

@@ -0,0 +1,9 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+

src/client/embedded/demo/client_proto_rpcs.ml

@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client/embedded/demo/client_proto_rpcs.mli

@@ -0,0 +1,13 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/client_main.ml

@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ())

src/compiler/.merlin

@@ -0,0 +1,2 @@
+REC
+FLG -open Error_monad -open Hash -open Utils

src/compiler/embedded_cmis.mli

@@ -0,0 +1,15 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/compiler/node_compiler_main.ml

@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/compiler/tezos_compiler.ml

@@ -0,0 +1,442 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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]

src/compiler/tezos_compiler.mli

@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/compiler_main.ml

@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/.merlin

@@ -0,0 +1,2 @@
+REC
+FLG -open Error_monad -open Hash -open Utils

src/node/db/context.ml

@@ -0,0 +1,327 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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))
+

src/node/db/context.mli

@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/db/db_proxy.ml

@@ -0,0 +1,108 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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)

src/node/db/db_proxy.mli

@@ -0,0 +1,46 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/db/ir_funview.ml

@@ -0,0 +1,673 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*
+ * Copyright (c) 2013-2015 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2016 Grégoire Henry <gregoire.henry@ocamlpro.com>
+ *
+ * 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

src/node/db/ir_funview.mli

@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/db/persist.ml

@@ -0,0 +1,571 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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)

src/node/db/persist.mli

@@ -0,0 +1,251 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/db/store.ml

@@ -0,0 +1,648 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/db/store.mli

@@ -0,0 +1,201 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/net/RPC.ml

@@ -0,0 +1,179 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/net/RPC.mli

@@ -0,0 +1,309 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/net/netbits.ml

@@ -0,0 +1,208 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 "[@[<hv 2>" ;
+  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)

src/node/net/netbits.mli

@@ -0,0 +1,61 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/net/p2p.mli

@@ -0,0 +1,102 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/shell/discoverer.ml

@@ -0,0 +1,46 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/node/shell/discoverer.mli

@@ -0,0 +1,14 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/shell/messages.ml

@@ -0,0 +1,92 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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
+

src/node/shell/messages.mli

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/shell/node.ml

@@ -0,0 +1,547 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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

src/node/shell/node.mli

@@ -0,0 +1,70 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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