balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'work-on-script'.

Browse Source
This commit is contained in:
Grégoire Henry 2017-01-23 23:24:16 +01:00
commit 854e2f0697
58 changed files with 1538 additions and 848 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
.dockerignore Normal file
View File

@ -0,0 +1,67 @@
.git
tezos-node
tezos-protocol-compiler
tezos-client
tezos-webclient
tezos-attacker
src/Makefile.local
src/webclient_static.ml
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
src/client/embedded/bootstrap/webclient_proto_static.ml
src/client/embedded/bootstrap/main.byte
src/client/embedded/bootstrap/webclient_static/main.js
src/client/embedded/bootstrap/webclient/browser/main.byte
src/client/embedded/bootstrap/webclient/static/main.js
src/client/embedded/bootstrap/webclient/webclient_proto_static.ml
test/.depend
test/reports
test/test-store
test/test-state
test/test-context
test/test-basic
test/test-data-encoding
test/test-p2p-io-scheduler
test/test-p2p-connection
test/test-p2p-connection-pool
test/LOG
**/*~
**/\#*\#
**/*.[oa]
**/*.so
**/*~
**/*.cm[iaoxt]
**/*.cmti
**/*.cmxa
**/*.cmxs
**/*.cmp
**/*.mli.deps
**/*.ml.deps
**/*.mli.deps.byte
**/*.ml.deps.byte
**/bisect*.out
**/*.rej
**/*.orig

54
.gitlab-ci.yml
View File

@ -1,10 +1,10 @@
variables:
ocaml_image: alpine_ocaml-4.03.0
build_image_name: ocp_tezos_build
image_name: ocp_tezos
image_id: ${CI_BUILD_REF_NAME}
build_image_name: ${image_name}_build_deps
build_image_id: ${CI_BUILD_REF}
build_image: ${build_image_name}:${ocaml_image}
image: ${build_image}_${build_image_id}
image: ${build_image_name}:${build_image_id}
stages:
- build_deps
@ -21,8 +21,8 @@ build_deps:
tags:
- docker_builder
script:
- ./scripts/create_docker_builder.sh
${build_image_name} ${ocaml_image} "_${build_image_id}"
- ./scripts/create_build_deps_docker_image.sh
${build_image_name} ${build_image_id}
build:
stage: build
@ -137,15 +137,29 @@ test:p2p-connection-pool:
- build
- build:test
expurge:
stage: expurge
publish:docker:
stage: publish
image: ocp:docker
tags:
- docker_builder
script:
- ./scripts/create_docker_image.sh ${image_name} ${build_image_id}
- docker tag ${image_name}:${build_image_id}
"$CI_REGISTRY_IMAGE:$CI_BUILD_REF_NAME"
- docker login -u gitlab-ci-token -p $CI_BUILD_TOKEN $CI_REGISTRY
- docker push "$CI_REGISTRY_IMAGE:$CI_BUILD_REF_NAME"
- docker rmi "$CI_REGISTRY_IMAGE:$CI_BUILD_REF_NAME"
publish:github:
image: ocaml/opam
stage: publish
tags:
- tezos_builder
only:
- master@tezos/tezos
script:
- echo "${CI_KH}" > ~/.ssh/known_hosts
- echo "${CI_PK_GITLAB}" > ~/.ssh/id_rsa
- echo "${CI_PK_GITHUB}" > ~/.ssh/id_rsa
- chmod 400 ~/.ssh/id_rsa
- rm -fr .git/refs/original
- git filter-branch --prune-empty --index-filter
@ -162,22 +176,6 @@ expurge:
export GIT_AUTHOR_EMAIL="contact@tezos.com" ;
fi'
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
script:
- echo "${CI_KH}" > ~/.ssh/known_hosts
- echo "${CI_PK_GITHUB}" > ~/.ssh/id_rsa
- chmod 400 ~/.ssh/id_rsa
- git reset ${CI_BUILD_REF}_expurged
- git push git@github.com:tezos/tezos.git -f HEAD:master
cleanup:
@ -186,7 +184,7 @@ cleanup:
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}
- docker tag ${build_image_name}:${build_image_id}
${build_image_name}:${CI_PROJECT_NAMESPACE}_${CI_BUILD_REF_NAME}
- docker rmi ${build_image_name}:${build_image_id}
when: always

7
Makefile
View File

@ -6,9 +6,16 @@ clean:
${MAKE} -C src clean
${MAKE} -C test clean
partial-clean:
${MAKE} -C src partial-clean
${MAKE} -C test clean
.PHONY: test
test:
${MAKE} -C test
build-deps:
@./scripts/install_build_deps.sh all
docker-image:
@./scripts/create_docker_image.sh

37
README.md
View File

@ -61,7 +61,7 @@ Running the node in a sandbox
To run a single instance of a Tezos node in sandbox mode:
```
./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732
./tezos-node --sandbox --rpc-addr :::8732
```
This "sandboxed" node will not participate in the P2P network, but will accept
@ -77,20 +77,22 @@ test network. Use the following command to run a node that will accept incoming
connections:
```
./tezos-node
./tezos-node --generate-identity --expected-pow 24.
```
The node will listen to connections coming in on `0.0.0.0:9732` (and
`[::]:9732`). All used data is stored at `$HOME/.tezos-node/`. For example,
the default configuration file is at `$HOME/.tezos-node/config`.
This will first generate a new node identity and compute the associated stamp
of proof-of-work. Then, the node will listen to connections coming in on
`0.0.0.0:9732` (and`[::]:9732`). All used data is stored at
`$HOME/.tezos-node/`. For example, the default configuration file is
at `$HOME/.tezos-node/config.json`.
To run multiple nodes on the same machine, you can duplicate and edit
`$HOME/.tezos-node/config` while making sure they don't share paths to the
`$HOME/.tezos-node/config.json` while making sure they don't share paths to the
database or any other data file (cf. options `db.store` ; `db.context` ;
`net.peers` and `protocol.dir`).
`db.protocol`, `net.peers-metadata` and `net.identity`).
You could also let Tezos generate a config file by specifying options on the
command line. For instance, if `$dir/config` does not exist, the following
command line. For instance, if `$dir/config.json` does not exist, the following
command will generate it and replace the default values with the values from
the command line:
@ -102,20 +104,23 @@ The Tezos server has a built-in mechanism to discover peers on the local
network (using UDP packets broadcasted on port 7732).
If this mechanism is not 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:
initial peers, either by editing the option `net.bootstrap-peers` in the
`config.json` file, or by specifying a command line parameter:
```
./tezos-node --base-dir "$dir" --net-addr 127.0.0.1:2023 \
--peer 127.0.0.1:2021 --peer 127.0.0.1:2022
```
If `"$dir"/config` exists, the command line options override those read in the
config file. Tezos won't modify the content of an existing `"$dir"/config`
file.
If `"$dir"/config.json` exists, the command line options override those
read in the config file. By default, Tezos won't modify the content of an
existing `"$dir"/config.json` file. But, you may explicit ask the node
to reset or to update the file according to the command line parameters
with the following commands line:
```
./tezos-node --config-file "$dir"/config
./tezos-node --reset-config --base-dir "$dir" --net-addr 127.0.0.1:9733
./tezos-node --update-config --base-dir "$dir" --net-addr 127.0.0.1:9734
```
@ -129,7 +134,7 @@ Typically, if you are not trying to run a local network and just want to
explore the RPC, you would run:
```
./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732
./tezos-node --sandbox --rpc-addr :::8732
```
The RPC interface is self-documented and the `tezos-client` executable is able
@ -151,7 +156,7 @@ You might also want the JSON schema describing the expected input and output of
a RPC. For instance:
```
./tezos-client rpc schema /block/genesis/hash
./tezos-client rpc schema /blocks/genesis/hash
```
Note: you can get the same information, but as a raw JSON object, with a simple

24
scripts/Dockerfile.binaries.in Normal file
View File

@ -0,0 +1,24 @@
FROM alpine:$alpine_version
LABEL distro_style="apk" distro="alpine" distro_long="alpine-$alpine_version" arch="x86_64" operatingsystem="linux"
RUN apk update && \
apk upgrade && \
apk add sudo bash libssl1.0 libsodium gmp && \
rm -f /var/cache/apk/* && \
adduser -S tezos && \
echo 'tezos ALL=(ALL:ALL) NOPASSWD:ALL' > /etc/sudoers.d/tezos && \
chmod 440 /etc/sudoers.d/tezos && \
chown root:root /etc/sudoers.d/tezos && \
sed -i 's/^Defaults.*requiretty//g' /etc/sudoers
USER tezos
COPY . /home/tezos
WORKDIR /home/tezos
RUN sudo chown root:root bin/* && \
sudo chmod a+rx bin/* && \
sudo mv bin/* /usr/local/bin && \
rmdir bin
ENTRYPOINT [ "/bin/bash" ]

7
scripts/Dockerfile.build_bin.in Normal file
View File

@ -0,0 +1,7 @@
FROM $base_name:$base_version
COPY . /home/opam/tezos
RUN sudo chown -R opam /home/opam/tezos && \
opam config exec -- make -C tezos -j4 && \
mkdir bin && \
cp tezos/tezos-* bin

8
scripts/Dockerfile.build_deps.in Normal file
View File

@ -0,0 +1,8 @@
FROM ocaml/opam:alpine-$alpine_version_ocaml-$ocaml_version
COPY scripts/install_build_deps.sh scripts/version.sh scripts/
COPY src/tezos-deps.opam src/
RUN sudo apk add libsodium-dev && \
opam config exec -- ./scripts/install_build_deps.sh all \
rm -fr ~/.opam/log/ \
"$(opam config exec -- ocamlfind query stdlib)"/topdirs.cmi

20
scripts/create_build_deps_docker_image.sh Executable file
View File

@ -0,0 +1,20 @@
#! /bin/sh
set -e
set -x
script_dir="$(dirname "$(readlink -f "$0")")"
src_dir="$(dirname "$script_dir")"
cd "$src_dir"
. scripts/version.sh
image_name="${1:-tezos_build_deps}"
image_version="${2:-latest}"
sed scripts/Dockerfile.build_deps.in \
-e 's/$alpine_version/'"$alpine_version"'/g' \
-e 's/$ocaml_version/'"$ocaml_version"'/g' > Dockerfile
docker build --pull -t "$image_name:$image_version" .
rm Dockerfile

32
scripts/create_docker_builder.sh
View File

@ -1,32 +0,0 @@
#! /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
docker pull ocaml/opam:${ocaml_version}
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}

41
scripts/create_docker_image.sh Executable file
View File

@ -0,0 +1,41 @@
#! /bin/sh
set -e
set -x
script_dir="$(dirname "$(readlink -f "$0")")"
src_dir="$(dirname "$script_dir")"
cd "$src_dir"
. scripts/version.sh
image_name="${1:-tezos}"
image_version="${2:-latest}"
build_deps_image_name="$image_name"_build_deps
echo Building dependencies...
./scripts/create_build_deps_docker_image.sh \
"$build_deps_image_name" "$image_version"
cleanup () {
set +e
echo Cleaning up...
[ -z "$tmp_container" ] || docker rm "$tmp_container"
[ -z "$tmp_image" ] || docker rmi "$tmp_image"
rm -rf Dockerfile bin
}
trap cleanup EXIT INT
sed scripts/Dockerfile.build_bin.in \
-e 's/$base_name/'"$build_deps_image_name"'/g' \
-e 's/$base_version/'"$image_version"'/g' > Dockerfile
echo Building tezos...
tmp_image="$(docker build -q .)"
tmp_container="$(docker run -dit "$tmp_image" true)"
docker cp "$tmp_container":/home/opam/bin/ bin
echo Building minimal docker image...
sed scripts/Dockerfile.binaries.in \
-e 's/$alpine_version/'"$alpine_version"'/g' > Dockerfile
docker build -q -t "$image_name:$image_version" .

67
scripts/install_build_deps.sh
View File

@ -1,39 +1,40 @@
#!/bin/sh
#! /bin/sh
if ! [ -f 'src/tezos-deps.opam' ]; then
echo
echo " Please run from the project's root directory. Aborting."
echo
exit 1
fi
script_dir="$(dirname "$(readlink -f "$0")")"
src_dir="$(dirname "$script_dir")"
. "$script_dir/version.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
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=false
depext=false
install=false
case $cmd in
pin)
pin=yes
;;
pin=true
;;
depext)
depext=yes
;;
depext=true
;;
install)
install=yes
;;
install=true
;;
all)
pin=yes
depext=yes
install=yes
;;
pin=true
depext=true
install=true
;;
*)
echo "Unknown command '$cmd'."
echo "Usage: $0 [pin|depext|install|all|]"
@ -43,7 +44,7 @@ esac
set -e
set -x
if ! [ -z "$pin" ]; then
if "$pin"; then
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
@ -56,15 +57,15 @@ if ! [ -z "$pin" ]; then
opam pin --yes add --no-action tezos-deps src
fi
if ! [ -z "$depext" ]; then
## In our CI, this rule is executed as user 'root'
## The other rules are executed as user 'opam'.
if "$depext"; then
opam list --installed depext || opam install depext
opam depext tezos-deps
opam depext $DEPEXTOPT tezos-deps
fi
if ! [ -z "$install" ]; then
opam install tezos-deps
## This seems broken in the current opam-repo (2016-12-09)
## opam install --build-test tezos-deps
if "$install"; then
if opam list --installed tezos-deps ; then
opam upgrade $(opam list -s --required-by tezos-deps | grep -ve '^ocaml *$')
else
opam install tezos-deps
fi
fi

4
scripts/version.sh Normal file
View File

@ -0,0 +1,4 @@
#! /bin/sh
alpine_version=3.5
ocaml_version=4.03.0

21
src/Makefile
View File

@ -65,7 +65,7 @@ node/updater/proto_environment.cmi: \
@echo OCAMLOPT ${TARGET} $@
@$(OCAMLOPT) -nopervasives -nostdlib -opaque -I tmp -I node/updater -c $<
clean::
partial-clean::
rm -f node/updater/proto_environment.mli
rm -f node/updater/environment_gen
@ -91,7 +91,7 @@ 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::
partial-clean::
rm -f compiler/embedded_cmis.ml
rm -rf tmp
@ -168,12 +168,12 @@ UTILS_LIB_INTFS := \
UTILS_LIB_IMPLS := \
utils/base48.ml \
utils/cli_entries.ml \
utils/error_monad_sig.ml \
utils/error_monad.ml \
utils/data_encoding_ezjsonm.ml \
utils/time.ml \
utils/hash.ml \
utils/crypto_box.ml \
utils/error_monad_sig.ml \
utils/error_monad.ml \
utils/lwt_exit.ml \
utils/logging.ml \
utils/lwt_utils.ml \
@ -368,7 +368,7 @@ ${TZNODE}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROT
@echo LINK $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
clean::
partial-clean::
-rm -f proto/*.cm* proto/*.a
## Embedded protocol modules
@ -399,8 +399,6 @@ proto/client_embedded_proto_%.cmxa: \
$(addprefix -I , ${CLIENT_PROTO_INCLUDES}) \
$@ proto/$*
clean::
rm -f ${TZNODE}
@ -529,7 +527,7 @@ client/embedded/webclient_%.cmx: \
$$(shell find client/embedded/%/webclient/static/)
@$(MAKE) -C client/embedded/$* ../webclient_$*.cmx
clean::
partial-clean::
-for d in $$(ls -d client/embedded/*/) ; do make clean -C $$d ; done
-rm -f client/embedded/*.cm* client/embedded/*.o
@ -601,8 +599,9 @@ clean::
## Cleaning
.PHONY: clean
clean::
.PHONY: clean partial-clean
clean:: partial-clean
partial-clean::
-find \( -name \*.cm\* -or -name \*.cmp -or -name \*.out -or -name \*~ -or -name \*.o -or -name \*.a \) -delete
## Dependencies
@ -652,6 +651,6 @@ compiler/tezos_compiler.cmo compiler/tezos_compiler.cmx: \
@echo OCAMLDEP ${TARGET} $(notdir $^)
@$(OCAMLDEP) $(INCLUDES) $^ > $@
clean::
partial-clean::
-rm -f .depend
-find \( -name \*.mli.deps -or -name \*.ml.deps \) -delete

8
src/client/client_aliases.ml
View File

@ -88,10 +88,10 @@ module Alias = functor (Entity : Entity) -> struct
let filename = filename () in
if not (Sys.file_exists filename) then return [] else
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
| Error _ ->
cctxt.Client_commands.error
"couldn't to read the %s alias file" Entity.name
| Some json ->
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error
@ -132,8 +132,8 @@ module Alias = functor (Entity : Entity) -> struct
let filename = filename () in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> fail (Failure "Json.write_file")
| true -> return ())
| Error _ -> fail (Failure "Json.write_file")
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the %s alias file: %s."

9
src/client/embedded/bootstrap/client_proto_nonces.ml
View File

@ -29,8 +29,9 @@ let load cctxt =
Lwt.return []
else
Data_encoding_ezjsonm.read_file filename >>= function
| None -> cctxt.Client_commands.error "couldn't to read the nonces file"
| Some json ->
| Error _ ->
cctxt.Client_commands.error "couldn't to read the nonces file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error "didn't understand the nonces file"
@ -51,8 +52,8 @@ let save cctxt list =
let filename = filename () in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the nonces file: %s." (Printexc.to_string exn))

8
src/client/embedded/bootstrap/mining/client_mining_endorsement.ml
View File

@ -51,9 +51,9 @@ end = struct
let filename = filename () in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
| Error _ ->
cctxt.Client_commands.error "couldn't to read the endorsement file"
| Some json ->
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error "didn't understand the endorsement file"
@ -69,8 +69,8 @@ end = struct
let filename = filename () in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error "could not write the endorsement file: %s."
(Printexc.to_string exn))

8
src/client/embedded/bootstrap/mining/client_mining_forge.ml
View File

@ -171,9 +171,9 @@ end = struct
let filename = filename () in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
| Error _ ->
failwith "couldn't to read the block file"
| Some json ->
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the block file"
@ -189,8 +189,8 @@ end = struct
let filename = filename () in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
Error_monad.failwith
"could not write the block file: %s."

25
src/minutils/utils.ml
View File

@ -9,13 +9,16 @@
module StringMap = Map.Make (String)
let split delim ?(limit = max_int) path =
let split delim ?(dup = true) ?(limit = max_int) path =
let l = String.length path in
let rec do_slashes acc limit i =
if i >= l then
List.rev acc
else if String.get path i = delim then
do_slashes acc limit (i + 1)
if dup then
do_slashes acc limit (i + 1)
else
do_split acc limit (i + 1)
else
do_split acc limit i
and do_split acc limit i =
@ -55,8 +58,8 @@ let iter_option ~f = function
| None -> ()
| Some x -> f x
let unopt x = function
| None -> x
let unopt ~default = function
| None -> default
| Some x -> x
let unopt_map ~f ~default = function
@ -85,8 +88,16 @@ let list_sub l n = list_rev_sub l n |> List.rev
let display_paragraph ppf description =
Format.fprintf ppf "@[%a@]"
(fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
(split ' ' description)
(Format.pp_print_list ~pp_sep:Format.pp_print_newline
(fun ppf line ->
Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun ppf w ->
(* replace &nbsp; by real spaces... *)
Format.fprintf ppf "%s@ "
(Stringext.replace_all ~pattern:"\xC2\xA0" ~with_:" " w))
ppf
(split ' ' line)))
(split ~dup:false '\n' description)
let rec remove_elem_from_list nb = function
| [] -> []
@ -128,6 +139,8 @@ let rec (--) i j =
if j < i then acc else loop (j :: acc) (pred j) in
loop [] j
let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x
let take_n_unsorted n l =
let rec loop acc n = function
| [] -> l

6
src/minutils/utils.mli
View File

@ -16,12 +16,12 @@ val split_path: string -> string list
(** Splits a string on a delimier character, grouping multiple
delimiters, and ignoring delimiters at the beginning and end of
string, if [limit] is passed, stops after [limit] split(s). *)
val split: char -> ?limit: int -> string -> string list
val split: char -> ?dup:bool -> ?limit: int -> string -> string list
val map_option: f:('a -> 'b) -> 'a option -> 'b option
val apply_option: f:('a -> 'b option) -> 'a option -> 'b option
val iter_option: f:('a -> unit) -> 'a option -> unit
val unopt: 'a -> 'a option -> 'a
val unopt: default:'a -> 'a option -> 'a
val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b
val unopt_list: 'a option list -> 'a list
val first_some: 'a option -> 'a option -> 'a option
@ -51,6 +51,8 @@ val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *)
val (--) : int -> int -> int list
val repeat: int -> 'a -> 'a list
(** [take_n n l] returns the [n] first elements of [n]. When [compare]
is provided, it returns the [n] greatest element of [l]. *)
val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list

5
src/node/net/p2p.ml
View File

@ -224,7 +224,7 @@ end
module Fake = struct
let id = Identity.generate Crypto_box.default_target
let id = Identity.generate (Crypto_box.make_target 0.)
let empty_stat = {
Stat.total_sent = 0 ;
total_recv = 0 ;
@ -261,9 +261,8 @@ type ('msg, 'meta) t = {
}
type ('msg, 'meta) net = ('msg, 'meta) t
let bootstrap ~config ~limits meta_cfg msg_cfg =
let create ~config ~limits meta_cfg msg_cfg =
Real.create ~config ~limits meta_cfg msg_cfg >>= fun net ->
Real.maintain net () >>= fun () ->
Lwt.return {
gid = Real.gid net ;
maintain = Real.maintain net ;

2
src/node/net/p2p.mli
View File

@ -124,7 +124,7 @@ type ('msg, 'meta) net = ('msg, 'meta) t
val faked_network : ('msg, 'meta) net
(** Main network initialisation function *)
val bootstrap :
val create :
config:config -> limits:limits ->
'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t

136
src/node/net/p2p_connection.ml
View File

@ -32,17 +32,53 @@ type error += Rejected
type error += Decoding_error
type error += Myself of Id_point.t
type error += Not_enough_proof_of_work of Gid.t
type error += Invalid_auth
type cryptobox_data = {
channel_key : Crypto_box.channel_key ;
mutable local_nonce : Crypto_box.nonce ;
mutable remote_nonce : Crypto_box.nonce ;
}
module Crypto = struct
let header_length = 2
let crypto_overhead = 18 (* FIXME import from Sodium.Box. *)
let max_content_length =
1 lsl (header_length * 8) - crypto_overhead
let header_length = 2
let crypto_overhead = 18 (* FIXME import from Sodium.Box. *)
let max_content_length =
1 lsl (header_length * 8) - crypto_overhead
type data = {
channel_key : Crypto_box.channel_key ;
mutable local_nonce : Crypto_box.nonce ;
mutable remote_nonce : Crypto_box.nonce ;
}
let write_chunk fd cryptobox_data buf =
let header_buf = MBytes.create header_length in
let local_nonce = cryptobox_data.local_nonce in
cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
let encrypted_message =
Crypto_box.fast_box cryptobox_data.channel_key buf local_nonce in
let encrypted_len = MBytes.length encrypted_message in
fail_unless
(encrypted_len < max_content_length)
Invalid_message_size >>=? fun () ->
MBytes.set_int16 header_buf 0 encrypted_len ;
P2p_io_scheduler.write fd header_buf >>=? fun () ->
P2p_io_scheduler.write fd encrypted_message >>=? fun () ->
return ()
let read_chunk fd cryptobox_data =
let header_buf = MBytes.create header_length in
P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () ->
let len = MBytes.get_uint16 header_buf 0 in
let buf = MBytes.create len in
P2p_io_scheduler.read_full ~len fd buf >>=? fun () ->
let remote_nonce = cryptobox_data.remote_nonce in
cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
match
Crypto_box.fast_box_open cryptobox_data.channel_key buf remote_nonce
with
| None ->
fail Decipher_error
| Some buf ->
return buf
end
module Connection_message = struct
@ -78,11 +114,12 @@ module Connection_message = struct
let encoded_message_len =
Data_encoding.Binary.length encoding message in
fail_unless
(encoded_message_len < max_content_length)
(encoded_message_len < Crypto.max_content_length)
Encoding_error >>=? fun () ->
let len = header_length + encoded_message_len in
let len = Crypto.header_length + encoded_message_len in
let buf = MBytes.create len in
match Data_encoding.Binary.write encoding message buf header_length with
match Data_encoding.Binary.write
encoding message buf Crypto.header_length with
| None ->
fail Encoding_error
| Some last ->
@ -91,8 +128,9 @@ module Connection_message = struct
P2p_io_scheduler.write fd buf
let read fd =
let header_buf = MBytes.create header_length in
P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () ->
let header_buf = MBytes.create Crypto.header_length in
P2p_io_scheduler.read_full
~len:Crypto.header_length fd header_buf >>=? fun () ->
let len = MBytes.get_uint16 header_buf 0 in
let buf = MBytes.create len in
P2p_io_scheduler.read_full ~len fd buf >>=? fun () ->
@ -109,29 +147,25 @@ end
module Ack = struct
type t = bool
type t = Ack | Nack
let ack = MBytes.of_string "\255"
let nack = MBytes.of_string "\000"
let write fd b =
match b with
| true ->
P2p_io_scheduler.write fd ack
| false ->
P2p_io_scheduler.write fd nack
let write cryptobox_data fd b =
Crypto.write_chunk cryptobox_data fd
(match b with Ack -> ack | Nack -> nack)
let read fd =
let buf = MBytes.create 1 in
P2p_io_scheduler.read_full fd buf >>=? fun () ->
let read fd cryptobox_data =
Crypto.read_chunk fd cryptobox_data >>=? fun buf ->
return (buf <> nack)
end
type authenticated_fd =
P2p_io_scheduler.connection * Connection_info.t * cryptobox_data
P2p_io_scheduler.connection * Connection_info.t * Crypto.data
let kick (fd, _ , _) =
Ack.write fd false >>= fun _ ->
let kick (fd, _ , cryptobox_data) =
Ack.write fd cryptobox_data Nack >>= fun _ ->
P2p_io_scheduler.close fd >>= fun _ ->
Lwt.return_unit
@ -168,14 +202,14 @@ let authenticate
{ Connection_info.gid = remote_gid ; versions = msg.versions ; incoming ;
id_point ; remote_socket_port ;} in
let cryptobox_data =
{ channel_key ; local_nonce ;
{ Crypto.channel_key ; local_nonce ;
remote_nonce = msg.message_nonce } in
return (info, (fd, info, cryptobox_data))
type connection = {
info : Connection_info.t ;
fd : P2p_io_scheduler.connection ;
cryptobox_data : cryptobox_data ;
cryptobox_data : Crypto.data ;
}
module Reader = struct
@ -188,29 +222,13 @@ module Reader = struct
mutable worker: unit Lwt.t ;
}
let read_chunk { fd ; cryptobox_data } =
let header_buf = MBytes.create header_length in
P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () ->
let len = MBytes.get_uint16 header_buf 0 in
let buf = MBytes.create len in
P2p_io_scheduler.read_full ~len fd buf >>=? fun () ->
let remote_nonce = cryptobox_data.remote_nonce in
cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
match
Crypto_box.fast_box_open cryptobox_data.channel_key buf remote_nonce
with
| None ->
fail Decipher_error
| Some buf ->
return buf
let rec read_message st buf =
return (Data_encoding.Binary.of_bytes st.encoding buf)
let rec worker_loop st =
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
read_chunk st.conn >>=? fun buf ->
Crypto.read_chunk st.conn.fd st.conn.cryptobox_data >>=? fun buf ->
read_message st buf
end >>= function
| Ok None ->
@ -258,21 +276,6 @@ module Writer = struct
mutable worker: unit Lwt.t ;
}
let write_chunk { cryptobox_data ; fd } buf =
let header_buf = MBytes.create header_length in
let local_nonce = cryptobox_data.local_nonce in
cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
let encrypted_message =
Crypto_box.fast_box cryptobox_data.channel_key buf local_nonce in
let encrypted_len = MBytes.length encrypted_message in
fail_unless
(encrypted_len < max_content_length)
Invalid_message_size >>=? fun () ->
MBytes.set_int16 header_buf 0 encrypted_len ;
P2p_io_scheduler.write fd header_buf >>=? fun () ->
P2p_io_scheduler.write fd encrypted_message >>=? fun () ->
return ()
let encode_message st msg =
try return (Data_encoding.Binary.to_bytes st.encoding msg)
with _ -> fail Encoding_error
@ -282,7 +285,7 @@ module Writer = struct
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt_pipe.pop st.messages >>= fun (msg, wakener) ->
encode_message st msg >>=? fun buf ->
write_chunk st.conn buf >>= fun res ->
Crypto.write_chunk st.conn.fd st.conn.cryptobox_data buf >>= fun res ->
iter_option wakener ~f:(fun u -> Lwt.wakeup_later u res) ;
Lwt.return res
end >>= function
@ -332,11 +335,14 @@ let accept
?incoming_message_queue_size ?outgoing_message_queue_size
(fd, info, cryptobox_data) encoding =
Lwt_utils.protect begin fun () ->
Ack.write fd true >>=? fun () ->
Ack.read fd
Ack.write fd cryptobox_data Ack >>=? fun () ->
Ack.read fd cryptobox_data
end ~on_error:begin fun err ->
P2p_io_scheduler.close fd >>= fun _ ->
Lwt.return (Error err)
match err with
| [ P2p_io_scheduler.Connection_closed ] -> fail Rejected
| [ Decipher_error ] -> fail Invalid_auth
| err -> Lwt.return (Error err)
end >>=? fun accepted ->
fail_unless accepted Rejected >>=? fun () ->
let canceler = Canceler.create () in

1
src/node/net/p2p_connection.mli
View File

@ -26,6 +26,7 @@ type error += Decoding_error
type error += Rejected
type error += Myself of Id_point.t
type error += Not_enough_proof_of_work of Gid.t
type error += Invalid_auth
type authenticated_fd
(** Type of a connection that successfully passed the authentication

20
src/node/net/p2p_connection_pool.ml
View File

@ -634,16 +634,16 @@ let create config meta_config message_config io_sched =
events ;
} in
List.iter (Points.set_trusted pool) config.trusted_points ;
Lwt.catch
(fun () ->
Gid_info.File.load config.peers_file meta_config.encoding)
(fun _ ->
(* TODO log error *)
Lwt.return_nil) >>= fun gids ->
List.iter
(fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
gids ;
Lwt.return pool
Gid_info.File.load config.peers_file meta_config.encoding >>= function
| Ok gids ->
List.iter
(fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
gids ;
Lwt.return pool
| Error err ->
log_error "@[Failed to parsed peers file:@ %a@]"
pp_print_error err ;
Lwt.return pool
let destroy pool =
Point.Table.fold (fun _point pi acc ->

8
src/node/net/p2p_connection_pool_types.ml
View File

@ -449,9 +449,11 @@ module Gid_info = struct
let load path metadata_encoding =
let enc = Data_encoding.list (encoding metadata_encoding) in
Data_encoding_ezjsonm.read_file path >|=
map_option ~f:(Data_encoding.Json.destruct enc) >|=
unopt []
if path <> "/dev/null" && Sys.file_exists path then
Data_encoding_ezjsonm.read_file path >>=? fun json ->
return (Data_encoding.Json.destruct enc json)
else
return []
let save path metadata_encoding peers =
let open Data_encoding in

4
src/node/net/p2p_connection_pool_types.mli
View File

@ -256,10 +256,10 @@ module Gid_info : sig
module File : sig
val load :
string -> 'meta Data_encoding.t ->
('conn, 'meta) gid_info list Lwt.t
('conn, 'meta) gid_info list tzresult Lwt.t
val save :
string -> 'meta Data_encoding.t ->
('conn, 'meta) gid_info list -> bool Lwt.t
('conn, 'meta) gid_info list -> unit tzresult Lwt.t
end
end

10
src/node/net/p2p_io_scheduler.ml
View File

@ -147,7 +147,7 @@ module Scheduler(IO : IO) = struct
canceler = Canceler.create () ;
worker = Lwt.return_unit ;
counter = Moving_average.create ~init:0 ~alpha ;
max_speed ; quota = unopt 0 max_speed ;
max_speed ; quota = unopt ~default:0 max_speed ;
quota_updated = Lwt_condition.create () ;
readys = Lwt_condition.create () ;
readys_high = Queue.create () ;
@ -358,9 +358,9 @@ let write_now { write_queue } msg = Lwt_pipe.push_now write_queue msg
let read_from conn ?pos ?len buf msg =
let maxlen = MBytes.length buf in
let pos = unopt 0 pos in
let pos = unopt ~default:0 pos in
assert (0 <= pos && pos < maxlen) ;
let len = unopt (maxlen - pos) len in
let len = unopt ~default:(maxlen - pos) len in
assert (len <= maxlen - pos) ;
match msg with
| Ok msg ->
@ -400,8 +400,8 @@ let read conn ?pos ?len buf =
let read_full conn ?pos ?len buf =
let maxlen = MBytes.length buf in
let pos = unopt 0 pos in
let len = unopt (maxlen - pos) len in
let pos = unopt ~default:0 pos in
let len = unopt ~default:(maxlen - pos) len in
assert (0 <= pos && pos < maxlen) ;
assert (len <= maxlen - pos) ;
let rec loop pos len =

7
src/node/net/p2p_maintenance.ml
View File

@ -79,6 +79,7 @@ let rec try_to_contact
let contactable =
connectable st start_time max_to_contact in
if contactable = [] then
Lwt_unix.yield () >>= fun () ->
Lwt.return_false
else
List.fold_left
@ -111,11 +112,11 @@ let rec maintain st =
and too_few_connections st n_connected =
let Pool pool = st.pool in
(* too few connections, try and contact many peers *)
lwt_debug "Too few connections (%d)" n_connected >>= fun () ->
lwt_log_notice "Too few connections (%d)" n_connected >>= fun () ->
let min_to_contact = st.bounds.min_target - n_connected in
let max_to_contact = st.bounds.max_target - n_connected in
try_to_contact st min_to_contact max_to_contact >>= fun continue ->
if not continue then begin
try_to_contact st min_to_contact max_to_contact >>= fun success ->
if success then begin
maintain st
end else begin
(* not enough contacts, ask the pals of our pals,

47
src/node/net/p2p_types.ml
View File

@ -193,12 +193,55 @@ module Identity = struct
(req "secret_key" Crypto_box.secret_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
let generate target =
let generate ?max target =
let secret_key, public_key, gid = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work public_key target in
Crypto_box.generate_proof_of_work ?max public_key target in
{ gid ; public_key ; secret_key ; proof_of_work_stamp }
let animation = [|
"|.....|" ;
"|o....|" ;
"|oo...|" ;
"|ooo..|" ;
"|.ooo.|" ;
"|..ooo|" ;
"|...oo|" ;
"|....o|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
|]
let init = String.make (String.length animation.(0)) '\ '
let clean = String.make (String.length animation.(0)) '\b'
let animation = Array.map (fun x -> clean ^ x) animation
let animation_size = Array.length animation
let duration = 1200 / animation_size
let generate_with_animation ppf target =
Format.fprintf ppf "%s%!" init ;
let count = ref 10000 in
let rec loop n =
let start = Mtime.counter () in
Format.fprintf ppf "%s%!" animation.(n mod animation_size);
try generate ~max:!count target
with Not_found ->
let time = Mtime.to_ms (Mtime.count start) in
count :=
if time <= 0. then
!count * 10
else
!count * duration / int_of_float time ;
loop (n+1)
in
let id = loop 0 in
Format.fprintf ppf "%s%s\n%!" clean init ;
id
let generate target = generate target
end
module Connection_info = struct

6
src/node/net/p2p_types.mli
View File

@ -94,6 +94,12 @@ module Identity : sig
val generate : Crypto_box.target -> t
(** [generate target] is a freshly minted identity whose proof of
work stamp difficulty is at least equal to [target]. *)
val generate_with_animation :
Format.formatter -> Crypto_box.target -> t
(** [generate_with_animation ppf target] is a freshly minted identity
whose proof of work stamp difficulty is at least equal to [target]. *)
end

43
src/node/shell/node.ml
View File

@ -211,10 +211,21 @@ let init_p2p net_params =
Lwt.return Tezos_p2p.faked_network
| Some (config, limits) ->
lwt_log_notice "bootstraping network..." >>= fun () ->
Tezos_p2p.bootstrap config limits
Tezos_p2p.create config limits >>= fun p2p ->
Lwt.async (fun () -> Tezos_p2p.maintain p2p) ;
Lwt.return p2p
let create
~genesis ~store_root ~context_root ?test_protocol ?patch_context net_params =
type config = {
genesis: Store.genesis ;
store_root: string ;
context_root: string ;
test_protocol: Protocol_hash.t option ;
patch_context: (Context.t -> Context.t Lwt.t) option ;
p2p: (P2p.config * P2p.limits) option ;
}
let create { genesis ; store_root ; context_root ;
test_protocol ; patch_context ; p2p = net_params } =
lwt_debug "-> Node.create" >>= fun () ->
init_p2p net_params >>= fun p2p ->
lwt_log_info "reading state..." >>= fun () ->
@ -234,11 +245,12 @@ let create
end >>=? fun global_net ->
Validator.activate validator global_net >>= fun global_validator ->
let cleanup () =
Tezos_p2p.shutdown p2p >>= fun () ->
Lwt.join [ Validator.shutdown validator ;
Discoverer.shutdown discoverer ] >>= fun () ->
State.store state
in
let canceler = Lwt_utils.Canceler.create () in
lwt_log_info "starting worker..." >>= fun () ->
let worker =
let handle_msg peer msg =
@ -249,22 +261,23 @@ let create
Lwt.return_unit
in
let rec worker_loop () =
Tezos_p2p.recv p2p >>= fun (peer, msg) ->
Lwt_utils.protect ~canceler begin fun () ->
Tezos_p2p.recv p2p >>= return
end >>=? fun (peer, msg) ->
handle_msg peer msg >>= fun () ->
worker_loop () in
Lwt.catch
worker_loop
(function
| Queue.Empty -> cleanup ()
| exn ->
lwt_log_error "unexpected exception in worker\n%s"
(Printexc.to_string exn) >>= fun () ->
Tezos_p2p.shutdown p2p >>= fun () ->
cleanup ())
worker_loop () >>= function
| Error [Lwt_utils.Canceled] | Ok () ->
cleanup ()
| Error err ->
lwt_log_error
"@[Unexpected error in worker@ %a@]"
pp_print_error err >>= fun () ->
cleanup ()
in
let shutdown () =
lwt_log_info "stopping worker..." >>= fun () ->
Tezos_p2p.shutdown p2p >>= fun () ->
Lwt_utils.Canceler.cancel canceler >>= fun () ->
worker >>= fun () ->
lwt_log_info "stopped"
in

18
src/node/shell/node.mli
View File

@ -9,14 +9,16 @@
type t
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
type config = {
genesis: Store.genesis ;
store_root: string ;
context_root: string ;
test_protocol: Protocol_hash.t option ;
patch_context: (Context.t -> Context.t Lwt.t) option ;
p2p: (P2p.config * P2p.limits) option ;
}
val create: config -> t tzresult Lwt.t
module RPC : sig

6
src/node/shell/node_rpc.ml
View File

@ -394,9 +394,9 @@ let build_rpc_directory node =
let dir =
let implementation (net_id, pred, time, fitness, operations, header) =
Node.RPC.block_info node (`Head 0) >>= fun bi ->
let timestamp = Utils.unopt (Time.now ()) time in
let net_id = Utils.unopt bi.net net_id in
let predecessor = Utils.unopt bi.hash pred in
let timestamp = Utils.unopt ~default:(Time.now ()) time in
let net_id = Utils.unopt ~default:bi.net net_id in
let predecessor = Utils.unopt ~default:bi.hash pred in
let res =
Store.Block.to_bytes {
shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;

105
src/node/shell/node_rpc_services.ml
View File

@ -524,7 +524,7 @@ let inject_block =
(fun (block, blocking, force) ->
(block, Some blocking, force))
(fun (block, blocking, force) ->
(block, Utils.unopt true blocking, force))
(block, Utils.unopt ~default:true blocking, force))
(obj3
(req "data" bytes)
(opt "blocking"
@ -555,25 +555,23 @@ let inject_operation =
RPCs ubder /blocks/prevalidation for more details on the \
prevalidation context."
~input:
(conv
(fun (block, blocking, force) -> (block, Some blocking, force))
(fun (block, blocking, force) -> (block, unopt true blocking, force))
(obj3
(req "signedOperationContents"
(describe ~title: "Tezos signed operation (hex encoded)"
bytes))
(opt "blocking"
(describe
~description:
"Should the RPC wait for the operation to be \
(pre-)validated before to answer. (default: true)"
bool))
(opt "force"
(describe
~description:
"Should we inject operation that are \"branch_refused\" \
or \"branch_delayed\". (default: false)"
bool))))
(obj3
(req "signedOperationContents"
(describe ~title: "Tezos signed operation (hex encoded)"
bytes))
(dft "blocking"
(describe
~description:
"Should the RPC wait for the operation to be \
(pre-)validated before to answer. (default: true)"
bool)
true)
(opt "force"
(describe
~description:
"Should we inject operation that are \"branch_refused\" \
or \"branch_delayed\". (default: false)"
bool)))
~output:
(Error.wrap @@
describe
@ -582,21 +580,6 @@ let inject_operation =
RPC.Path.(root / "inject_operation")
let inject_protocol =
let proto =
(list
(obj3
(req "name"
(describe ~title:"OCaml module name"
string))
(opt "interface"
(describe
~description:"Content of the .mli file"
string))
(req "implementation"
(describe
~description:"Content of the .ml file"
string))))
in
let proto_of_rpc =
List.map (fun (name, interface, implementation) ->
{ Tezos_compiler.Protocol.name; interface; implementation })
@ -605,28 +588,44 @@ let inject_protocol =
List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } ->
(name, interface, implementation))
in
let proto =
conv
rpc_of_proto
proto_of_rpc
(list
(obj3
(req "name"
(describe ~title:"OCaml module name"
string))
(opt "interface"
(describe
~description:"Content of the .mli file"
string))
(req "implementation"
(describe
~description:"Content of the .ml file"
string))))
in
RPC.service
~description:
"Inject a protocol in node. Returns the ID of the protocol."
~input:
(conv
(fun (proto, blocking, force) -> (rpc_of_proto proto, Some blocking, force))
(fun (proto, blocking, force) -> (proto_of_rpc proto, unopt true blocking, force))
(obj3
(req "protocol"
(describe ~title: "Tezos protocol"
proto))
(opt "blocking"
(describe
~description:
"Should the RPC wait for the protocol to be \
validated before to answer. (default: true)"
bool))
(opt "force"
(describe
~description:
"Should we inject protocol that is invalid. (default: false)"
bool))))
(obj3
(req "protocol"
(describe ~title: "Tezos protocol"
proto))
(dft "blocking"
(describe
~description:
"Should the RPC wait for the protocol to be \
validated before to answer. (default: true)"
bool)
true)
(opt "force"
(describe
~description:
"Should we inject protocol that is invalid. (default: false)"
bool)))
~output:
(Error.wrap @@
describe

3
src/node/shell/state.ml
View File

@ -699,7 +699,8 @@ module Valid_block = struct
(* TODO check coherency: test_protocol. *)
Lwt.return res
| None ->
let test_protocol = Utils.unopt genesis.protocol test_protocol in
let test_protocol =
Utils.unopt ~default:genesis.protocol test_protocol in
Context.create_genesis_context
vstate.index genesis test_protocol >>= fun _context ->
Block.db_store vstate.block_db genesis.block {

4
src/node/shell/tezos_p2p.ml
View File

@ -106,8 +106,8 @@ and msg_cfg : _ P2p.message_config = {
type net = (Message.t, Metadata.t) P2p.net
let bootstrap ~config ~limits =
P2p.bootstrap ~config ~limits meta_cfg msg_cfg
let create ~config ~limits =
P2p.create ~config ~limits meta_cfg msg_cfg
let broadcast = P2p.broadcast
let try_send = P2p.try_send

2
src/node/shell/tezos_p2p.mli
View File

@ -8,7 +8,7 @@ type net
val faked_network : net
(** Main network initialisation function *)
val bootstrap : config:config -> limits:limits -> net Lwt.t
val create : config:config -> limits:limits -> net Lwt.t
(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : net -> unit Lwt.t

1109
src/node_main.ml
View File

File diff suppressed because it is too large Load Diff

56
src/utils/crypto_box.ml
View File

@ -15,7 +15,7 @@ type secret_key = Sodium.Box.secret_key
type public_key = Sodium.Box.public_key
type channel_key = Sodium.Box.channel_key
type nonce = Sodium.Box.nonce
type target = int64 list (* used as unsigned intergers... *)
type target = Z.t
exception TargetNot256Bit
module Public_key_hash = Hash.Make_Blake2B (Base48) (struct
@ -44,24 +44,29 @@ let fast_box_open ck msg nonce =
try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with
| Sodium.Verification_failure -> None
let make_target target =
if List.length target > 8 then raise TargetNot256Bit ;
target
(* Compare a SHA256 hash to a 256bits-target prefix.
The prefix is a list of "unsigned" int64. *)
let compare_target hash target =
let hash = Hash.Generic_hash.to_string hash in
let rec check offset = function
| [] -> true
| x :: xs ->
Compare.Uint64.(EndianString.BigEndian.get_int64 hash offset <= x)
&& check (offset + 8) xs in
check 0 target
let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in
Z.compare hash target <= 0
let default_target =
(* FIXME we use an easy target until we allow custom configuration. *)
[ Int64.shift_left 1L 48 ]
let make_target f =
if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
let frac, shift = modf f in
let shift = int_of_float shift in
let m =
Z.of_int64 @@
if frac = 0. then
Int64.(pred (shift_left 1L 54))
else
Int64.of_float (2. ** (54. -. frac))
in
if shift < 202 then
Z.logor
(Z.shift_left m (202 - shift))
(Z.pred @@ Z.shift_left Z.one (202 - shift))
else
Z.shift_right m (shift - 202)
let default_target = make_target 24.
let check_proof_of_work pk nonce target =
let hash =
@ -71,11 +76,18 @@ let check_proof_of_work pk nonce target =
] in
compare_target hash target
let generate_proof_of_work pk target =
let rec loop nonce =
if check_proof_of_work pk nonce target then nonce
else loop (increment_nonce nonce) in
loop (random_nonce ())
let generate_proof_of_work ?max pk target =
let may_interupt =
match max with
| None -> (fun _ -> ())
| Some max -> (fun cpt -> if max < cpt then raise Not_found) in
let rec loop nonce cpt =
may_interupt cpt ;
if check_proof_of_work pk nonce target then
nonce
else
loop (increment_nonce nonce) (cpt + 1) in
loop (random_nonce ()) 0
let public_key_encoding =
let open Data_encoding in

4
src/utils/crypto_box.mli
View File

@ -16,8 +16,8 @@ val increment_nonce : ?step:int -> nonce -> nonce
val nonce_encoding : nonce Data_encoding.t
type target
val make_target : (* unsigned *) Int64.t list -> target
val default_target : target
val make_target : float -> target
type secret_key
type public_key
@ -38,5 +38,5 @@ val fast_box : channel_key -> MBytes.t -> nonce -> MBytes.t
val fast_box_open : channel_key -> MBytes.t -> nonce -> MBytes.t option
val check_proof_of_work : public_key -> nonce -> target -> bool
val generate_proof_of_work : public_key -> target -> nonce
val generate_proof_of_work : ?max:int -> public_key -> target -> nonce

35
src/utils/data_encoding_ezjsonm.ml
View File

@ -7,6 +7,8 @@
(* *)
(**************************************************************************)
open Error_monad
let to_root = function
| `O ctns -> `O ctns
| `A ctns -> `A ctns
@ -35,22 +37,21 @@ let from_stream (stream: string Lwt_stream.t) =
let write_file file json =
let json = to_root json in
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Output file (fun chan ->
let str = to_string json in
write chan str >>= fun _ ->
return true)))
(fun _ -> return false)
protect begin fun () ->
Lwt_io.with_file ~mode:Output file begin fun chan ->
let str = to_string json in
Lwt_io.write chan str >>= fun _ ->
return ()
end
end
let read_file file =
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Input file (fun chan ->
read chan >>= fun str ->
return (Some (Ezjsonm.from_string str :> Data_encoding.json)))))
(fun _ ->
(* TODO log error or use Error_monad. *)
return None)
protect begin fun () ->
Lwt_io.with_file ~mode:Input file begin fun chan ->
Lwt_io.read chan >>= fun str ->
return (Ezjsonm.from_string str :> Data_encoding.json)
end
end
let () =
Error_monad.json_to_string := to_string

6
src/utils/data_encoding_ezjsonm.mli
View File

@ -7,6 +7,8 @@
(* *)
(**************************************************************************)
open Error_monad
(** Read a JSON document from a string. *)
val from_string : string -> (Data_encoding.json, string) result
@ -20,7 +22,7 @@ val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt
val to_string : Data_encoding.json -> string
(** Loads a JSON file in memory *)
val read_file : string -> Data_encoding.json option Lwt.t
val read_file : string -> Data_encoding.json tzresult Lwt.t
(** (Over)write a JSON file from in memory data *)
val write_file : string -> Data_encoding.json -> bool Lwt.t
val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t

29
src/utils/error_monad.ml
View File

@ -16,12 +16,15 @@ type error_category = [ `Branch | `Temporary | `Permanent ]
type 'err full_error_category =
[ error_category | `Wrapped of 'err -> error_category ]
(* HACK: forward reference from [Data_encoding_ezjsonm] *)
let json_to_string = ref (fun _ -> "")
let json_pp id encoding ppf x =
Format.pp_print_string ppf @@
!json_to_string @@
let encoding =
Data_encoding.(merge_objs (obj1 (req "id" string)) encoding) in
Format.pp_print_string ppf @@
Data_encoding_ezjsonm.to_string @@
Data_encoding.Json.(construct encoding (id, x))
Data_encoding.Json.construct encoding (id, x)
module Make() = struct
@ -76,7 +79,7 @@ module Make() = struct
category ;
from_error ;
encoding_case ;
pp = Utils.unopt (json_pp name encoding) pp } :: !error_kinds
pp = Utils.unopt ~default:(json_pp name encoding) pp } :: !error_kinds
let register_wrapped_error_kind
category ~id ~title ~description ?pp
@ -176,11 +179,6 @@ module Make() = struct
let fail s = Lwt.return (Error [ s ])
let protect ~on_error t =
t >>= function
| Ok res -> return res
| Error err -> on_error err
let (>>?) v f =
match v with
| Error _ as err -> err
@ -327,6 +325,11 @@ let () =
error_kinds :=
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
let protect ~on_error t =
t >>= function
| Ok res -> return res
| Error err -> on_error err
end
include Make()
@ -342,6 +345,14 @@ let error_exn s = Error [ Exn s ]
let trace_exn exn f = trace (Exn exn) f
let record_trace_exn exn f = record_trace (Exn exn) f
let protect ?on_error t =
Lwt.catch t (fun exn -> fail (Exn exn)) >>= function
| Ok res -> return res
| Error err ->
match on_error with
| Some f -> f err
| None -> Lwt.return (Error err)
let pp_exn ppf exn = pp ppf (Exn exn)
let () =

7
src/utils/error_monad.mli
View File

@ -26,6 +26,10 @@ val failwith :
('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 ->
'a
val protect :
?on_error: (error list -> 'a tzresult Lwt.t) ->
(unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
val error_exn : exn -> 'a tzresult
val record_trace_exn : exn -> 'a tzresult -> 'a tzresult
val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
@ -35,3 +39,6 @@ type error += Exn of exn
type error += Unclassified of string
module Make() : Error_monad_sig.S
(**/**)
val json_to_string : (Data_encoding.json -> string) ref

134
src/utils/logging.ml
View File

@ -7,6 +7,8 @@
(* *)
(**************************************************************************)
open Lwt.Infix
module type LOG = sig
val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
@ -86,32 +88,134 @@ module Client = struct
end
module Webclient = Make(struct let name = "webclient" end)
let template = "$(date) $(name)[$(pid)]: $(message)"
let default_logger () =
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
type template = Lwt_log.template
let default_template = "$(date) - $(section): $(message)"
type kind =
| Null
| Stdout
| Stderr
| File of string
| Syslog
| Manual of Lwt_log.logger
| Syslog of Lwt_log.syslog_facility
let init kind =
let logger =
let kind_encoding =
let open Data_encoding in
conv
(function
| Null -> "/dev/null"
| Stdout -> "stdout"
| Stderr -> "stderr"
| File fp -> fp
| Syslog `Auth -> "syslog:auth"
| Syslog `Authpriv -> "syslog:authpriv"
| Syslog `Cron -> "syslog:cron"
| Syslog `Daemon -> "syslog:daemon"
| Syslog `FTP -> "syslog:ftp"
| Syslog `Kernel -> "syslog:kernel"
| Syslog `Local0 -> "syslog:local0"
| Syslog `Local1 -> "syslog:local1"
| Syslog `Local2 -> "syslog:local2"
| Syslog `Local3 -> "syslog:local3"
| Syslog `Local4 -> "syslog:local4"
| Syslog `Local5 -> "syslog:local5"
| Syslog `Local6 -> "syslog:local6"
| Syslog `Local7 -> "syslog:local7"
| Syslog `LPR -> "syslog:lpr"
| Syslog `Mail -> "syslog:mail"
| Syslog `News -> "syslog:news"
| Syslog `Syslog -> "syslog:syslog"
| Syslog `User -> "syslog:user"
| Syslog `UUCP -> "syslog:uucp"
| Syslog `NTP -> "syslog:ntp"
| Syslog `Security -> "syslog:security"
| Syslog `Console -> "syslog:console")
(function
| "/dev/null" | "null" -> Null
| "stdout" -> Stdout
| "stderr" -> Stderr
| "syslog:auth" -> Syslog `Auth
| "syslog:authpriv" -> Syslog `Authpriv
| "syslog:cron" -> Syslog `Cron
| "syslog:daemon" -> Syslog `Daemon
| "syslog:ftp" -> Syslog `FTP
| "syslog:kernel" -> Syslog `Kernel
| "syslog:local0" -> Syslog `Local0
| "syslog:local1" -> Syslog `Local1
| "syslog:local2" -> Syslog `Local2
| "syslog:local3" -> Syslog `Local3
| "syslog:local4" -> Syslog `Local4
| "syslog:local5" -> Syslog `Local5
| "syslog:local6" -> Syslog `Local6
| "syslog:local7" -> Syslog `Local7
| "syslog:lpr" -> Syslog `LPR
| "syslog:mail" -> Syslog `Mail
| "syslog:news" -> Syslog `News
| "syslog:syslog" -> Syslog `Syslog
| "syslog:user" -> Syslog `User
| "syslog:uucp" -> Syslog `UUCP
| "syslog:ntp" -> Syslog `NTP
| "syslog:security" -> Syslog `Security
| "syslog:console" -> Syslog `Console
(* | s when start_with "syslog:" FIXME error or warning. *)
| fp ->
(* TODO check absolute path *)
File fp)
string
let init ?(template = default_template) kind =
begin
match kind with
| Stderr ->
default_logger ()
Lwt.return @@
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
| Stdout ->
Lwt.return @@
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
| File file_name ->
Lwt_main.run (Lwt_log.file ~file_name ~template ())
Lwt_log.file ~file_name ~template ()
| Null ->
Lwt.return @@
Lwt_log.null
| Syslog ->
Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!";
default_logger ()
| Manual logger -> logger in
Lwt_log.default := logger
| Syslog facility ->
Lwt.return @@
Lwt_log.syslog ~template ~facility ()
end >>= fun logger ->
Lwt_log.default := logger ;
Lwt.return_unit
type level = Lwt_log_core.level =
| Debug
(** Debugging message. They can be automatically removed by the
syntax extension. *)
| Info
(** Informational message. Suitable to be displayed when the
program is in verbose mode. *)
| Notice
(** Same as {!Info}, but is displayed by default. *)
| Warning
(** Something strange happend *)
| Error
(** An error message, which should not means the end of the
program. *)
| Fatal
let level_encoding =
let open Data_encoding in
conv
(function
| Fatal -> "fatal"
| Error -> "error"
| Warning -> "warning"
| Notice -> "notice"
| Info -> "info"
| Debug -> "debug")
(function
| "error" -> Error
| "warn" -> Warning
| "notice" -> Notice
| "info" -> Info
| "debug" -> Debug
| "fatal" -> Fatal
| _ -> invalid_arg "Logging.level")
string

28
src/utils/logging.mli
View File

@ -48,12 +48,34 @@ module Webclient : LOG
module Make(S: sig val name: string end) : LOG
type level = Lwt_log_core.level =
| Debug
(** Debugging message. They can be automatically removed by the
syntax extension. *)
| Info
(** Informational message. Suitable to be displayed when the
program is in verbose mode. *)
| Notice
(** Same as {!Info}, but is displayed by default. *)
| Warning
(** Something strange happend *)
| Error
(** An error message, which should not means the end of the
program. *)
| Fatal
type template = Lwt_log.template
val default_template : template
val level_encoding : level Data_encoding.t
type kind =
| Null
| Stdout
| Stderr
| File of string
| Syslog
| Manual of Lwt_log.logger
| Syslog of Lwt_log.syslog_facility
val init: kind -> unit
val kind_encoding : kind Data_encoding.t
val init: ?template:template -> kind -> unit Lwt.t

16
src/utils/lwt_utils.ml
View File

@ -346,12 +346,14 @@ let remove_dir dir =
Lwt.return ()
let rec create_dir ?(perm = 0o755) dir =
if Sys.file_exists dir then
Lwt.return ()
else begin
create_dir (Filename.dirname dir) >>= fun () ->
Lwt_unix.mkdir dir perm
end
Lwt_unix.file_exists dir >>= function
| false ->
create_dir (Filename.dirname dir) >>= fun () ->
Lwt_unix.mkdir dir perm
| true ->
Lwt_unix.stat dir >>= function
| {st_kind = S_DIR} -> Lwt.return_unit
| _ -> failwith "Not a directory"
let create_file ?(perm = 0o644) name content =
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
@ -402,4 +404,6 @@ let with_timeout ?(canceler = Canceler.create ()) timeout f =
Canceler.cancel canceler >>= fun () ->
fail Timeout
let unless cond f =
if cond then Lwt.return () else f ()

2
src/utils/lwt_utils.mli
View File

@ -67,3 +67,5 @@ val with_timeout:
?canceler:Canceler.t ->
float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
val unless: bool -> (unit -> unit Lwt.t) -> unit Lwt.t

10
test/lib/assert.ml
View File

@ -14,6 +14,16 @@ include Kaputt.Assertion
let format_msg = function None -> None | Some msg -> Some (msg ^ "\n")
let is_error ?(msg="") x =
match x with
| Error _ -> ()
| Ok _ -> fail "Error _" "Ok _" msg
let is_ok ?(msg="") x =
match x with
| Ok _ -> ()
| Error _ -> fail "Ok _" "Error _" msg
let equal_persist_list ?msg l1 l2 =
let msg = format_msg msg in
let pr_persist l =

4
test/lib/assert.mli
View File

@ -8,8 +8,12 @@
(**************************************************************************)
open Hash
open Error_monad
include (module type of struct include Kaputt.Assertion end)
val is_ok : ?msg:string -> 'a tzresult -> unit
val is_error : ?msg:string -> 'a tzresult -> unit
val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a
val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a

5
test/lib/process.ml
View File

@ -19,11 +19,8 @@ let detach ?(prefix = "") f =
| 0 ->
Random.self_init () ;
let template = Format.asprintf "%s$(section): $(message)" prefix in
let logger =
Lwt_log.channel
~template ~close_mode:`Keep ~channel:Lwt_io.stderr () in
Logging.init (Manual logger) ;
Lwt_main.run begin
Logging.init ~template Stderr >>= fun () ->
lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () ->
f ()
end ;

8
test/test-basic.sh
View File

@ -5,8 +5,8 @@ set -e
DIR=$(dirname "$0")
cd "${DIR}"
DATA_DIR=$(mktemp -d /tmp/tezos_node.XXXXXXXXXX)
CLIENT_DIR=$(mktemp -d /tmp/tezos_client.XXXXXXXXXX)
DATA_DIR="$(mktemp -td tezos_node.XXXXXXXXXX)"
CLIENT_DIR="$(mktemp -td tezos_client.XXXXXXXXXX)"
cleanup() {
rm -fr ${DATA_DIR} ${CLIENT_DIR}
@ -17,8 +17,8 @@ trap cleanup EXIT QUIT INT
NODE=../tezos-node
CLIENT="../tezos-client -base-dir ${CLIENT_DIR}"
CUSTOM_PARAM="--sandbox-param ./sandbox.json"
${NODE} --sandbox "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 &
CUSTOM_PARAM="--sandbox ./sandbox.json"
${NODE} --base-dir "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 &
NODE_PID="$!"
sleep 3

4
test/test_basic.ml
View File

@ -50,8 +50,8 @@ let fork_node () =
Unix.create_process
Filename.(concat (dirname (Sys.getcwd ())) "tezos-node")
[| "tezos-node" ;
"--sandbox"; data_dir ;
"--sandbox-param"; "./sandbox.json";
"--base-dir"; data_dir ;
"--sandbox"; "./sandbox.json";
"--rpc-addr"; ":::8732" |]
null_fd log_fd log_fd in
Printf.printf "Created node, pid: %d, log: %s\n%!" pid log_file_name ;

14
test/test_data_encoding.ml
View File

@ -110,11 +110,11 @@ let test_json testdir =
let f_str = to_string v in
Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]";
read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
Assert.is_none ~msg:__LOC__ rf;
Assert.is_error ~msg:__LOC__ rf ;
write_file file v >>= fun success ->
Assert.is_true ~msg:__LOC__ success;
Assert.is_ok ~msg:__LOC__ success ;
read_file file >>= fun opt ->
Assert.is_some ~msg:__LOC__ opt;
Assert.is_ok ~msg:__LOC__ opt ;
Lwt.return ()
type t = A of int | B of string | C of int | D of string | E
@ -269,8 +269,8 @@ let test_json_input testdir =
|}
in
Data_encoding_ezjsonm.read_file file >>= function
None -> Assert.fail_msg "Cannot parse \"good.json\"."
| Some json ->
| Error _ -> Assert.fail_msg "Cannot parse \"good.json\"."
| Ok json ->
let (id, value, popup) = Json.destruct enc json in
Assert.equal_string ~msg:__LOC__ "file" id;
Assert.equal_string ~msg:__LOC__ "File" value;
@ -295,8 +295,8 @@ let test_json_input testdir =
|}
in
Data_encoding_ezjsonm.read_file file >>= function
None -> Assert.fail_msg "Cannot parse \"unknown.json\"."
| Some json ->
| Error _ -> Assert.fail_msg "Cannot parse \"unknown.json\"."
| Ok json ->
Assert.test_fail ~msg:__LOC__
(fun () -> ignore (Json.destruct enc json))
(function

15
test/test_p2p_connection.ml
View File

@ -14,14 +14,13 @@ open Error_monad
open P2p_types
include Logging.Make (struct let name = "test-p2p-connection" end)
let proof_of_work_target =
Crypto_box.make_target [Int64.shift_left 1L 48]
let proof_of_work_target = Crypto_box.make_target 16.
let id1 = Identity.generate proof_of_work_target
let id2 = Identity.generate proof_of_work_target
let id0 =
(* Luckilly, this will be an insuficient proof of work! *)
Identity.generate (Crypto_box.make_target [])
Identity.generate (Crypto_box.make_target 0.)
let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
@ -83,11 +82,17 @@ let simple_msg =
let is_rejected = function
| Error [P2p_connection.Rejected] -> true
| Ok _ | Error _ -> false
| Ok _ -> false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
false
let is_connection_closed = function
| Error [P2p_io_scheduler.Connection_closed] -> true
| Ok _ | Error _ -> false
| Ok _ -> false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
false
let bytes_encoding = Data_encoding.Variable.bytes

14
test/test_p2p_connection_pool.ml
View File

@ -126,7 +126,7 @@ let run_net config repeat points addr port =
let make_net points repeat n =
let point, points = Utils.select n points in
let proof_of_work_target = Crypto_box.make_target [] in
let proof_of_work_target = Crypto_box.make_target 0. in
let identity = Identity.generate proof_of_work_target in
let config = P2p_connection_pool.{
identity ;
@ -158,7 +158,7 @@ let make_net points repeat n =
let addr = ref Ipaddr.V6.localhost
let port = ref (1024 + Random.int 8192)
let clients = ref 10
let repeat = ref 5
let repeat_connections = ref 5
let spec = Arg.[
@ -169,7 +169,8 @@ let spec = Arg.[
"--clients", Set_int clients, " Number of concurrent clients." ;
"--repeat", Set_int repeat, " Number of connections/disconnections." ;
"--repeat", Set_int repeat_connections,
" Number of connections/disconnections." ;
"-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)),
" Log up to info msgs" ;
@ -181,16 +182,15 @@ let spec = Arg.[
let main () =
let open Utils in
Logging.init Stderr >>= fun () ->
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
let ports = !port -- (!port + !clients - 1) in
let points = List.map (fun port -> !addr, port) ports in
Lwt_list.iter_p (make_net points !repeat) (0 -- (!clients - 1))
Lwt_list.iter_p (make_net points !repeat_connections) (0 -- (!clients - 1))
let () =
Sys.catch_break true ;
try
Logging.init Stderr ;
Lwt_main.run @@ main ()
try Lwt_main.run @@ main ()
with _ -> ()

2
test/test_p2p_io_scheduler.ml
View File

@ -140,7 +140,7 @@ let run
?max_download_speed ?max_upload_speed
~read_buffer_size ?read_queue_size ?write_queue_size
addr port time n =
Logging.init Stderr ;
Logging.init Stderr >>= fun () ->
listen ?port addr >>= fun (main_socket, port) ->
let server =
Process.detach ~prefix:"server " begin fun () ->

2
test/test_state.ml
View File

@ -39,7 +39,7 @@ let incr_fitness fitness =
| [ _ ; fitness ] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Utils.unopt 0L
|> Utils.unopt ~default:0L
|> Int64.succ
|> Data_encoding.Binary.to_bytes Data_encoding.int64
)