From d6f79edae2a52960215b680aca55931a9875a225 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 16 Apr 2018 00:44:24 +0200 Subject: [PATCH] Shell/RPC: rework `/blocks` - start using `GET` and query parameters instead of `POST` when meaningful - inline parsed protocol data and metadata in block headers - inline parsed protocol data and metadata in operations - split the RPC in four categories: - static data, available explicitly in block headers and operations - static "metadata", information that were computed while validating a block or an operation, but which are not explicit in the block header (e.g. the baker of a block, the list of internal transfer... (currently not implemented, but that's WIP)) - "context" all the static data we may read in the context (contracts balance, list of delegates, ...) - "helpers" are some RPC that may perform some computation. --- docs/doc_gen/rpcs/usage.rst | 2 +- docs/introduction/alphanet.rst | 2 +- docs/introduction/howto.rst | 6 +- scripts/alphanet.sh | 4 +- scripts/docker/entrypoint.inc.sh | 4 +- src/bin_client/main_client.ml | 2 +- src/bin_client/test/test_basic.sh | 14 +- src/bin_client/test/test_cors.sh | 7 +- src/bin_client/test/test_fork.sh | 2 +- src/bin_client/test/test_injection.sh | 4 +- src/bin_client/test/test_injection_alpha.sh | 2 +- src/bin_client/test/test_multinode.sh | 6 +- src/bin_client/tezos-init-sandboxed-client.sh | 6 +- src/bin_node/node_run_command.ml | 2 +- src/lib_client_base/client_confirmations.ml | 107 +- src/lib_client_base/client_confirmations.mli | 1 + .../client_admin_commands.ml | 2 +- .../client_helpers_commands.ml | 2 +- .../client_report_commands.ml | 66 +- .../sigs/v1/updater.mli | 4 +- .../tezos_protocol_environment.ml | 42 +- .../tezos_protocol_environment.mli | 10 +- src/lib_protocol_updater/jbuild | 2 + .../registered_protocol.ml | 27 +- .../registered_protocol.mli | 9 +- src/lib_shell/block_directory.ml | 340 +++++ src/lib_shell/block_directory.mli | 15 + src/lib_shell/chain_directory.ml | 159 +++ .../chain_directory.mli} | 15 +- src/lib_shell/node.ml | 437 +----- src/lib_shell/node.mli | 92 +- src/lib_shell/node_rpc.ml | 503 ------- src/lib_shell/prevalidation.ml | 53 +- src/lib_shell/prevalidation.mli | 9 + src/lib_shell/protocol_directory.ml | 57 + src/lib_shell/protocol_directory.mli | 11 + src/lib_shell/shell_directory.ml | 179 +++ src/lib_shell/shell_directory.mli | 11 + src/lib_shell/state.ml | 30 + src/lib_shell/state.mli | 13 +- src/lib_shell/worker_directory.ml | 88 ++ .../{node_rpc.mli => worker_directory.mli} | 2 +- src/lib_shell_services/block_services.ml | 1269 +++++++++++------ src/lib_shell_services/block_services.mli | 586 +++++--- src/lib_shell_services/chain_services.ml | 228 +++ src/lib_shell_services/chain_services.mli | 126 ++ src/lib_shell_services/jbuild | 2 +- src/lib_shell_services/mempool_services.ml | 48 - src/lib_shell_services/shell_services.ml | 82 +- src/lib_shell_services/shell_services.mli | 39 +- src/lib_shell_services/worker_services.ml | 6 - .../lib_baking/client_baking_blocks.ml | 86 +- .../lib_baking/client_baking_blocks.mli | 25 +- .../lib_baking/client_baking_daemon.ml | 13 +- .../lib_baking/client_baking_daemon.mli | 1 - .../lib_baking/client_baking_endorsement.ml | 48 +- .../lib_baking/client_baking_endorsement.mli | 3 +- .../lib_baking/client_baking_forge.ml | 164 +-- .../lib_baking/client_baking_forge.mli | 9 +- .../lib_baking/client_baking_lib.ml | 6 +- .../lib_baking/client_baking_lib.mli | 1 + .../lib_baking/client_baking_revelation.ml | 15 +- .../lib_baking/client_baking_revelation.mli | 2 + .../lib_baking/test/proto_alpha_helpers.ml | 112 +- .../lib_baking/test/proto_alpha_helpers.mli | 14 +- src/proto_alpha/lib_baking/test/test_rpc.ml | 21 +- src/proto_alpha/lib_baking/test/test_vote.ml | 2 +- .../lib_client/client_proto_context.ml | 99 +- .../lib_client/client_proto_context.mli | 41 +- .../lib_client/client_proto_contracts.ml | 8 +- .../lib_client/client_proto_contracts.mli | 6 +- .../lib_client/client_proto_programs.ml | 56 +- .../lib_client/client_proto_programs.mli | 28 +- src/proto_alpha/lib_client/injection.ml | 33 +- src/proto_alpha/lib_client/injection.mli | 6 +- src/proto_alpha/lib_client/proto_alpha.ml | 22 +- .../client_proto_context_commands.ml | 100 +- .../client_proto_programs_commands.ml | 18 +- .../lib_protocol/src/alpha_services.ml | 92 -- .../lib_protocol/src/alpha_services.mli | 9 - .../lib_protocol/src/block_header_repr.ml | 29 +- .../lib_protocol/src/services_registration.ml | 15 +- .../lib_protocol/test/helpers/block.ml | 6 +- .../lib_protocol/test/helpers/incremental.ml | 11 +- .../lib_client/client_proto_main.ml | 11 +- src/proto_genesis/lib_client/proto_genesis.ml | 7 +- 86 files changed, 3384 insertions(+), 2470 deletions(-) create mode 100644 src/lib_shell/block_directory.ml create mode 100644 src/lib_shell/block_directory.mli create mode 100644 src/lib_shell/chain_directory.ml rename src/{lib_shell_services/mempool_services.mli => lib_shell/chain_directory.mli} (67%) delete mode 100644 src/lib_shell/node_rpc.ml create mode 100644 src/lib_shell/protocol_directory.ml create mode 100644 src/lib_shell/protocol_directory.mli create mode 100644 src/lib_shell/shell_directory.ml create mode 100644 src/lib_shell/shell_directory.mli create mode 100644 src/lib_shell/worker_directory.ml rename src/lib_shell/{node_rpc.mli => worker_directory.mli} (91%) create mode 100644 src/lib_shell_services/chain_services.ml create mode 100644 src/lib_shell_services/chain_services.mli delete mode 100644 src/lib_shell_services/mempool_services.ml diff --git a/docs/doc_gen/rpcs/usage.rst b/docs/doc_gen/rpcs/usage.rst index 529b46a00..8b0e6d6e6 100644 --- a/docs/doc_gen/rpcs/usage.rst +++ b/docs/doc_gen/rpcs/usage.rst @@ -5,7 +5,7 @@ Usage ***** In order to interact with a Tezos node, you may use RPC calls through the -client using this command ``tezos-admin-client rpc post ``. +client using this command ``tezos-admin-client rpc (get|post) ``. For instance, if you wish to request the current balance of a given block and contract, you can call the associated RPC via the command : diff --git a/docs/introduction/alphanet.rst b/docs/introduction/alphanet.rst index 86c607aa7..ad5fe4cde 100644 --- a/docs/introduction/alphanet.rst +++ b/docs/introduction/alphanet.rst @@ -318,7 +318,7 @@ the appropriate value: $ ./alphanet.sh client list known identities my_identity: tz1iFY8aDskx9QGbgBy68SNAGgkc7AE2iG9H (public key known) (secret key known) - $ ./alphanet.sh client rpc post /blocks/head/proto/helpers/rights/baking/delegate/tz1iFY8aDskx9QGbgBy68SNAGgkc7AE2iG9H with '{}' + $ ./alphanet.sh client rpc post /chains/main/blocks/head/helpers/rights/baking/delegate/tz1iFY8aDskx9QGbgBy68SNAGgkc7AE2iG9H with {} { "ok": [ { "level": 1400.000000, "priority": 2.000000, "timestamp": "2017-05-19T03:21:52Z" }, diff --git a/docs/introduction/howto.rst b/docs/introduction/howto.rst index 1bbae3fa2..1305720a5 100644 --- a/docs/introduction/howto.rst +++ b/docs/introduction/howto.rst @@ -277,7 +277,7 @@ preconfigured for communicating the same-numbered node. For instance: :: - $ tezos-client rpc post blocks/head/hash + $ tezos-client rpc get /chains/main/blocks/head/hash { "hash": "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" } When you bootstrap a new network, the network is initialized with a @@ -288,11 +288,11 @@ activating the whole network. For instance: :: - $ tezos-client rpc post blocks/head/protocol + $ tezos-client rpc get /chains/main/blocks/head/metadata/next_protocol_hash { "protocol": "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" } $ tezos-activate-alpha Injected BMBcK869jaHQDc - $ tezos-client rpc post blocks/head/protocol + $ tezos-client rpc get /chains/main/blocks/head/metadata/next_protocol_hash { "protocol": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK" } Tune protocol alpha parameters diff --git a/scripts/alphanet.sh b/scripts/alphanet.sh index 52483283e..5384cd54f 100755 --- a/scripts/alphanet.sh +++ b/scripts/alphanet.sh @@ -381,8 +381,8 @@ run_shell() { display_head() { assert_node_uptodate - exec_docker tezos-client rpc post /blocks/head with '{}' - exec_docker tezos-client rpc post /blocks/head/proto/context/level with '{}' + exec_docker tezos-client rpc get /chains/main/blocks/head + exec_docker tezos-client rpc post /chains/main/blocks/head/context/level with {} } ## Main #################################################################### diff --git a/scripts/docker/entrypoint.inc.sh b/scripts/docker/entrypoint.inc.sh index 8425ae267..3ffa87895 100644 --- a/scripts/docker/entrypoint.inc.sh +++ b/scripts/docker/entrypoint.inc.sh @@ -19,10 +19,10 @@ configure_client() { wait_for_the_node_to_be_ready() { local count=0 - if "$client" rpc post /blocks/head/hash >/dev/null 2>&1; then return; fi + if "$client" rpc get /chains/main/blocks/head/hash >/dev/null 2>&1; then return; fi printf "Waiting for the node to initialize..." sleep 1 - while ! "$client" rpc post /blocks/head/hash >/dev/null 2>&1 + while ! "$client" rpc get /chains/main/blocks/head/hash >/dev/null 2>&1 do count=$((count+1)) if [ "$count" -ge 30 ]; then diff --git a/src/bin_client/main_client.ml b/src/bin_client/main_client.ml index b4c3a11f3..5f9e2672c 100644 --- a/src/bin_client/main_client.ml +++ b/src/bin_client/main_client.ml @@ -10,7 +10,7 @@ open Client_config let get_commands_for_version ctxt block protocol = - Block_services.protocol ctxt block >>= function + Block_services.Empty.Metadata.next_protocol_hash ctxt ~block () >>= function | Ok version -> begin match protocol with | None -> diff --git a/src/bin_client/test/test_basic.sh b/src/bin_client/test/test_basic.sh index 4bb440c5f..cbee1accf 100755 --- a/src/bin_client/test/test_basic.sh +++ b/src/bin_client/test/test_basic.sh @@ -13,13 +13,13 @@ $client -w none config update sleep 2 #tests for the rpc service raw_context -$client rpc post '/blocks/head/raw_context/version' | assert '{ "content": "616c706861" }' -$client rpc post '/blocks/head/raw_context/non-existent' | assert 'No service found at this URL' -$client rpc post '/blocks/head/raw_context/delegates/?depth=2' | assert '{ "content": - { "ed25519": - { "02": null, "a9": null, "c5": null, "da": null, "e7": null } } }' -$client rpc post '/blocks/head/raw_context/non-existent?depth=-1' | assert 'No service found at this URL' -$client rpc post '/blocks/head/raw_context/non-existent?depth=0' | assert 'No service found at this URL' +$client rpc get '/chains/main/blocks/head/context/raw/version' | assert '"616c706861"' +$client rpc get '/chains/main/blocks/head/context/raw/non-existent' | assert 'No service found at this URL' +$client rpc get '/chains/main/blocks/head/context/raw/delegates/?depth=3' | assert '{ "ed25519": + { "02": { "29": null }, "a9": { "ce": null }, "c5": { "5c": null }, + "da": { "c9": null }, "e7": { "67": null } } }' +$client rpc get '/chains/main/blocks/head/context/raw/non-existent?depth=-1' | assert 'Unexpected server answer' +$client rpc get '/chains/main/blocks/head/context/raw/non-existent?depth=0' | assert 'No service found at this URL' bake diff --git a/src/bin_client/test/test_cors.sh b/src/bin_client/test/test_cors.sh index ffba74916..add9f67b7 100755 --- a/src/bin_client/test/test_cors.sh +++ b/src/bin_client/test/test_cors.sh @@ -22,20 +22,19 @@ run_preflight() { -H "Access-Control-Request-Method: $cors_method" \ -H "Access-Control-Request-Headers: $header" \ -X $method \ - -I -s http://localhost:18731/blocks/head/protocol > CURL.$id 2>&1 + -I -s http://localhost:18731/chains/main/blocks/head/header/shell > CURL.$id 2>&1 } run_request() { local origin="$1" curl -H "Origin: $origin" \ -H "Content-Type: application/json" \ - --data-binary "{}" \ -D CURL.$id \ - -s http://localhost:18731/blocks/head/protocol 2>&1 > /dev/null + -s http://localhost:18731/chains/main/blocks/head/header/shell 2>&1 > /dev/null } # Preflight -run_preflight "localhost" "OPTIONS" "POST" "Content-Type" +run_preflight "localhost" "OPTIONS" "GET" "Content-Type" cat CURL.$id grep -q "access-control-allow-origin" CURL.$id grep -q "access-control-allow-methods" CURL.$id diff --git a/src/bin_client/test/test_fork.sh b/src/bin_client/test/test_fork.sh index 7c83c80d9..547686ba2 100755 --- a/src/bin_client/test/test_fork.sh +++ b/src/bin_client/test/test_fork.sh @@ -37,7 +37,7 @@ $admin_client list protocols #these commands cannot be used in this case because the client does not #know about the new protocol #$client --protocol $protocol_short bake for bootstrap1 -max-priority 512 -#$client --protocol $protocol_version rpc post /blocks/head with {} +#$client --protocol $protocol_version rpc get /chains/main/blocks/head echo echo End of test diff --git a/src/bin_client/test/test_injection.sh b/src/bin_client/test/test_injection.sh index 38f00315f..15733e3a3 100755 --- a/src/bin_client/test/test_injection.sh +++ b/src/bin_client/test/test_injection.sh @@ -19,10 +19,10 @@ protocol_version="PtamL2BUfeNFM2A8Thq2Wde8vNaVD9DhoARDVB41QsHFj89kQpT" $admin_client inject protocol "$test_dir/demo" $admin_client list protocols $client activate protocol $protocol_version with fitness 1 and key dictator and parameters $parameters_file -answ=$($client -p ProtoALphaALph rpc post /blocks/head/protocol with {} 2>/dev/null) +answ=$($client -p ProtoALphaALph rpc get /chains/main/blocks/head/metadata/next_protocol_hash 2>/dev/null) if ! grep "$protocol_version" <<< $answ ; then - exit 1 + exit 1 fi echo diff --git a/src/bin_client/test/test_injection_alpha.sh b/src/bin_client/test/test_injection_alpha.sh index 1ba7f49bd..6c5dbc334 100755 --- a/src/bin_client/test/test_injection_alpha.sh +++ b/src/bin_client/test/test_injection_alpha.sh @@ -37,7 +37,7 @@ $admin_client list protocols #these commands cannot be used in this case because the client does not #know about the new protocol #$client --protocol $protocol_short bake for bootstrap1 -max-priority 512 -#$client --protocol $protocol_version rpc post /blocks/head with {} +#$client --protocol $protocol_version rpc get /chains/main/blocks/head echo echo End of test diff --git a/src/bin_client/test/test_multinode.sh b/src/bin_client/test/test_multinode.sh index 18ad45481..ee26426d9 100755 --- a/src/bin_client/test/test_multinode.sh +++ b/src/bin_client/test/test_multinode.sh @@ -40,7 +40,7 @@ assert_propagation_level() { level=$1 printf "\n\nAsserting all nodes have reached level %s\n" "$level" for client in "${client_instances[@]}"; do - ( $client rpc post /blocks/head/proto/context/level \ + ( $client rpc post /chains/main/blocks/head/context/level with {} \ | assert_in_output "\"level\": $level" ) \ || exit 2 done @@ -51,7 +51,7 @@ assert_protocol() { proto=$1 printf "\n\nAsserting protocol propagation\n" for client in "${client_instances[@]}"; do - ( $client rpc post /blocks/head/protocol | assert_in_output "$proto" ) \ + ( $client rpc get /chains/main/blocks/head/metadata/next_protocol_hash | assert_in_output "$proto" ) \ || exit 2 done } @@ -102,7 +102,7 @@ assert_contains_operation() { hash="$1" printf "Asserting operations list contains '$hash'\n" for client in "${client_instances[@]}"; do - ( $client rpc post /blocks/head/operations with {} \ + ( $client rpc get /chains/main/blocks/head/operation_hashes \ | assert_in_output $hash ) \ || exit 2 done diff --git a/src/bin_client/tezos-init-sandboxed-client.sh b/src/bin_client/tezos-init-sandboxed-client.sh index 599eead4d..c1dae2942 100755 --- a/src/bin_client/tezos-init-sandboxed-client.sh +++ b/src/bin_client/tezos-init-sandboxed-client.sh @@ -57,10 +57,10 @@ cleanup_clients() { wait_for_the_node_to_be_ready() { local count=0 - if $client rpc post blocks/head/hash >/dev/null 2>&1; then return; fi + if $client rpc get /chains/main/blocks/head/hash >/dev/null 2>&1; then return; fi printf "Waiting for the node to initialize..." sleep 1 - while ! $client rpc post blocks/head/hash >/dev/null 2>&1 + while ! $client rpc get /chains/main/blocks/head/hash >/dev/null 2>&1 do count=$((count+1)) if [ "$count" -ge 30 ]; then @@ -301,7 +301,7 @@ The client is now properly initialized. In the rest of this shell session, you might now run \`tezos-client\` to communicate with a tezos node launched with \`launch-sandboxed-node $1\`. For instance: - tezos-client rpc post blocks/head/protocol + tezos-client rpc get /chains/main/blocks/head/metadata/protocol_hash Note: if the current protocol version, as reported by the previous command, is "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im", you diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 349555804..20afa0723 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -207,7 +207,7 @@ let init_rpc (rpc_config: Node_config_file.rpc) node = failwith "Cannot resolve listening address: %S" addr | (addr, port) :: _ -> let host = Ipaddr.V6.to_string addr in - let dir = Node_rpc.build_rpc_directory node in + let dir = Node.build_rpc_directory node in let mode = match rpc_config.tls with | None -> `TCP (`Port port) diff --git a/src/lib_client_base/client_confirmations.ml b/src/lib_client_base/client_confirmations.ml index a3b5d8032..2042f1729 100644 --- a/src/lib_client_base/client_confirmations.ml +++ b/src/lib_client_base/client_confirmations.ml @@ -9,59 +9,108 @@ let wait_for_operation_inclusion (ctxt : #Client_context.full) + ~chain ?(predecessors = 10) ?(confirmations = 1) operation_hash = - let confirmed_blocks = Hashtbl.create confirmations in + + (* Table of known blocks: + - None: if neither the block or its predecessors contains the operation + - (Some n): if the `n-th` predecessors of the block contains the operation *) + + let blocks : int option Block_hash.Table.t = + Block_hash.Table.create confirmations in + + (* Fetch _all_ the 'unknown' predecessors af a block. *) + + let fetch_predecessors block = + let rec loop acc block = + Block_services.Empty.Header.Shell.predecessor + ctxt ~chain ~block:(`Hash (block, 0)) () >>=? fun predecessor -> + if Block_hash.Table.mem blocks predecessor then + return acc + else + loop (predecessor :: acc) predecessor + in + loop [block] block >>= function + | Ok blocks -> Lwt.return blocks + | Error err -> + ctxt#warning + "Error while fetching block (ignored): %a" + pp_print_error err >>= fun () -> + (* Will be retried when a new head arrives *) + Lwt.return [] in + + (* Check whether a block as enough confirmations. This function + assumes that the block predecessor has been processed already. *) + let process block = - Block_services.hash ctxt block >>=? fun hash -> - Block_services.predecessor ctxt block >>=? fun predecessor -> - match Hashtbl.find_opt confirmed_blocks predecessor with + Block_services.Empty.hash ctxt ~chain ~block () >>=? fun hash -> + Block_services.Empty.Header.Shell.predecessor + ctxt ~chain ~block () >>=? fun predecessor -> + match Block_hash.Table.find blocks predecessor with | Some n -> ctxt#answer "Operation received %d confirmations as of block: %a" (n+1) Block_hash.pp hash >>= fun () -> if n+1 < confirmations then begin - Hashtbl.add confirmed_blocks hash (n+1) ; + Block_hash.Table.add blocks hash (Some (n+1)) ; return false end else return true | None -> - Block_services.operations - ctxt ~contents:false block >>=? fun operations -> + Block_services.Empty.Operation_hash.operation_hashes + ctxt ~chain ~block () >>=? fun operations -> let in_block = List.exists (List.exists - (fun (oph, _) -> Operation_hash.equal operation_hash oph)) + (Operation_hash.equal operation_hash)) operations in - if not in_block then + if not in_block then begin + Block_hash.Table.add blocks hash None ; return false - else begin + end else begin ctxt#answer "Operation found in block: %a" Block_hash.pp hash >>= fun () -> if confirmations <= 0 then return true else begin - Hashtbl.add confirmed_blocks hash 0 ; + Block_hash.Table.add blocks hash (Some 0) ; return false end end in - Block_services.monitor - ~include_ops:false - ~length:predecessors ctxt >>=? fun (stream, stop) -> - let exception WrapError of error list in - let stream = Lwt_stream.map_list List.concat stream in - Lwt.catch - (fun () -> - Lwt_stream.find_s - (fun bi -> - process (`Hash (bi.Block_services.hash, 0)) >>= function - | Ok b -> Lwt.return b - | Error err -> - Lwt.fail (WrapError err)) stream >>= return) - (function - | WrapError e -> Lwt.return (Error e) - | exn -> Lwt.fail exn) >>=? fun _ -> - stop () ; - return () + + Shell_services.Monitor.heads ctxt chain >>=? fun (stream, stop) -> + Lwt_stream.get stream >>= function + | None -> assert false + | Some head -> + let rec loop n = + if n >= 0 then + process (`Hash (head, n)) >>=? function + | true -> + stop () ; + return () + | false -> + loop (n-1) + else + let exception WrapError of error list in + Lwt.catch + (fun () -> + let stream = Lwt_stream.map_list_s fetch_predecessors stream in + Lwt_stream.find_s + (fun block -> + process (`Hash (block, 0)) >>= function + | Ok b -> Lwt.return b + | Error err -> + Lwt.fail (WrapError err)) stream >>= return) + (function + | WrapError e -> Lwt.return (Error e) + | exn -> Lwt.fail exn) >>=? fun _ -> + stop () ; + return () in + Block_services.Empty.hash + ctxt ~block:(`Hash (head, predecessors+1)) () >>=? fun oldest -> + Block_hash.Table.add blocks oldest None ; + loop predecessors + diff --git a/src/lib_client_base/client_confirmations.mli b/src/lib_client_base/client_confirmations.mli index 2def1cc79..bc5d1580b 100644 --- a/src/lib_client_base/client_confirmations.mli +++ b/src/lib_client_base/client_confirmations.mli @@ -9,6 +9,7 @@ val wait_for_operation_inclusion: #Client_context.full -> + chain:Chain_services.chain -> ?predecessors:int -> ?confirmations:int -> Operation_hash.t -> diff --git a/src/lib_client_commands/client_admin_commands.ml b/src/lib_client_commands/client_admin_commands.ml index c0b662bf9..fdae952b2 100644 --- a/src/lib_client_commands/client_admin_commands.ml +++ b/src/lib_client_commands/client_admin_commands.ml @@ -20,7 +20,7 @@ let commands () = (fun () blocks (cctxt : #Client_context.full) -> iter_s (fun block -> - Block_services.unmark_invalid cctxt block >>=? fun () -> + Chain_services.Invalid_blocks.delete cctxt block >>=? fun () -> cctxt#message "Block %a no longer marked invalid." Block_hash.pp block >>= fun () -> diff --git a/src/lib_client_commands/client_helpers_commands.ml b/src/lib_client_commands/client_helpers_commands.ml index 3ea9a349d..46f9b8c47 100644 --- a/src/lib_client_commands/client_helpers_commands.ml +++ b/src/lib_client_commands/client_helpers_commands.ml @@ -26,7 +26,7 @@ let commands () = Clic.[ ~desc: "the prefix of the hash to complete" @@ stop) (fun unique prefix (cctxt : #Client_context.full) -> - Shell_services.complete + Block_services.Empty.Helpers.complete cctxt ~block:cctxt#block prefix >>=? fun completions -> match completions with | [] -> Pervasives.exit 3 diff --git a/src/lib_client_commands/client_report_commands.ml b/src/lib_client_commands/client_report_commands.ml index b4db8a5dc..6fd313e93 100644 --- a/src/lib_client_commands/client_report_commands.ml +++ b/src/lib_client_commands/client_report_commands.ml @@ -13,32 +13,14 @@ let skip_line ppf = Format.pp_print_newline ppf (); return @@ Format.pp_print_newline ppf () -let print_heads ppf heads = - Format.pp_print_list ~pp_sep:Format.pp_print_newline - (fun ppf blocks -> - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - Block_services.pp_block_info - ppf - blocks) - ppf heads - -let print_rejected ppf = function - | [] -> Format.fprintf ppf "No invalid blocks." - | invalid -> - Format.pp_print_list - (fun ppf (hash, level, errors) -> - Format.fprintf ppf - "@[Hash: %a\ - @ Level: %ld\ - @ Errors: @[%a@]@]" - Block_hash.pp hash - level - (Format.pp_print_list ~pp_sep:Format.pp_print_newline - Error_monad.pp) - errors) - ppf - invalid +let print_invalid_blocks ppf (b: Chain_services.invalid_block) = + Format.fprintf ppf + "@[Hash: %a\ + @ Level: %ld\ + @ %a@]" + Block_hash.pp b.hash + b.level + pp_print_error b.errors let commands () = let open Clic in @@ -63,28 +45,22 @@ let commands () = (args1 output_arg) (fixed [ "list" ; "heads" ]) (fun ppf cctxt -> - Block_services.list ~include_ops:true ~length:1 cctxt >>=? fun heads -> - Format.fprintf ppf "%a@." print_heads heads ; + Chain_services.Blocks.list cctxt () >>=? fun heads -> + Format.fprintf ppf "@[%a@]@." + (Format.pp_print_list Block_hash.pp) + (List.concat heads) ; return ()) ; command ~group ~desc: "The blocks that have been marked invalid by the node." (args1 output_arg) (fixed [ "list" ; "rejected" ; "blocks" ]) (fun ppf cctxt -> - Block_services.list_invalid cctxt >>=? fun invalid -> - Format.fprintf ppf "%a@." print_rejected invalid ; - return ()) ; - command ~group ~desc: "A full report of the node's state." - (args1 output_arg) - (fixed [ "full" ; "report" ]) - (fun ppf cctxt -> - Block_services.list ~include_ops:true ~length:1 cctxt >>=? fun heads -> - Block_services.list_invalid cctxt >>=? fun invalid -> - Format.fprintf ppf - "@[@{Date@} %a@,\ - @[<v 2>@{<title>Heads@}@,%a@]@,\ - @[<v 2>@{<title>Rejected blocks@}@,%a@]@]" - Time.pp_hum (Time.now ()) - print_heads heads - print_rejected invalid ; - return ()) ; + Chain_services.Invalid_blocks.list cctxt () >>=? function + | [] -> + Format.fprintf ppf "No invalid blocks." ; + return () + | _ :: _ as invalid -> + Format.fprintf ppf "@[<v>%a@]@." + (Format.pp_print_list print_invalid_blocks) + invalid ; + return ()) ; ] diff --git a/src/lib_protocol_environment/sigs/v1/updater.mli b/src/lib_protocol_environment/sigs/v1/updater.mli index 25e00aec0..df4f21f91 100644 --- a/src/lib_protocol_environment/sigs/v1/updater.mli +++ b/src/lib_protocol_environment/sigs/v1/updater.mli @@ -50,9 +50,7 @@ type quota = { type rpc_context = { block_hash: Block_hash.t ; - block_header: Block_header.t ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.t list list Lwt.t ; + block_header: Block_header.shell_header ; context: Context.t ; } diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 9c5b1625d..0839e4747 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -47,9 +47,7 @@ module Make (Context : CONTEXT) = struct type rpc_context = { block_hash: Block_hash.t ; - block_header: Block_header.t ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.t list list Lwt.t ; + block_header: Block_header.shell_header ; context: Context.t ; } @@ -171,9 +169,9 @@ module Make (Context : CONTEXT) = struct and type operation = P.operation and type validation_state = P.validation_state - class ['block] proto_rpc_context : - Tezos_rpc.RPC_context.t -> (unit, unit * 'block) RPC_path.t -> - ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : + Tezos_rpc.RPC_context.t -> (unit, (unit * 'chain) * 'block) RPC_path.t -> + [('chain * 'block)] RPC_context.simple class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> RPC_context.t RPC_directory.t -> @@ -589,9 +587,7 @@ module Make (Context : CONTEXT) = struct type nonrec rpc_context = rpc_context = { block_hash: Block_hash.t ; - block_header: Block_header.t ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.t list list Lwt.t ; + block_header: Block_header.shell_header ; context: Context.t ; } @@ -663,47 +659,47 @@ module Make (Context : CONTEXT) = struct let init c bh = init c bh >|= wrap_error end - class ['block] proto_rpc_context + class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) - (prefix : (unit, unit * 'block) RPC_path.t) = + (prefix : (unit, (unit * 'chain) * 'block) RPC_path.t) = object method call_proto_service0 : 'm 'q 'i 'o. ([< RPC_service.meth ] as 'm, RPC_context.t, RPC_context.t, 'q, 'i, 'o) RPC_service.t -> - 'block -> 'q -> 'i -> 'o tzresult Lwt.t - = fun s block q i -> + ('chain * 'block) -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s (chain, block) q i -> let s = RPC_service.subst0 s in let s = RPC_service.prefix prefix s in - t#call_service s ((), block) q i + t#call_service s (((), chain), block) q i method call_proto_service1 : 'm 'a 'q 'i 'o. ([< RPC_service.meth ] as 'm, RPC_context.t, RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t - = fun s block a1 q i -> + ('chain * 'block) -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s (chain, block) a1 q i -> let s = RPC_service.subst1 s in let s = RPC_service.prefix prefix s in - t#call_service s (((), block), a1) q i + t#call_service s ((((), chain), block), a1) q i method call_proto_service2 : 'm 'a 'b 'q 'i 'o. ([< RPC_service.meth ] as 'm, RPC_context.t, (RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'block -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t - = fun s block a1 a2 q i -> + ('chain * 'block) -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s (chain, block) a1 a2 q i -> let s = RPC_service.subst2 s in let s = RPC_service.prefix prefix s in - t#call_service s ((((), block), a1), a2) q i + t#call_service s (((((), chain), block), a1), a2) q i method call_proto_service3 : 'm 'a 'b 'c 'q 'i 'o. ([< RPC_service.meth ] as 'm, RPC_context.t, ((RPC_context.t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> - 'block -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t - = fun s block a1 a2 a3 q i -> + ('chain * 'block) -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s (chain, block) a1 a2 a3 q i -> let s = RPC_service.subst3 s in let s = RPC_service.prefix prefix s in - t#call_service s (((((), block), a1), a2), a3) q i + t#call_service s ((((((), chain), block), a1), a2), a3) q i end class ['block] proto_rpc_context_of_directory conv dir : ['block] RPC_context.simple = diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index 5f58646eb..af09e5dba 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -40,9 +40,7 @@ module Make (Context : CONTEXT) : sig type rpc_context = { block_hash: Block_hash.t ; - block_header: Block_header.t ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.t list list Lwt.t ; + block_header: Block_header.shell_header ; context: Context.t ; } @@ -164,9 +162,9 @@ module Make (Context : CONTEXT) : sig and type operation = P.operation and type validation_state = P.validation_state - class ['block] proto_rpc_context : - Tezos_rpc.RPC_context.t -> (unit, unit * 'block) RPC_path.t -> - ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : + Tezos_rpc.RPC_context.t -> (unit, (unit * 'chain) * 'block) RPC_path.t -> + [('chain * 'block)] RPC_context.simple class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> RPC_context.t RPC_directory.t -> diff --git a/src/lib_protocol_updater/jbuild b/src/lib_protocol_updater/jbuild index 79b020c6c..ae299564f 100644 --- a/src/lib_protocol_updater/jbuild +++ b/src/lib_protocol_updater/jbuild @@ -6,6 +6,7 @@ (libraries (tezos-base tezos-stdlib-unix tezos-micheline + tezos-shell-services tezos-protocol-environment-shell tezos-protocol-compiler.registerer tezos-protocol-compiler.native @@ -16,6 +17,7 @@ -open Tezos_base__TzPervasives -open Tezos_stdlib_unix -open Tezos_micheline + -open Tezos_shell_services -open Tezos_storage)))) (alias diff --git a/src/lib_protocol_updater/registered_protocol.ml b/src/lib_protocol_updater/registered_protocol.ml index d4a3f7767..5abb6d0c5 100644 --- a/src/lib_protocol_updater/registered_protocol.ml +++ b/src/lib_protocol_updater/registered_protocol.ml @@ -8,8 +8,13 @@ (**************************************************************************) module type T = sig - val hash: Protocol_hash.t - include Tezos_protocol_environment_shell.PROTOCOL + module P : sig + val hash: Protocol_hash.t + include Tezos_protocol_environment_shell.PROTOCOL + end + include (module type of (struct include P end)) + module Block_services : + (module type of (struct include Block_services.Make(P)(P) end)) val complete_b58prefix : Context.t -> string -> string list Lwt.t end @@ -22,9 +27,13 @@ let build_v1 hash = end in let module Env = Tezos_protocol_environment_shell.MakeV1(Name)() in (module struct - let hash = hash - module P = F(Env) - include Env.Lift(P) + module Raw = F(Env) + module P = struct + let hash = hash + include Env.Lift(Raw) + end + include P + module Block_services = Block_services.Make(P)(P) let complete_b58prefix = Env.Context.complete end : T) @@ -68,8 +77,12 @@ module Register VersionTable.add versions hash (module struct - let hash = hash - include Env.Lift(Proto) + module P = struct + let hash = hash + include Env.Lift(Proto) + end + include P + module Block_services = Block_services.Make(P)(P) let complete_b58prefix = Env.Context.complete end : T) diff --git a/src/lib_protocol_updater/registered_protocol.mli b/src/lib_protocol_updater/registered_protocol.mli index 82f51984f..1905765fe 100644 --- a/src/lib_protocol_updater/registered_protocol.mli +++ b/src/lib_protocol_updater/registered_protocol.mli @@ -8,8 +8,13 @@ (**************************************************************************) module type T = sig - val hash: Protocol_hash.t - include Tezos_protocol_environment_shell.PROTOCOL + module P : sig + val hash: Protocol_hash.t + include Tezos_protocol_environment_shell.PROTOCOL + end + include (module type of (struct include P end)) + module Block_services : + (module type of (struct include Block_services.Make(P)(P) end)) val complete_b58prefix : Context.t -> string -> string list Lwt.t end diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml new file mode 100644 index 000000000..087a65141 --- /dev/null +++ b/src/lib_shell/block_directory.ml @@ -0,0 +1,340 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let rec read_partial_context context path depth = + (* non tail-recursive *) + if depth = 0 then + Lwt.return Block_services.Cut + else + (* try to read as file *) + Context.get context path >>= function + | Some v -> + Lwt.return (Block_services.Key v) + | None -> + (* try to read as directory *) + Context.fold context path ~init:[] ~f: begin fun k acc -> + match k with + | `Key k | `Dir k -> + read_partial_context context k (depth-1) >>= fun v -> + let k = List.nth k ((List.length k)-1) in + Lwt.return ((k,v)::acc) + end >>= fun l -> + Lwt.return (Block_services.Dir (List.rev l)) + +let rpc_directory + (module Proto : Block_services.PROTO) + (module Next_proto : Registered_protocol.T) = + + let dir : State.Block.t RPC_directory.t ref = + ref RPC_directory.empty in + + let register0 s f = + dir := + RPC_directory.register !dir (RPC_service.subst0 s) + (fun block p q -> f block p q) in + let register1 s f = + dir := + RPC_directory.register !dir (RPC_service.subst1 s) + (fun (block, a) p q -> f block a p q) in + let register2 s f = + dir := + RPC_directory.register !dir (RPC_service.subst2 s) + (fun ((block, a), b) p q -> f block a b p q) in + + let module Block_services = Block_services.Make(Proto)(Next_proto) in + let module S = Block_services.S in + + register0 S.hash begin fun block () () -> + return (State.Block.hash block) + end ; + + (* block header *) + + register0 S.Header.header begin fun block () () -> + let chain_id = State.Block.chain_id block in + let hash = State.Block.hash block in + let header = State.Block.header block in + let protocol_data = + Data_encoding.Binary.of_bytes_exn + Proto.block_header_data_encoding + header.protocol_data in + return { Block_services.hash ; chain_id ; + shell = header.shell ; protocol_data } + end ; + register0 S.Header.shell_header begin fun block () () -> + return (State.Block.header block).shell + end ; + register0 S.Header.Shell.level begin fun block () () -> + return (State.Block.header block).shell.level + end ; + register0 S.Header.Shell.protocol_level begin fun block () () -> + return (State.Block.header block).shell.proto_level + end ; + register0 S.Header.Shell.predecessor begin fun block () () -> + return (State.Block.header block).shell.predecessor + end ; + register0 S.Header.Shell.timestamp begin fun block () () -> + return (State.Block.header block).shell.timestamp + end ; + register0 S.Header.Shell.validation_passes begin fun block () () -> + return (State.Block.header block).shell.validation_passes + end ; + register0 S.Header.Shell.operations_hash begin fun block () () -> + return (State.Block.header block).shell.operations_hash + end ; + register0 S.Header.Shell.fitness begin fun block () () -> + return (State.Block.header block).shell.fitness + end ; + register0 S.Header.Shell.context_hash begin fun block () () -> + return (State.Block.header block).shell.context + end ; + register0 S.Header.protocol_data begin fun block () () -> + let header = State.Block.header block in + return + (Data_encoding.Binary.of_bytes_exn + Proto.block_header_data_encoding + header.protocol_data) + end ; + + (* block metadata *) + + let metadata block = + let protocol_data = + Data_encoding.Binary.of_bytes_exn + Proto.block_header_metadata_encoding + (State.Block.metadata block) in + State.Block.test_chain block >>= fun test_chain_status -> + return { + Block_services.protocol_data ; + test_chain_status ; + max_operations_ttl = State.Block.max_operations_ttl block ; + max_operation_data_length = State.Block.max_operation_data_length block ; + max_block_header_length = Next_proto.max_block_length ; + operation_list_quota = + List.map + (fun { Tezos_protocol_environment_shell.max_size; max_op } -> + { Tezos_shell_services.Block_services.max_size ; max_op } ) + Next_proto.validation_passes ; + } in + + register0 S.Metadata.metadata begin fun block () () -> + metadata block + end ; + register0 S.Metadata.protocol_data begin fun block () () -> + return + (Data_encoding.Binary.of_bytes_exn + Proto.block_header_metadata_encoding + (State.Block.metadata block)) + end ; + register0 S.Metadata.protocol_hash begin fun _block () () -> + return Proto.hash + end ; + register0 S.Metadata.next_protocol_hash begin fun _block () () -> + return Next_proto.hash + end ; + register0 S.Metadata.test_chain_status begin fun block () () -> + State.Block.test_chain block >>= return + end ; + register0 S.Metadata.max_operations_ttl begin fun block () () -> + return (State.Block.max_operations_ttl block) + end ; + register0 S.Metadata.max_operation_data_length begin fun block () () -> + return (State.Block.max_operation_data_length block) + end ; + register0 S.Metadata.max_block_header_length begin fun _block () () -> + return (Next_proto.max_block_length) ; + end ; + register0 S.Metadata.operation_list_quota begin fun _block () () -> + return + (List.map + (fun { Tezos_protocol_environment_shell.max_size; max_op } -> + { Tezos_shell_services.Block_services.max_size ; max_op } ) + Next_proto.validation_passes) + end ; + + (* operations *) + + let convert chain_id (op : Operation.t) metadata = + let protocol_data = + Data_encoding.Binary.of_bytes_exn + Proto.operation_data_encoding + op.proto in + let metadata = + Data_encoding.Binary.of_bytes_exn + Proto.operation_metadata_encoding + metadata in + { Block_services.chain_id ; + hash = Operation.hash op ; + shell = op.shell ; + protocol_data ; + metadata ; + } in + + let operations block = + State.Block.all_operations block >>= fun ops -> + State.Block.all_operations_metadata block >>= fun metadata -> + let chain_id = State.Block.chain_id block in + return (List.map2 (List.map2 (convert chain_id)) ops metadata) in + + register0 S.Operation.operations begin fun block () () -> + operations block + end ; + + register1 S.Operation.operations_in_pass begin fun block i () () -> + State.Block.operations block i >>= fun (ops, _path) -> + State.Block.operations_metadata block i >>= fun metadata -> + let chain_id = State.Block.chain_id block in + return (List.map2 (convert chain_id) ops metadata) + end ; + + register2 S.Operation.operation begin fun block i j () () -> + State.Block.operations block i >>= fun (ops, _path) -> + State.Block.operations_metadata block i >>= fun metadata -> + let chain_id = State.Block.chain_id block in + return (convert chain_id (List.nth ops j) (List.nth metadata j)) + end ; + + (* operation_hashes *) + + register0 S.Operation_hash.operation_hashes begin fun block () () -> + State.Block.all_operation_hashes block >>= return + end ; + + register1 S.Operation_hash.operation_hashes_in_pass begin fun block i () () -> + State.Block.operation_hashes block i >>= fun (ops, _) -> + return ops + end ; + + register2 S.Operation_hash.operation_hash begin fun block i j () () -> + State.Block.operation_hashes block i >>= fun (ops, _) -> + return (List.nth ops j) + end ; + + (* context *) + + register1 S.Context.Raw.read begin fun block path q () -> + let depth = Option.unopt ~default:max_int q#depth in + fail_unless (depth >= 0) + (Tezos_shell_services.Block_services.Invalid_depth_arg (path, depth)) >>=? fun () -> + State.Block.context block >>= fun context -> + Context.mem context path >>= fun mem -> + Context.dir_mem context path >>= fun dir_mem -> + if not (mem || dir_mem) then + Lwt.fail Not_found + else + read_partial_context context path depth >>= fun dir -> + return dir + end ; + + (* info *) + + register0 S.info begin fun block () () -> + let chain_id = State.Block.chain_id block in + let hash = State.Block.hash block in + let header = State.Block.header block in + let shell = header.shell in + let protocol_data = + Data_encoding.Binary.of_bytes_exn + Proto.block_header_data_encoding + header.protocol_data in + metadata block >>=? fun metadata -> + operations block >>=? fun operations -> + return { Block_services.hash ; chain_id ; + header = { shell ; protocol_data } ; + metadata ; operations } + end ; + + (* helpers *) + + register0 S.Helpers.preapply begin fun block q p -> + let protocol_data = + Data_encoding.Binary.to_bytes_exn + Next_proto.block_header_data_encoding + p.protocol_data in + let operations = + List.map + (List.map + (fun (op : Next_proto.operation) -> + let proto = + Data_encoding.Binary.to_bytes_exn + Next_proto.operation_data_encoding + op.protocol_data in + { Operation.shell = op.shell ; proto })) + p.operations in + Prevalidation.preapply + ~predecessor:block + ~timestamp:p.timestamp + ~protocol_data + ~sort_operations:q#sort_operations + operations + end ; + + register1 S.Helpers.complete begin fun block prefix () () -> + State.Block.context block >>= fun ctxt -> + Base58.complete prefix >>= fun l1 -> + Next_proto.complete_b58prefix ctxt prefix >>= fun l2 -> + return (l1 @ l2) + end ; + + (* merge protocol rpcs... *) + + RPC_directory.merge + !dir + (RPC_directory.map + (fun block -> + State.Block.context block >>= fun context -> + Lwt.return Tezos_protocol_environment_shell.{ + block_hash = State.Block.hash block ; + block_header = State.Block.shell_header block ; + context }) + Next_proto.rpc_services) + +let get_protocol hash = + match Registered_protocol.get hash with + | None -> raise Not_found + | Some protocol -> protocol + +let get_directory block = + State.Block.get_rpc_directory block >>= function + | Some dir -> Lwt.return dir + | None -> + State.Block.protocol_hash block >>= fun next_protocol_hash -> + let next_protocol = get_protocol next_protocol_hash in + State.Block.predecessor block >>= function + | None -> + Lwt.return (rpc_directory + (module Block_services.Fake_protocol) + next_protocol) + | Some pred -> + State.Block.protocol_hash pred >>= fun protocol_hash -> + let (module Proto) = get_protocol protocol_hash in + State.Block.get_rpc_directory block >>= function + | Some dir -> Lwt.return dir + | None -> + let dir = rpc_directory (module Proto) next_protocol in + State.Block.set_rpc_directory block dir >>= fun () -> + Lwt.return dir + +let get_block chain_state = function + | `Genesis -> + Chain.genesis chain_state + | `Head n -> + Chain.head chain_state >>= fun head -> + if n = 0 then + Lwt.return head + else + State.Block.read_exn chain_state ~pred:n (State.Block.hash head) + | `Hash (hash, n) -> + State.Block.read_exn chain_state ~pred:n hash + +let build_rpc_directory chain_state block = + get_block chain_state block >>= fun block -> + get_directory block >>= fun dir -> + Lwt.return (RPC_directory.map (fun _ -> block) dir) + diff --git a/src/lib_shell/block_directory.mli b/src/lib_shell/block_directory.mli new file mode 100644 index 000000000..be6624928 --- /dev/null +++ b/src/lib_shell/block_directory.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val get_block: State.Chain.t -> Block_services.block -> State.Block.t Lwt.t + +val build_rpc_directory: + State.Chain.t -> + Block_services.block -> + 'a RPC_directory.t Lwt.t diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml new file mode 100644 index 000000000..4930ecc62 --- /dev/null +++ b/src/lib_shell/chain_directory.ml @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Chain_services + +let get_chain_id state = function + | `Main -> Lwt.return (State.Chain.main state) + | `Test -> begin + State.Chain.get_exn state (State.Chain.main state) >>= fun main_chain -> + State.Chain.test main_chain >>= function + | None -> Lwt.fail Not_found + | Some chain_id -> Lwt.return chain_id + end + | `Hash chain_id -> + Lwt.return chain_id + +let get_chain state chain = + get_chain_id state chain >>= fun chain_id -> + State.Chain.get_exn state chain_id + +let predecessors ignored length head = + let rec loop acc length block = + if length <= 0 then + Lwt.return (List.rev acc) + else + State.Block.predecessor block >>= function + | None -> + Lwt.return (List.rev acc) + | Some pred -> + if Block_hash.Set.mem (State.Block.hash block) ignored then + Lwt.return (List.rev acc) + else + loop (State.Block.hash pred :: acc) (length-1) pred + in + loop [State.Block.hash head] (length-1) head + +let list_blocks chain_state ?(length = 1) ?min_date heads = + begin + match heads with + | [] -> + Chain.known_heads chain_state >>= fun heads -> + let heads = + match min_date with + | None -> heads + | Some min_date -> + List.fold_left + (fun acc block -> + let timestamp = State.Block.timestamp block in + if Time.(min_date <= timestamp) then block :: acc + else acc) + [] heads in + let sorted_heads = + List.sort + (fun b1 b2 -> + let f1 = State.Block.fitness b1 in + let f2 = State.Block.fitness b2 in + ~- (Fitness.compare f1 f2)) + heads in + Lwt.return (List.map (fun b -> Some b) sorted_heads) + | _ :: _ as heads -> + Lwt_list.map_p (State.Block.read_opt chain_state) heads + end >>= fun requested_heads -> + Lwt_list.fold_left_s + (fun (ignored, acc) head -> + match head with + | None -> Lwt.return (ignored, []) + | Some block -> + predecessors ignored length block >>= fun predecessors -> + let ignored = + List.fold_right Block_hash.Set.add predecessors ignored in + Lwt.return (ignored, predecessors :: acc)) + (Block_hash.Set.empty, []) + requested_heads >>= fun (_, blocks) -> + return (List.rev blocks) + +let rpc_directory = + + let dir : State.Chain.t Lwt.t RPC_directory.t ref = + ref RPC_directory.empty in + + let register0 s f = + dir := + RPC_directory.register !dir (RPC_service.subst0 s) + (fun chain p q -> chain >>= fun chain -> f chain p q) in + let register1 s f = + dir := + RPC_directory.register !dir (RPC_service.subst1 s) + (fun (chain, a) p q -> chain >>= fun chain -> f chain a p q) in + + let register_dynamic_directory2 ?descr s f = + dir := + RPC_directory.register_dynamic_directory + !dir ?descr (RPC_path.subst1 s) + (fun (chain, a) -> chain >>= fun chain -> f chain a) in + + register0 S.chain_id begin fun chain () () -> + return (State.Chain.id chain) + end ; + + (* blocks *) + + register0 S.Blocks.list begin fun chain q () -> + list_blocks chain ?length:q#length ?min_date:q#min_date q#heads + end ; + + register_dynamic_directory2 + Block_services.path + Block_directory.build_rpc_directory ; + + (* invalid_blocks *) + + register0 S.Invalid_blocks.list begin fun chain () () -> + let convert (hash, level, errors) = { hash ; level ; errors } in + State.Block.list_invalid chain >>= fun blocks -> + return (List.map convert blocks) + end ; + + register1 S.Invalid_blocks.get begin fun chain hash () () -> + State.Block.read_invalid chain hash >>= function + | None -> Lwt.fail Not_found + | Some { level ; errors } -> return { hash ; level ; errors } + end ; + + register1 S.Invalid_blocks.delete begin fun chain hash () () -> + State.Block.unmark_invalid chain hash + end ; + + !dir + +let build_rpc_directory state validator = + + let dir = ref rpc_directory in + + (* Mempool *) + + let register0 s f = + dir := + RPC_directory.register !dir (RPC_service.subst0 s) + (fun chain p q -> chain >>= fun chain -> f chain p q) in + + register0 S.Mempool.pending_operations begin fun chain () () -> + Validator.get_exn validator (State.Chain.id chain) >>= fun chain_validator -> + let pv_opt = Chain_validator.prevalidator chain_validator in + match pv_opt with + | Some pv -> + return (Prevalidator.operations pv) + | None -> + return (Preapply_result.empty, Operation_hash.Map.empty) + end ; + + RPC_directory.prefix Chain_services.path @@ + RPC_directory.map (fun ((), chain) -> get_chain state chain) !dir + diff --git a/src/lib_shell_services/mempool_services.mli b/src/lib_shell/chain_directory.mli similarity index 67% rename from src/lib_shell_services/mempool_services.mli rename to src/lib_shell/chain_directory.mli index 72b07bc7f..7baee7024 100644 --- a/src/lib_shell_services/mempool_services.mli +++ b/src/lib_shell/chain_directory.mli @@ -7,16 +7,9 @@ (* *) (**************************************************************************) +val get_chain_id: State.t -> Chain_services.chain -> Chain_id.t Lwt.t +val get_chain: State.t -> Chain_services.chain -> State.Chain.t Lwt.t -module S : sig - val pending_operations: - ([ `POST ], unit, - unit , unit, unit, - error Preapply_result.t * Operation.t Operation_hash.Map.t) RPC_service.t -end +val rpc_directory: State.Chain.t Lwt.t RPC_directory.t -open RPC_context - -val pending_operations: - #simple -> - (error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t +val build_rpc_directory: State.t -> Validator.t -> unit RPC_directory.t diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index 71fc0f115..a0876035d 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -10,57 +10,11 @@ open Lwt.Infix open Worker_logging -let inject_operation validator ?chain_id bytes = - let t = - match Data_encoding.Binary.of_bytes Operation.encoding bytes with - | None -> failwith "Can't parse the operation" - | Some op -> - Validator.inject_operation validator ?chain_id op - in - let hash = Operation_hash.hash_bytes [bytes] in - Lwt.return (hash, t) - -let inject_protocol state ?force:_ proto = - let proto_bytes = - Data_encoding.Binary.to_bytes_exn Protocol.encoding proto in - let hash = Protocol_hash.hash_bytes [proto_bytes] in - let validation = - Updater.compile hash proto >>= function - | false -> - failwith - "Compilation failed (%a)" - Protocol_hash.pp_short hash - | true -> - State.Protocol.store state proto >>= function - | None -> - failwith - "Previously registered protocol (%a)" - Protocol_hash.pp_short hash - | Some _ -> return () - in - Lwt.return (hash, validation) - -let inject_block validator ?force ?chain_id bytes operations = - Validator.validate_block - validator ?force ?chain_id bytes operations >>=? fun (hash, block) -> - return (hash, (block >>=? fun _ -> return ())) - type t = { state: State.t ; distributed_db: Distributed_db.t ; validator: Validator.t ; mainchain_validator: Chain_validator.t ; - inject_block: - ?force:bool -> - ?chain_id:Chain_id.t -> - MBytes.t -> Operation.t list list -> - (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t ; - inject_operation: - ?chain_id:Chain_id.t -> MBytes.t -> - (Operation_hash.t * unit tzresult Lwt.t) Lwt.t ; - inject_protocol: - ?force:bool -> Protocol.t -> - (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t ; p2p: Distributed_db.p2p ; (* For P2P RPCs *) shutdown: unit -> unit Lwt.t ; } @@ -139,12 +93,6 @@ and chain_validator_limits = Chain_validator.limits = { worker_limits : Worker_types.limits ; } -let may_create_chain state genesis = - State.Chain.get state (Chain_id.of_block_hash genesis.State.Chain.block) >>= function - | Ok chain -> Lwt.return chain - | Error _ -> - State.Chain.create state genesis - let create { genesis ; store_root ; context_root ; patch_context ; p2p = p2p_params ; test_chain_max_tll = max_child_ttl } @@ -178,381 +126,28 @@ let create { genesis ; store_root ; context_root ; distributed_db ; validator ; mainchain_validator ; - inject_block = inject_block validator ; - inject_operation = inject_operation validator ; - inject_protocol = inject_protocol state ; p2p ; shutdown ; } let shutdown node = node.shutdown () -module RPC = struct +let build_rpc_directory node = + let dir : unit RPC_directory.t ref = ref RPC_directory.empty in + let merge d = dir := RPC_directory.merge !dir d in + let register0 s f = + dir := RPC_directory.register !dir s (fun () p q -> f p q) in - type block = Block_services.block - type block_info = Block_services.block_info = { - hash: Block_hash.t ; - chain_id: Chain_id.t ; - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - validation_passes: int ; (* uint8 *) - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - context: Context_hash.t ; - protocol_data: MBytes.t ; - operations: (Operation_hash.t * Operation.t) list list option ; - protocol: Protocol_hash.t ; - test_chain: Test_chain_status.t ; - } + merge (Protocol_directory.build_rpc_directory node.state node.distributed_db) ; + merge (Shell_directory.build_rpc_directory + node.state node.validator node.mainchain_validator) ; + merge (Chain_directory.build_rpc_directory node.state node.validator) ; + merge (P2p.build_rpc_directory node.p2p) ; + merge Worker_directory.rpc_directory ; - let convert (block: State.Block.t) = - let hash = State.Block.hash block in - let header = State.Block.header block in - State.Block.all_operations block >>= fun operations -> - let operations = - List.map (List.map (fun op -> (Operation.hash op, op))) operations in - State.Block.context block >>= fun context -> - Context.get_protocol context >>= fun protocol -> - Context.get_test_chain context >>= fun test_chain -> - Lwt.return { - hash ; - chain_id = State.Block.chain_id block ; - level = header.shell.level ; - proto_level = header.shell.proto_level ; - predecessor = header.shell.predecessor ; - timestamp = header.shell.timestamp ; - validation_passes = header.shell.validation_passes ; - operations_hash = header.shell.operations_hash ; - fitness = header.shell.fitness ; - context = header.shell.context ; - protocol_data = header.protocol_data ; - operations = Some operations ; - protocol ; - test_chain ; - } + register0 RPC_service.error_service begin fun () () -> + return (Data_encoding.Json.schema Error_monad.error_encoding) + end ; - let inject_block node = node.inject_block - let inject_operation node = node.inject_operation - let inject_protocol node = node.inject_protocol - - let raw_block_info node hash = - State.read_block node.state hash >>= function - | Some block -> - convert block - | None -> - Lwt.fail Not_found - - let prevalidation_hash = - Block_hash.of_b58check_exn - "BLockPrevaLidationPrevaLidationPrevaLidationPrZ4mr6" - - let get_validator node = function - | `Genesis | `Head _ -> node.mainchain_validator - | `Test_head _ -> - match Chain_validator.child node.mainchain_validator with - | None -> raise Not_found - | Some v -> v - - let get_validator_per_hash node hash = - State.read_block_exn node.state hash >>= fun block -> - let chain_id = State.Block.chain_id block in - if Chain_id.equal (Chain_validator.chain_id node.mainchain_validator) chain_id then - Lwt.return (Some node.mainchain_validator) - else - match Chain_validator.child node.mainchain_validator with - | Some test_validator -> - if Chain_id.equal (Chain_validator.chain_id test_validator) chain_id then - Lwt.return_some test_validator - else - Lwt.return_none - | _ -> Lwt.return_none - - let read_valid_block node h n = - State.read_block node.state ~pred:n h - - let read_valid_block_exn node h n = - State.read_block_exn node.state ~pred:n h - - let get_block node = function - | `Genesis -> - let chain_state = Chain_validator.chain_state node.mainchain_validator in - Chain.genesis chain_state - | ( `Head n | `Test_head n ) as block -> - let validator = get_validator node block in - let chain_state = Chain_validator.chain_state validator in - Chain.head chain_state >>= fun head -> - if n = 0 then - Lwt.return head - else - read_valid_block_exn node (State.Block.hash head) n - | `Hash (hash, n) -> - read_valid_block node hash n >>= function - | None -> Lwt.fail Not_found - | Some b -> Lwt.return b - - let block_info node (block: block) = - get_block node block >>= convert - - let rpc_context block : Tezos_protocol_environment_shell.rpc_context Lwt.t = - let block_hash = State.Block.hash block in - let block_header = State.Block.header block in - State.Block.context block >|= fun context -> - { Tezos_protocol_environment_shell.block_hash ; - block_header ; - operation_hashes = (fun () -> State.Block.all_operation_hashes block) ; - operations = (fun () -> State.Block.all_operations block) ; - context ; - } - - let get_rpc_context node block = - Lwt.catch begin fun () -> - get_block node block >>= fun block -> - rpc_context block >>= fun ctxt -> - Lwt.return (Some ctxt) - end begin - fun _ -> Lwt.return None - end - - let operation_hashes node block = - get_block node block >>= fun block -> - State.Block.all_operation_hashes block - - let operations node block = - get_block node block >>= fun block -> - State.Block.all_operations block - - let pending_operations node = - let validator = get_validator node (`Head 0) in - let pv_opt = Chain_validator.prevalidator validator in - match pv_opt with - | Some pv -> - Lwt.return (Prevalidator.operations pv) - | None -> - Lwt.return (Preapply_result.empty, Operation_hash.Map.empty) - - let protocols { state } = - State.Protocol.list state >>= fun set -> - Lwt.return (Protocol_hash.Set.elements set) - - let protocol_content node hash = - State.Protocol.read node.state hash - - let preapply - node block - ~timestamp ~protocol_data ~sort_operations:sort ops = - get_block node block >>= fun predecessor -> - Prevalidation.start_prevalidation - ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state -> - let ops = List.map (List.map (fun x -> Operation.hash x, x)) ops in - Lwt_list.fold_left_s - (fun (validation_state, rs) ops -> - Prevalidation.prevalidate - validation_state ~sort ops >>= fun (validation_state, r) -> - Lwt.return (validation_state, rs @ [r])) - (validation_state, []) ops >>= fun (validation_state, rs) -> - let operations_hash = - Operation_list_list_hash.compute - (List.map - (fun r -> - Operation_list_hash.compute - (List.map fst r.Preapply_result.applied)) - rs) in - Prevalidation.end_prevalidation - validation_state >>=? fun { fitness ; context ; message } -> - let pred_shell_header = State.Block.shell_header predecessor in - State.Block.protocol_hash predecessor >>= fun pred_protocol -> - Context.get_protocol context >>= fun protocol -> - let proto_level = - if Protocol_hash.equal protocol pred_protocol then - pred_shell_header.proto_level - else - ((pred_shell_header.proto_level + 1) mod 256) in - let shell_header : Block_header.shell_header = { - level = Int32.succ pred_shell_header.level ; - proto_level ; - predecessor = State.Block.hash predecessor ; - timestamp ; - validation_passes = List.length rs ; - operations_hash ; - fitness ; - context = Context_hash.zero ; (* place holder *) - } in - begin - if Protocol_hash.equal protocol pred_protocol then - return (context, message) - else - match Registered_protocol.get protocol with - | None -> - fail (Block_validator_errors.Unavailable_protocol - { block = State.Block.hash predecessor ; protocol }) - | Some (module NewProto) -> - NewProto.init context shell_header >>=? fun { context ; message ; _ } -> - return (context, message) - end >>=? fun (context, message) -> - Context.commit ?message ~time:timestamp context >>= fun context -> - return ({ shell_header with context }, rs) - - let complete node ?block str = - match block with - | None -> - Base58.complete str - | Some block -> - get_rpc_context node block >>= function - | None -> Lwt.fail Not_found - | Some { context = ctxt } -> - Context.get_protocol ctxt >>= fun protocol_hash -> - let (module Proto) = Registered_protocol.get_exn protocol_hash in - Base58.complete str >>= fun l1 -> - Proto.complete_b58prefix ctxt str >>= fun l2 -> - Lwt.return (l1 @ l2) - - let context_dir node block = - get_rpc_context node block >>= function - | None -> Lwt.return None - | Some rpc_context -> - Context.get_protocol rpc_context.context >>= fun protocol_hash -> - let (module Proto) = Registered_protocol.get_exn protocol_hash in - let dir = RPC_directory.map (fun () -> Lwt.return rpc_context) Proto.rpc_services in - Lwt.return (Some (RPC_directory.map (fun _ -> ()) dir)) - - let context_raw_get node block ~path ~depth = - let open Block_services in - (* negative depth could be handled by a more informative error *) - if depth < 0 then Lwt.return_none else - get_rpc_context node block >>= function - | None -> Lwt.return_none - | Some rpc_context -> - let rec loop path depth = (* non tail-recursive *) - if depth = 0 then Lwt.return Cut else - (* try to read as file *) - Context.get rpc_context.context path >>= function - | Some v -> Lwt.return (Key v) - | None -> (* try to read as directory *) - Context.fold rpc_context.context path ~init:[] - ~f:(fun k acc -> - match k with - | `Key k | `Dir k -> - loop k (depth-1) >>= fun v -> - let k = List.nth k ((List.length k)-1) in - Lwt.return ((k,v)::acc)) >>= fun l -> - Lwt.return (Dir (List.rev l)) - in - Context.mem rpc_context.context path >>= fun mem -> - Context.dir_mem rpc_context.context path >>= fun dir_mem -> - if mem || dir_mem then - loop path depth >>= Lwt.return_some - else Lwt.return_none - - let heads node = - let chain_state = Chain_validator.chain_state node.mainchain_validator in - Chain.known_heads chain_state >>= fun heads -> - begin - match Chain_validator.child node.mainchain_validator with - | None -> Lwt.return_nil - | Some test_validator -> - let chain_state = Chain_validator.chain_state test_validator in - Chain.known_heads chain_state - end >>= fun test_heads -> - Lwt_list.fold_left_s - (fun map block -> - convert block >|= fun bi -> - Block_hash.Map.add - (State.Block.hash block) bi map) - Block_hash.Map.empty (test_heads @ heads) - - let predecessors node len head = - let rec loop acc len block = - if len = 0 then - Lwt.return (List.rev acc) - else - State.Block.predecessor block >>= function - | None -> Lwt.return (List.rev acc) - | Some block -> - loop (State.Block.hash block :: acc) (len-1) block - in - try - State.read_block_exn node.state head >>= fun block -> - loop [] len block - with Not_found -> Lwt.return_nil - - let predecessors_bi ignored len head = - try - let rec loop acc len block = - convert block >>= fun bi -> - State.Block.predecessor block >>= function - | None -> - Lwt.return (List.rev (bi :: acc)) - | Some pred -> - if len = 0 || - Block_hash.Set.mem (State.Block.hash block) ignored then - Lwt.return (List.rev acc) - else - loop (bi :: acc) (len-1) pred - in - loop [] len head - with Not_found -> Lwt.return_nil - - let list node len heads = - Lwt_list.fold_left_s - (fun (ignored, acc) head -> - State.read_block_exn node.state head >>= fun block -> - predecessors_bi ignored len block >>= fun predecessors -> - let ignored = - List.fold_right - (fun x s -> Block_hash.Set.add x.hash s) - predecessors ignored in - Lwt.return (ignored, predecessors :: acc) - ) - (Block_hash.Set.empty, []) - heads >>= fun (_, blocks) -> - Lwt.return (List.rev blocks) - - let list_invalid node = - State.Block.list_invalid (Chain_validator.chain_state node.mainchain_validator) - - let unmark_invalid node block = - State.Block.unmark_invalid (Chain_validator.chain_state node.mainchain_validator) block - - let block_header_watcher node = - Distributed_db.watch_block_header node.distributed_db - - let block_watcher node = - let stream, shutdown = Validator.watcher node.validator in - Lwt_stream.map_s (fun block -> convert block) stream, - shutdown - - let operation_watcher node = - Distributed_db.watch_operation node.distributed_db - - let protocol_watcher node = - Distributed_db.Protocol.watch node.distributed_db - - let bootstrapped node = - let block_stream, stopper = - Chain_validator.new_head_watcher node.mainchain_validator in - let first_run = ref true in - let next () = - if !first_run then begin - first_run := false ; - let chain_state = Chain_validator.chain_state node.mainchain_validator in - Chain.head chain_state >>= fun head -> - let head_hash = State.Block.hash head in - let head_header = State.Block.header head in - Lwt.return (Some (head_hash, head_header.shell.timestamp)) - end else begin - Lwt.pick [ - ( Lwt_stream.get block_stream >|= - Option.map ~f:(fun b -> - (State.Block.hash b, (State.Block.header b).shell.timestamp)) ) ; - (Chain_validator.bootstrapped node.mainchain_validator >|= fun () -> None) ; - ] - end in - let shutdown () = Lwt_watcher.shutdown stopper in - RPC_answer.{ next ; shutdown } - - let build_p2p_rpc_directory (t : t) = - P2p.build_rpc_directory t.p2p - -end + RPC_directory.register_describe_directory_service + !dir RPC_service.description_service diff --git a/src/lib_shell/node.mli b/src/lib_shell/node.mli index 380243579..43c49490e 100644 --- a/src/lib_shell/node.mli +++ b/src/lib_shell/node.mli @@ -47,94 +47,6 @@ val create: chain_validator_limits -> t tzresult Lwt.t -module RPC : sig - - type block = Block_services.block - type block_info = Block_services.block_info - - val inject_block: - t -> ?force:bool -> ?chain_id:Chain_id.t -> - MBytes.t -> Operation.t list list -> - (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t - (** [inject_block node ?force bytes] tries to insert [bytes] - (supposedly the serialization of a block header) inside - [node]. If [?force] is true, the block will be inserted even on - non strictly increasing fitness. *) - - val inject_operation: - t -> ?chain_id:Chain_id.t -> MBytes.t -> - (Operation_hash.t * unit tzresult Lwt.t) Lwt.t - val inject_protocol: - t -> ?force:bool -> Protocol.t -> - (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t - - val raw_block_info: - t -> Block_hash.t -> block_info Lwt.t - val block_header_watcher: - t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Lwt_watcher.stopper - val block_watcher: - t -> (block_info Lwt_stream.t * Lwt_watcher.stopper) - val heads: t -> block_info Block_hash.Map.t Lwt.t - - val predecessors: - t -> int -> Block_hash.t -> Block_hash.t list Lwt.t - - val list: - t -> int -> Block_hash.t list -> block_info list list Lwt.t - - val list_invalid: - t -> (Block_hash.t * int32 * error list) list Lwt.t - - val unmark_invalid: - t -> Block_hash.t -> unit tzresult Lwt.t - - val block_info: - t -> block -> block_info Lwt.t - - val operation_hashes: - t -> block -> Operation_hash.t list list Lwt.t - val operations: - t -> block -> Operation.t list list Lwt.t - val operation_watcher: - t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper - - val pending_operations: - t -> - (error Preapply_result.t * Operation.t Operation_hash.Map.t) Lwt.t - - val protocols: - t -> Protocol_hash.t list Lwt.t - val protocol_content: - t -> Protocol_hash.t -> Protocol.t tzresult Lwt.t - val protocol_watcher: - t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Lwt_watcher.stopper - - val context_dir: - t -> block -> 'a RPC_directory.t option Lwt.t - - (** Returns the content of the context at the given [path] descending - recursively into directories as far as [depth] allows. - Returns [None] if a path in not in the context or if [depth] is - negative. *) - val context_raw_get: - t -> block -> path:string list -> depth:int -> - Block_services.raw_context_result option Lwt.t - - val preapply: - t -> block -> - timestamp:Time.t -> protocol_data:MBytes.t -> - sort_operations:bool -> Operation.t list list -> - (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t - - val complete: - t -> ?block:block -> string -> string list Lwt.t - - val bootstrapped: - t -> (Block_hash.t * Time.t) RPC_answer.stream - - - val build_p2p_rpc_directory: t -> unit RPC_directory.t - -end - val shutdown: t -> unit Lwt.t + +val build_rpc_directory: t -> unit RPC_directory.t diff --git a/src/lib_shell/node_rpc.ml b/src/lib_shell/node_rpc.ml deleted file mode 100644 index ce83b5659..000000000 --- a/src/lib_shell/node_rpc.ml +++ /dev/null @@ -1,503 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open RPC_logging - -let filter_bi operations (bi: Block_services.block_info) = - let bi = if operations then bi else { bi with operations = None } in - bi - -let register_bi_dir node dir = - let dir = - let implementation b () include_ops = - Node.RPC.block_info node b >>= fun bi -> - return (filter_bi include_ops bi) in - RPC_directory.register1 dir - Block_services.S.info implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.hash in - RPC_directory.register1 dir - Block_services.S.hash - implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.chain_id in - RPC_directory.register1 dir - Block_services.S.chain_id implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.level in - RPC_directory.register1 dir - Block_services.S.level implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.predecessor in - RPC_directory.register1 dir - Block_services.S.predecessor implementation in - let dir = - let implementation b () len = - Node.RPC.block_info node b >>= fun bi -> - Node.RPC.predecessors node len bi.hash >>= fun hashes -> - return hashes in - RPC_directory.register1 dir - Block_services.S.predecessors implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.fitness in - RPC_directory.register1 dir - Block_services.S.fitness implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.timestamp in - RPC_directory.register1 dir - Block_services.S.timestamp implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.protocol in - RPC_directory.register1 dir - Block_services.S.protocol implementation in - let dir = - let implementation b () () = - Node.RPC.block_info node b >>= fun bi -> - return bi.test_chain in - RPC_directory.register1 dir - Block_services.S.test_chain implementation in - let dir = - let implementation b () { Block_services.S.contents } = - Node.RPC.operation_hashes node b >>= fun hashes -> - if contents then - Node.RPC.operations node b >>= fun ops -> - RPC_answer.return @@ - List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops - else - RPC_answer.return @@ - List.map (List.map (fun h -> h, None)) hashes - in - RPC_directory.gen_register1 dir - Block_services.S.operations implementation in - - let dir = - let implementation - b () - { Block_services.S.operations ; sort_operations ; - timestamp ; protocol_data } = - Node.RPC.preapply node b - ~timestamp ~protocol_data ~sort_operations operations - >>=? fun (shell_header, operations) -> - return { Block_services.shell_header ; operations } in - RPC_directory.register1 dir - Block_services.S.preapply implementation in - dir - -let rec insert_future_block (bi: Block_services.block_info) = function - | [] -> [bi] - | ({timestamp} as head: Block_services.block_info) :: tail as all -> - if Time.compare bi.timestamp timestamp < 0 then - bi :: all - else - head :: insert_future_block bi tail - -let create_delayed_stream - ~filtering ~include_ops requested_heads bi_stream delay = - let stream, push = Lwt_stream.create () in - let current_blocks = - ref (List.fold_left - (fun acc h -> Block_hash.Set.add h acc) - Block_hash.Set.empty requested_heads) in - let next_future_block, is_futur_block, - insert_future_block, pop_future_block = - let future_blocks = ref [] in (* FIXME *) - let future_blocks_set = ref Block_hash.Set.empty in - let next () = - match !future_blocks with - | [] -> None - | bi :: _ -> Some bi - and mem hash = Block_hash.Set.mem hash !future_blocks_set - and insert bi = - future_blocks := insert_future_block bi !future_blocks ; - future_blocks_set := - Block_hash.Set.add bi.hash !future_blocks_set - and pop time = - match !future_blocks with - | {timestamp} as bi :: rest when Time.(timestamp <= time) -> - future_blocks := rest ; - future_blocks_set := - Block_hash.Set.remove bi.hash !future_blocks_set ; - Some bi - | _ -> None in - next, mem, insert, pop in - let _block_watcher_worker = - let never_ending = fst (Lwt.wait ()) in - let rec worker_loop () = - lwt_debug "WWW worker_loop" >>= fun () -> - let time = Time.(add (now ()) (Int64.of_int ~-delay)) in - let migration_delay = - match next_future_block () with - | None -> never_ending - | Some bi -> - let delay = Time.diff bi.timestamp time in - if delay <= 0L then - Lwt.return_unit - else - Lwt_unix.sleep (Int64.to_float delay) in - Lwt.choose [(migration_delay >|= fun () -> `Migrate) ; - (Lwt_stream.get bi_stream >|= fun x -> `Block x) ] - >>= function - | `Block None -> - lwt_debug "WWW worker_loop None" >>= fun () -> - Lwt.return_unit - | `Block (Some (bi : Block_services.block_info)) -> - lwt_debug "WWW worker_loop Some" >>= fun () -> - begin - if not filtering - || Block_hash.Set.mem bi.predecessor !current_blocks - || is_futur_block bi.predecessor - then begin - let time = Time.(add (now ()) (Int64.of_int ~-delay)) in - if Time.(time < bi.timestamp) then begin - insert_future_block bi ; - Lwt.return_unit - end else begin - current_blocks := - Block_hash.Set.remove bi.predecessor !current_blocks - |> Block_hash.Set.add bi.hash ; - push (Some [[filter_bi include_ops bi]]) ; - Lwt.return_unit - end - end else begin - Lwt.return_unit - end - end >>= fun () -> - worker_loop () - | `Migrate -> - lwt_debug "WWW worker_loop Migrate" >>= fun () -> - let time = Time.(add (now ()) (Int64.of_int ~-delay)) in - let rec migrate_future_blocks () = - match pop_future_block time with - | Some bi -> - push (Some [[filter_bi include_ops bi]]) ; - migrate_future_blocks () - | None -> Lwt.return_unit in - migrate_future_blocks () >>= fun () -> - worker_loop () - in - Lwt_utils.worker "block_watcher" - ~run:worker_loop ~cancel:(fun () -> Lwt.return_unit) in - stream - -let list_blocks - node () - { Block_services.S.include_ops ; length ; heads ; monitor ; delay ; - min_date; min_heads} = - let len = match length with None -> 1 | Some x -> x in - let monitor = match monitor with None -> false | Some x -> x in - let time = - match delay with - | None -> None - | Some delay -> Some (Time.(add (now ()) (Int64.of_int ~-delay))) in - begin - match heads with - | None -> - Node.RPC.heads node >>= fun heads -> - let heads = List.map snd (Block_hash.Map.bindings heads) in - let heads = - match min_date with - | None -> heads - | Some date -> - let min_heads = - match min_heads with - | None -> 0 - | Some min_heads -> min_heads in - snd @@ - List.fold_left (fun (min_heads, acc) (bi : Node.RPC.block_info) -> - min_heads - 1, - if Time.(>) bi.timestamp date || min_heads > 0 then bi :: acc - else acc) - (min_heads, []) heads in - begin - match time with - | None -> Lwt.return heads - | Some time -> - let rec current_predecessor (bi: Node.RPC.block_info) = - if Time.compare bi.timestamp time <= 0 - || bi.hash = bi.predecessor then - Lwt.return bi - else - Node.RPC.raw_block_info node bi.predecessor >>= - current_predecessor in - Lwt_list.map_p current_predecessor heads - end >|= fun heads_info -> - let sorted_infos = - List.sort - (fun - (bi1: Block_services.block_info) - (bi2: Block_services.block_info) -> - ~- (Fitness.compare bi1.fitness bi2.fitness)) - heads_info in - List.map - (fun ({ hash } : Block_services.block_info) -> hash) - sorted_infos - | Some heads -> - let known_block h = - try ignore (Node.RPC.raw_block_info node h) ; true - with Not_found -> false in - Lwt.return (List.filter known_block heads) - end >>= fun requested_heads -> - Node.RPC.list node len requested_heads >>= fun requested_blocks -> - if not monitor then - let infos = - List.map - (List.map (filter_bi include_ops)) - requested_blocks in - RPC_answer.return infos - else begin - let (bi_stream, stopper) = Node.RPC.block_watcher node in - let stream = - match delay with - | None -> - Lwt_stream.map (fun bi -> [[filter_bi include_ops bi]]) bi_stream - | Some delay -> - let filtering = heads <> None in - create_delayed_stream - ~filtering ~include_ops requested_heads bi_stream delay in - let shutdown () = Lwt_watcher.shutdown stopper in - let first_request = ref true in - let next () = - if not !first_request then begin - Lwt_stream.get stream - end else begin - first_request := false ; - let infos = - List.map (List.map (filter_bi include_ops)) requested_blocks in - Lwt.return (Some infos) - end in - RPC_answer.return_stream { next ; shutdown } - end - -let list_invalid node () () = - Node.RPC.list_invalid node >>= return - -let unmark_invalid node block () () = - Node.RPC.unmark_invalid node block - -let list_protocols node () { Protocol_services.S.monitor ; contents } = - let monitor = match monitor with None -> false | Some x -> x in - let include_contents = match contents with None -> false | Some x -> x in - Node.RPC.protocols node >>= fun protocols -> - Lwt_list.map_p - (fun hash -> - if include_contents then - Node.RPC.protocol_content node hash >>= function - | Error _ -> Lwt.return (hash, None) - | Ok bytes -> Lwt.return (hash, Some bytes) - else - Lwt.return (hash, None)) - protocols >>= fun protocols -> - if not monitor then - RPC_answer.return protocols - else - let stream, stopper = Node.RPC.protocol_watcher node in - let shutdown () = Lwt_watcher.shutdown stopper in - let first_request = ref true in - let next () = - if not !first_request then - Lwt_stream.get stream >>= function - | None -> Lwt.return_none - | Some (h, op) when include_contents -> Lwt.return (Some [h, Some op]) - | Some (h, _) -> Lwt.return (Some [h, None]) - else begin - first_request := false ; - Lwt.return (Some protocols) - end in - RPC_answer.return_stream { next ; shutdown } - -let get_protocols node hash () () = - Node.RPC.protocol_content node hash - -let build_rpc_directory node = - let dir = RPC_directory.empty in - let dir = - RPC_directory.gen_register0 dir Block_services.S.list - (list_blocks node) in - let dir = - RPC_directory.register0 dir Block_services.S.list_invalid - (list_invalid node) in - let dir = - RPC_directory.register1 dir Block_services.S.unmark_invalid - (unmark_invalid node) in - let dir = register_bi_dir node dir in - let dir = - let implementation block = - Lwt.catch (fun () -> - Node.RPC.context_dir node block >>= function - | None -> Lwt.fail Not_found - | Some context_dir -> Lwt.return context_dir) - (fun _ -> Lwt.return RPC_directory.empty) in - RPC_directory.register_dynamic_directory1 - ~descr: - "All the RPCs which are specific to the protocol version." - dir (Block_services.S.proto_path ()) implementation in - let dir = - RPC_directory.gen_register0 dir Protocol_services.S.list - (list_protocols node) in - let dir = - RPC_directory.register1 dir Protocol_services.S.contents - (get_protocols node) in - let dir = - let implementation () header = - let res = - Data_encoding.Binary.to_bytes_exn Block_header.encoding header in - RPC_answer.return res in - RPC_directory.gen_register0 dir Shell_services.S.forge_block_header - implementation in - let dir = - let implementation () - { Shell_services.S.raw ; blocking ; force ; operations } = - begin - Node.RPC.inject_block - node ~force - raw operations >>=? fun (hash, wait) -> - (if blocking then wait else return ()) >>=? fun () -> return hash - end in - RPC_directory.register0 dir Shell_services.S.inject_block implementation in - let dir = - let implementation () (contents, blocking, chain_id) = - Node.RPC.inject_operation - node ?chain_id contents >>= fun (hash, wait) -> - begin - (if blocking then wait else return ()) >>=? fun () -> return hash - end in - RPC_directory.register0 dir Shell_services.S.inject_operation implementation in - let dir = - let implementation () (proto, blocking, force) = - Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) -> - begin - (if blocking then wait else return ()) >>=? fun () -> return hash - end in - RPC_directory.register0 dir Shell_services.S.inject_protocol implementation in - let dir = - let implementation () () = - RPC_answer.return_stream (Node.RPC.bootstrapped node) in - RPC_directory.gen_register0 dir Shell_services.S.bootstrapped implementation in - let dir = - let implementation () () = - return Data_encoding.Json.(schema Error_monad.error_encoding) in - RPC_directory.register0 dir RPC_service.error_service implementation in - let dir = - RPC_directory.register1 dir Shell_services.S.complete - (fun s () () -> Node.RPC.complete node s >>= return) in - let dir = - RPC_directory.register2 dir Block_services.S.complete - (fun block s () () -> Node.RPC.complete node ~block s >>= return) in - let dir = - RPC_directory.register2 dir Block_services.S.raw_context - (fun block path q () -> - Node.RPC.context_raw_get node block ~path ~depth:q#depth >>= function - | None -> raise Not_found - | Some v -> return v) - in - - (* Workers : Prevalidators *) - - let dir = - RPC_directory.register0 dir Worker_services.Prevalidators.S.list - (fun () () -> - return - (List.map - (fun (id, w) -> (id, Prevalidator.status w)) - (Prevalidator.running_workers ()))) in - let dir = - RPC_directory.register1 dir Worker_services.Prevalidators.S.state - (fun chain_id () () -> - let w = List.assoc chain_id (Prevalidator.running_workers ()) in - return - { Worker_types.status = Prevalidator.status w ; - pending_requests = Prevalidator.pending_requests w ; - backlog = Prevalidator.last_events w ; - current_request = Prevalidator.current_request w }) in - - (* Workers : Block_validator *) - - let dir = - RPC_directory.register0 dir Worker_services.Block_validator.S.state - (fun () () -> - let w = Block_validator.running_worker () in - return - { Worker_types.status = Block_validator.status w ; - pending_requests = Block_validator.pending_requests w ; - backlog = Block_validator.last_events w ; - current_request = Block_validator.current_request w }) in - - (* Workers : Peer validators *) - - let dir = - RPC_directory.register1 dir Worker_services.Peer_validators.S.list - (fun chain_id () () -> - return - (List.filter_map - (fun ((id, peer_id), w) -> - if Chain_id.equal id chain_id then - Some (peer_id, Peer_validator.status w) - else None) - (Peer_validator.running_workers ()))) in - let dir = - RPC_directory.register2 dir Worker_services.Peer_validators.S.state - (fun chain_id peer_id () () -> - let w = List.assoc (chain_id, peer_id) (Peer_validator.running_workers ()) in - return - { Worker_types.status = Peer_validator.status w ; - pending_requests = [] ; - backlog = Peer_validator.last_events w ; - current_request = Peer_validator.current_request w }) in - - (* Workers : Net validators *) - let dir = - RPC_directory.register0 dir Worker_services.Chain_validators.S.list - (fun () () -> - return - (List.map - (fun (id, w) -> (id, Chain_validator.status w)) - (Chain_validator.running_workers ()))) in - let dir = - RPC_directory.register1 dir Worker_services.Chain_validators.S.state - (fun chain_id () () -> - let w = List.assoc chain_id (Chain_validator.running_workers ()) in - return - { Worker_types.status = Chain_validator.status w ; - pending_requests = Chain_validator.pending_requests w ; - backlog = Chain_validator.last_events w ; - current_request = Chain_validator.current_request w }) in - - (* Network *) - let dir = RPC_directory.merge dir (Node.RPC.build_p2p_rpc_directory node) in - - (* Mempool *) - let dir = - let implementation () () () = - Node.RPC.pending_operations node >>= fun res -> - return res in - RPC_directory.register dir - Mempool_services.S.pending_operations - implementation in - - let dir = - RPC_directory.register_describe_directory_service - dir RPC_service.description_service in - - - dir - diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 647a60e6b..bc2dd6704 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -54,7 +54,7 @@ type prevalidation_state = -> prevalidation_state and 'a proto = - (module Registered_protocol.T with type validation_state = 'a) + (module Registered_protocol.T with type P.validation_state = 'a) let start_prevalidation ?protocol_data @@ -166,3 +166,54 @@ let prevalidate let end_prevalidation (State { proto = (module Proto) ; state }) = Proto.finalize_block state >>=? fun (result, _metadata) -> return result + +let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops = + start_prevalidation + ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state -> + let ops = List.map (List.map (fun x -> Operation.hash x, x)) ops in + Lwt_list.fold_left_s + (fun (validation_state, rs) ops -> + prevalidate + validation_state ~sort ops >>= fun (validation_state, r) -> + Lwt.return (validation_state, rs @ [r])) + (validation_state, []) ops >>= fun (validation_state, rs) -> + let operations_hash = + Operation_list_list_hash.compute + (List.map + (fun r -> + Operation_list_hash.compute + (List.map fst r.Preapply_result.applied)) + rs) in + end_prevalidation validation_state >>=? fun { fitness ; context ; message } -> + let pred_shell_header = State.Block.shell_header predecessor in + State.Block.protocol_hash predecessor >>= fun pred_protocol -> + Context.get_protocol context >>= fun protocol -> + let proto_level = + if Protocol_hash.equal protocol pred_protocol then + pred_shell_header.proto_level + else + ((pred_shell_header.proto_level + 1) mod 256) in + let shell_header : Block_header.shell_header = { + level = Int32.succ pred_shell_header.level ; + proto_level ; + predecessor = State.Block.hash predecessor ; + timestamp ; + validation_passes = List.length rs ; + operations_hash ; + fitness ; + context = Context_hash.zero ; (* place holder *) + } in + begin + if Protocol_hash.equal protocol pred_protocol then + return (context, message) + else + match Registered_protocol.get protocol with + | None -> + fail (Block_validator_errors.Unavailable_protocol + { block = State.Block.hash predecessor ; protocol }) + | Some (module NewProto) -> + NewProto.init context shell_header >>=? fun { context ; message ; _ } -> + return (context, message) + end >>=? fun (context, message) -> + Context.commit ?message ~time:timestamp context >>= fun context -> + return ({ shell_header with context }, rs) diff --git a/src/lib_shell/prevalidation.mli b/src/lib_shell/prevalidation.mli index 13be9e85e..a494e296d 100644 --- a/src/lib_shell/prevalidation.mli +++ b/src/lib_shell/prevalidation.mli @@ -23,3 +23,12 @@ val prevalidate : val end_prevalidation : prevalidation_state -> Tezos_protocol_environment_shell.validation_result tzresult Lwt.t + +val preapply : + predecessor:State.Block.t -> + timestamp:Time.t -> + protocol_data:MBytes.t -> + sort_operations:bool -> + Operation.t list list -> + (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t + diff --git a/src/lib_shell/protocol_directory.ml b/src/lib_shell/protocol_directory.ml new file mode 100644 index 000000000..a01bc613d --- /dev/null +++ b/src/lib_shell/protocol_directory.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let build_rpc_directory state distributed_db = + + let dir : unit RPC_directory.t ref = ref RPC_directory.empty in + let gen_register0 s f = + dir := RPC_directory.gen_register !dir s (fun () p q -> f p q) in + let register1 s f = + dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q) in + + gen_register0 Protocol_services.S.list begin fun () p -> + let { Protocol_services.S.monitor ; contents } = p in + let monitor = match monitor with None -> false | Some x -> x in + let include_contents = match contents with None -> false | Some x -> x in + State.Protocol.list state >>= fun set -> + let protocols = Protocol_hash.Set.elements set in + Lwt_list.map_p + (fun hash -> + if include_contents then + State.Protocol.read state hash >>= function + | Error _ -> Lwt.return (hash, None) + | Ok bytes -> Lwt.return (hash, Some bytes) + else + Lwt.return (hash, None)) + protocols >>= fun protocols -> + if not monitor then + RPC_answer.return protocols + else + let stream, stopper = + Distributed_db.Protocol.watch distributed_db in + let shutdown () = Lwt_watcher.shutdown stopper in + let first_request = ref true in + let next () = + if not !first_request then + Lwt_stream.get stream >>= function + | None -> Lwt.return_none + | Some (h, op) when include_contents -> Lwt.return (Some [h, Some op]) + | Some (h, _) -> Lwt.return (Some [h, None]) + else begin + first_request := false ; + Lwt.return (Some protocols) + end in + RPC_answer.return_stream { next ; shutdown } + end; + + register1 Protocol_services.S.contents begin fun hash () () -> + State.Protocol.read state hash + end ; + + !dir diff --git a/src/lib_shell/protocol_directory.mli b/src/lib_shell/protocol_directory.mli new file mode 100644 index 000000000..b882ea375 --- /dev/null +++ b/src/lib_shell/protocol_directory.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val build_rpc_directory: + State.t -> Distributed_db.t -> unit RPC_directory.t diff --git a/src/lib_shell/shell_directory.ml b/src/lib_shell/shell_directory.ml new file mode 100644 index 000000000..298cafcbb --- /dev/null +++ b/src/lib_shell/shell_directory.ml @@ -0,0 +1,179 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let inject_block validator ?force ?chain_id bytes operations = + Validator.validate_block + validator ?force ?chain_id bytes operations >>=? fun (hash, block) -> + return (hash, (block >>=? fun _ -> return ())) + +let inject_operation validator ?chain_id bytes = + let t = + match Data_encoding.Binary.of_bytes Operation.encoding bytes with + | None -> failwith "Can't parse the operation" + | Some op -> + Validator.inject_operation validator ?chain_id op + in + let hash = Operation_hash.hash_bytes [bytes] in + Lwt.return (hash, t) + +let inject_protocol state ?force:_ proto = + let proto_bytes = + Data_encoding.Binary.to_bytes_exn Protocol.encoding proto in + let hash = Protocol_hash.hash_bytes [proto_bytes] in + let validation = + Updater.compile hash proto >>= function + | false -> + failwith + "Compilation failed (%a)" + Protocol_hash.pp_short hash + | true -> + State.Protocol.store state proto >>= function + | None -> + failwith + "Previously registered protocol (%a)" + Protocol_hash.pp_short hash + | Some _ -> return () + in + Lwt.return (hash, validation) + +let build_rpc_directory state validator mainchain_validator = + + let dir : unit RPC_directory.t ref = ref RPC_directory.empty in + let gen_register0 s f = + dir := RPC_directory.gen_register !dir s (fun () p q -> f p q) in + let register0 s f = + dir := RPC_directory.register !dir s (fun () p q -> f p q) in + let gen_register1 s f = + dir := RPC_directory.gen_register !dir s (fun ((), a) p q -> f a p q) in + + register0 Shell_services.S.forge_block_header begin fun () header -> + return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header) + end ; + + register0 Shell_services.S.inject_block begin fun () p -> + let { Shell_services.S.raw ; blocking ; force ; operations } = p in + inject_block validator ~force raw operations >>=? fun (hash, wait) -> + (if blocking then wait else return ()) >>=? fun () -> + return hash + end ; + + register0 Shell_services.S.inject_operation begin fun () p -> + let (contents, blocking, chain_id) = p in + inject_operation validator ?chain_id contents >>= fun (hash, wait) -> + (if blocking then wait else return ()) >>=? fun () -> + return hash + end ; + + register0 Shell_services.S.inject_protocol begin fun () p -> + let (proto, blocking, force) = p in + inject_protocol state ?force proto >>= fun (hash, wait) -> + (if blocking then wait else return ()) >>=? fun () -> + return hash + end ; + + gen_register0 Shell_services.S.bootstrapped begin fun () () -> + let block_stream, stopper = + Chain_validator.new_head_watcher mainchain_validator in + let first_run = ref true in + let next () = + if !first_run then begin + first_run := false ; + let chain_state = Chain_validator.chain_state mainchain_validator in + Chain.head chain_state >>= fun head -> + let head_hash = State.Block.hash head in + let head_header = State.Block.header head in + Lwt.return (Some (head_hash, head_header.shell.timestamp)) + end else begin + Lwt.pick [ + ( Lwt_stream.get block_stream >|= + Option.map ~f:(fun b -> + (State.Block.hash b, (State.Block.header b).shell.timestamp)) ) ; + (Chain_validator.bootstrapped mainchain_validator >|= fun () -> None) ; + ] + end in + let shutdown () = Lwt_watcher.shutdown stopper in + RPC_answer.return_stream { next ; shutdown } + end ; + + gen_register0 Shell_services.S.Monitor.valid_blocks begin fun q () -> + let block_stream, stopper = State.watcher state in + let shutdown () = Lwt_watcher.shutdown stopper in + let in_chains block = + Lwt_list.map_p (Chain_directory.get_chain_id state) q#chains >>= function + | [] -> Lwt.return_true + | chains -> + let chain_id = State.Block.chain_id block in + Lwt.return (List.exists (Chain_id.equal chain_id) chains) in + let in_protocols block = + match q#protocols with + | [] -> Lwt.return_true + | protocols -> + State.Block.predecessor block >>= function + | None -> Lwt.return_false (* won't happen *) + | Some pred -> + State.Block.context pred >>= fun context -> + Context.get_protocol context >>= fun protocol -> + Lwt.return (List.exists (Protocol_hash.equal protocol) protocols) in + let in_next_protocols block = + match q#next_protocols with + | [] -> Lwt.return_true + | protocols -> + State.Block.context block >>= fun context -> + Context.get_protocol context >>= fun next_protocol -> + Lwt.return (List.exists (Protocol_hash.equal next_protocol) protocols) in + let stream = + Lwt_stream.filter_map_s + (fun block -> + in_chains block >>= fun in_chains -> + in_next_protocols block >>= fun in_next_protocols -> + in_protocols block >>= fun in_protocols -> + if in_chains && in_protocols && in_next_protocols then + Lwt.return_some + (State.Block.chain_id block, State.Block.hash block) + else + Lwt.return_none) + block_stream in + let next () = Lwt_stream.get stream in + RPC_answer.return_stream { next ; shutdown } + end ; + + gen_register1 Shell_services.S.Monitor.heads begin fun chain q () -> + (* TODO: when `chain = `Test`, should we reset then stream when + the `testnet` change, or dias we currently do ?? *) + Chain_directory.get_chain state chain >>= fun chain -> + Validator.get_exn validator (State.Chain.id chain) >>= fun chain_validator -> + let block_stream, stopper = Chain_validator.new_head_watcher chain_validator in + Chain.head chain >>= fun head -> + let shutdown () = Lwt_watcher.shutdown stopper in + let in_next_protocols block = + match q#next_protocols with + | [] -> Lwt.return_true + | protocols -> + State.Block.context block >>= fun context -> + Context.get_protocol context >>= fun next_protocol -> + Lwt.return (List.exists (Protocol_hash.equal next_protocol) protocols) in + let stream = + Lwt_stream.filter_map_s + (fun block -> + in_next_protocols block >>= fun in_next_protocols -> + if in_next_protocols then + Lwt.return_some (State.Block.hash block) + else + Lwt.return_none) + block_stream in + let first_call = ref true in + let next () = + if !first_call then begin + first_call := false ; Lwt.return_some (State.Block.hash head) + end else + Lwt_stream.get stream in + RPC_answer.return_stream { next ; shutdown } + end ; + + !dir diff --git a/src/lib_shell/shell_directory.mli b/src/lib_shell/shell_directory.mli new file mode 100644 index 000000000..446422f0b --- /dev/null +++ b/src/lib_shell/shell_directory.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val build_rpc_directory: + State.t -> Validator.t -> Chain_validator.t -> unit RPC_directory.t diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index f901e44ec..b0bd4cd58 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -44,6 +44,8 @@ and chain_state = { context_index: Context.index Shared.t ; block_watcher: block Lwt_watcher.input ; chain_data: chain_data_state Shared.t ; + block_rpc_directories: + block RPC_directory.t Protocol_hash.Map.t Protocol_hash.Table.t ; } and genesis = { @@ -282,6 +284,7 @@ module Chain = struct block_store = Shared.create block_store ; context_index = Shared.create context_index ; block_watcher = Lwt_watcher.create_input () ; + block_rpc_directories = Protocol_hash.Table.create 7 ; } in Lwt.return chain_state @@ -722,6 +725,33 @@ module Block = struct read_exn chain_state tail >>= fun block -> Lwt.return_some (block, locator) + let get_rpc_directory ({ chain_state ; _ } as block) = + read_opt chain_state block.contents.header.shell.predecessor >>= function + | None -> Lwt.return_none (* genesis *) + | Some pred -> + protocol_hash pred >>= fun protocol -> + match + Protocol_hash.Table.find_opt + chain_state.block_rpc_directories protocol + with + | None -> Lwt.return_none + | Some map -> + protocol_hash block >>= fun next_protocol -> + Lwt.return (Protocol_hash.Map.find_opt next_protocol map) + + let set_rpc_directory ({ chain_state ; _ } as block) dir = + read_exn chain_state block.contents.header.shell.predecessor >>= fun pred -> + protocol_hash block >>= fun next_protocol -> + protocol_hash pred >>= fun protocol -> + let map = + Option.unopt ~default:Protocol_hash.Map.empty + (Protocol_hash.Table.find_opt chain_state.block_rpc_directories protocol) + in + Protocol_hash.Table.replace + chain_state.block_rpc_directories protocol + (Protocol_hash.Map.add next_protocol dir map) ; + Lwt.return_unit + end let watcher (state : global_state) = diff --git a/src/lib_shell/state.mli b/src/lib_shell/state.mli index 42deed6cf..fe70970fd 100644 --- a/src/lib_shell/state.mli +++ b/src/lib_shell/state.mli @@ -147,11 +147,14 @@ module Block : sig val known_ancestor: Chain.t -> Block_locator.t -> (block * Block_locator.t) option Lwt.t - (** [known_ancestor chain_state locator] computes the first block of - [locator] that is known to be a valid block. It also computes the - 'prefix' of [locator] with end at the first valid block. The - function returns [None] when no block in the locator are known or - if the first known block is invalid. *) + (** [known_ancestor chain_state locator] computes the first block of + [locator] that is known to be a valid block. It also computes the + 'prefix' of [locator] with end at the first valid block. The + function returns [None] when no block in the locator are known or + if the first known block is invalid. *) + + val get_rpc_directory: block -> block RPC_directory.t option Lwt.t + val set_rpc_directory: block -> block RPC_directory.t -> unit Lwt.t end diff --git a/src/lib_shell/worker_directory.ml b/src/lib_shell/worker_directory.ml new file mode 100644 index 000000000..94c32a287 --- /dev/null +++ b/src/lib_shell/worker_directory.ml @@ -0,0 +1,88 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let rpc_directory = + + let dir : unit RPC_directory.t ref = ref RPC_directory.empty in + let register0 s f = + dir := RPC_directory.register !dir s (fun () p q -> f p q) in + let register1 s f = + dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q) in + let register2 s f = + dir := RPC_directory.register !dir s (fun (((), a), b) p q -> f a b p q) in + + (* Workers : Prevalidators *) + + register0 Worker_services.Prevalidators.S.list begin fun () () -> + return + (List.map + (fun (id, w) -> (id, Prevalidator.status w)) + (Prevalidator.running_workers ())) + end ; + + register1 Worker_services.Prevalidators.S.state begin fun chain_id () () -> + let w = List.assoc chain_id (Prevalidator.running_workers ()) in + return + { Worker_types.status = Prevalidator.status w ; + pending_requests = Prevalidator.pending_requests w ; + backlog = Prevalidator.last_events w ; + current_request = Prevalidator.current_request w } + end ; + + (* Workers : Block_validator *) + + register0 Worker_services.Block_validator.S.state begin fun () () -> + let w = Block_validator.running_worker () in + return + { Worker_types.status = Block_validator.status w ; + pending_requests = Block_validator.pending_requests w ; + backlog = Block_validator.last_events w ; + current_request = Block_validator.current_request w } + end ; + + (* Workers : Peer validators *) + + register1 Worker_services.Peer_validators.S.list begin fun chain_id () () -> + return + (List.filter_map + (fun ((id, peer_id), w) -> + if Chain_id.equal id chain_id then + Some (peer_id, Peer_validator.status w) + else None) + (Peer_validator.running_workers ())) + end ; + + register2 Worker_services.Peer_validators.S.state begin fun chain_id peer_id () () -> + let w = List.assoc (chain_id, peer_id) (Peer_validator.running_workers ()) in + return + { Worker_types.status = Peer_validator.status w ; + pending_requests = [] ; + backlog = Peer_validator.last_events w ; + current_request = Peer_validator.current_request w } + end ; + + (* Workers : Net validators *) + + register0 Worker_services.Chain_validators.S.list begin fun () () -> + return + (List.map + (fun (id, w) -> (id, Chain_validator.status w)) + (Chain_validator.running_workers ())) + end ; + + register1 Worker_services.Chain_validators.S.state begin fun chain_id () () -> + let w = List.assoc chain_id (Chain_validator.running_workers ()) in + return + { Worker_types.status = Chain_validator.status w ; + pending_requests = Chain_validator.pending_requests w ; + backlog = Chain_validator.last_events w ; + current_request = Chain_validator.current_request w } + end ; + + !dir diff --git a/src/lib_shell/node_rpc.mli b/src/lib_shell/worker_directory.mli similarity index 91% rename from src/lib_shell/node_rpc.mli rename to src/lib_shell/worker_directory.mli index 922c70190..c77d4e66c 100644 --- a/src/lib_shell/node_rpc.mli +++ b/src/lib_shell/worker_directory.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val build_rpc_directory: Node.t -> unit RPC_directory.t +val rpc_directory: unit RPC_directory.t diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index 3817870ab..2da3834b1 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -12,7 +12,6 @@ open Data_encoding type block = [ | `Genesis | `Head of int - | `Test_head of int | `Hash of Block_hash.t * int ] @@ -21,9 +20,7 @@ let parse_block s = match String.split '~' s with | ["genesis"] -> Ok `Genesis | ["head"] -> Ok (`Head 0) - | ["test_head"] -> Ok (`Test_head 0) | ["head"; n] -> Ok (`Head (int_of_string n)) - | ["test_head"; n] -> Ok (`Test_head (int_of_string n)) | [h] -> Ok (`Hash (Block_hash.of_b58check_exn h, 0)) | [h ; n] -> Ok (`Hash (Block_hash.of_b58check_exn h, int_of_string n)) | _ -> raise Exit @@ -33,495 +30,843 @@ let to_string = function | `Genesis -> "genesis" | `Head 0 -> "head" | `Head n -> Printf.sprintf "head~%d" n - | `Test_head 0 -> "test_head" - | `Test_head n -> Printf.sprintf "test_head~%d" n | `Hash (h, 0) -> Block_hash.to_b58check h | `Hash (h, n) -> Printf.sprintf "%s~%d" (Block_hash.to_b58check h) n -type block_info = { - hash: Block_hash.t ; - chain_id: Chain_id.t ; - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - validation_passes: int ; (* uint8 *) - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - context: Context_hash.t ; - protocol_data: MBytes.t ; - operations: (Operation_hash.t * Operation.t) list list option ; - protocol: Protocol_hash.t ; - test_chain: Test_chain_status.t ; +let blocks_arg = + let name = "block_id" in + let descr = + "A block identifier. This is either a block hash in Base58Check notation \ + or a one the predefined aliases: 'genesis', 'head'. \ + One might alse use 'head~N' or '<hash>~N' where N is an integer to \ + denotes the Nth predecessors of the designated block." in + let construct = to_string in + let destruct = parse_block in + RPC_arg.make ~name ~descr ~construct ~destruct () + +type prefix = (unit * Chain_services.chain) * block +let path = RPC_path.(Chain_services.S.Blocks.path /: blocks_arg) + +type operation_list_quota = { + max_size: int ; + max_op: int option ; } -let pp_block_info ppf - { hash ; chain_id ; level ; - proto_level ; predecessor ; timestamp ; - operations_hash ; fitness ; protocol_data ; - operations ; protocol ; test_chain } = - Format.fprintf ppf - "@[<v 2>Hash: %a\ - @ Test chain: %a\ - @ Level: %ld\ - @ Proto_level: %d\ - @ Predecessor: %a\ - @ Protocol: %a\ - @ Net id: %a\ - @ Timestamp: %a\ - @ @[<hov 2>Fitness: %a@]\ - @ Operations hash: %a\ - @ @[<hov 2>Operations:@ %a@]\ - @ @[<hov 2>Protocol data:@ %a@]@]" - Block_hash.pp hash - Test_chain_status.pp test_chain - level - proto_level - Block_hash.pp predecessor - Protocol_hash.pp protocol - Chain_id.pp chain_id - Time.pp_hum timestamp - Fitness.pp fitness - Operation_list_list_hash.pp operations_hash - (fun ppf -> function - | None -> Format.fprintf ppf "None" - | Some operations -> - Format.pp_print_list ~pp_sep:Format.pp_print_newline - (Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (oph, _) -> Operation_hash.pp ppf oph)) - ppf operations) - operations - Hex.pp (MBytes.to_hex protocol_data) - -let block_info_encoding = - let operation_encoding = - merge_objs - (obj1 (req "hash" Operation_hash.encoding)) - Operation.encoding in +let operation_list_quota_encoding = conv - (fun { hash ; chain_id ; level ; proto_level ; predecessor ; - fitness ; timestamp ; protocol ; - validation_passes ; operations_hash ; context ; protocol_data ; - operations ; test_chain } -> - ((hash, chain_id, operations, protocol, test_chain), - { Block_header.shell = - { level ; proto_level ; predecessor ; - timestamp ; validation_passes ; operations_hash ; fitness ; - context } ; - protocol_data })) - (fun ((hash, chain_id, operations, protocol, test_chain), - { Block_header.shell = - { level ; proto_level ; predecessor ; - timestamp ; validation_passes ; operations_hash ; fitness ; - context } ; - protocol_data }) -> - { hash ; chain_id ; level ; proto_level ; predecessor ; - fitness ; timestamp ; protocol ; - validation_passes ; operations_hash ; context ; protocol_data ; - operations ; test_chain }) - (dynamic_size - (merge_objs - (obj5 - (req "hash" Block_hash.encoding) - (req "chain_id" Chain_id.encoding) - (opt "operations" (dynamic_size (list (dynamic_size (list (dynamic_size operation_encoding)))))) - (req "protocol" Protocol_hash.encoding) - (dft "test_chain" - Test_chain_status.encoding Not_running)) - Block_header.encoding)) + (fun { max_size ; max_op } -> (max_size, max_op)) + (fun (max_size, max_op) -> { max_size ; max_op }) + (obj2 + (req "max_size" int31) + (opt "max_op" int31)) -type preapply_result = { - shell_header: Block_header.shell_header ; - operations: error Preapply_result.t list ; -} - -let preapply_result_encoding = - (conv - (fun { shell_header ; operations } -> - (shell_header, operations)) - (fun (shell_header, operations) -> - { shell_header ; operations }) - (obj2 - (req "shell_header" Block_header.shell_header_encoding) - (req "operations" - (list (Preapply_result.encoding RPC_error.encoding))))) - -type raw_context_result = +type raw_context = | Key of MBytes.t - | Dir of (string * raw_context_result) list + | Dir of (string * raw_context) list | Cut -let raw_context_result_pp t = - let open Format in - let rec loop ppf = function - | Cut -> fprintf ppf "..." - | Key v -> let `Hex s = MBytes.to_hex v in fprintf ppf "%S" s - | Dir l -> - fprintf ppf "{@[<v 1>@,%a@]@,}" - (pp_print_list ~pp_sep:Format.pp_print_cut - (fun ppf (s,t) -> fprintf ppf "%s : %a" s loop t)) l - in - asprintf "%a" loop t +let rec pp_raw_context ppf = function + | Cut -> Format.fprintf ppf "..." + | Key v -> Hex.pp ppf (MBytes.to_hex v) + | Dir l -> + Format.fprintf ppf "{@[<v 1>@,%a@]@,}" + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (s, t) -> Format.fprintf ppf "%s : %a" s pp_raw_context t)) + l -module S = struct +let raw_context_encoding = + mu "raw_context" + (fun encoding -> + union [ + case (Tag 0) bytes + (function Key k -> Some k | _ -> None) + (fun k -> Key k) ; + case (Tag 1) (assoc encoding) + (function Dir k -> Some k | _ -> None) + (fun k -> Dir k) ; + case (Tag 2) null + (function Cut -> Some () | _ -> None) + (fun () -> Cut) ; + ]) - let blocks_arg = - let name = "block_id" in - let descr = - "A block identifier. This is either a block hash in hexadecimal \ - notation or a one the predefined aliases: \ - 'genesis', 'head', \ - or 'test_head'. One might alse use 'head~N' - to 'test_head~N', where N is an integer to denotes the Nth predecessors - of 'head' or 'test_head'." in - let construct = to_string in - let destruct = parse_block in - RPC_arg.make ~name ~descr ~construct ~destruct () +type error += + | Invalid_depth_arg of (string list * int) + | Missing_key of string list - let block_path : (unit, unit * block) RPC_path.path = - RPC_path.(root / "blocks" /: blocks_arg) - let proto_path () = - RPC_path.(open_root / "blocks" /: blocks_arg / "proto") +let () = + register_error_kind + `Permanent + ~id:"raw_context.missing_key" + ~title:"...FIXME..." + ~description:"...FIXME..." + ~pp:(fun ppf path -> + Format.fprintf ppf "Missing key: %s" (String.concat "/" path)) + Data_encoding.(obj1 (req "path" (list string))) + (function Missing_key path -> Some path | _ -> None) + (fun path -> Missing_key path) +module type PROTO = sig + val hash: Protocol_hash.t + type block_header_data + val block_header_data_encoding: block_header_data Data_encoding.t + type block_header_metadata + val block_header_metadata_encoding: + block_header_metadata Data_encoding.t + type operation_data + val operation_data_encoding: operation_data Data_encoding.t + type operation_metadata + val operation_metadata_encoding: operation_metadata Data_encoding.t + type operation = { + shell: Operation.shell_header ; + protocol_data: operation_data ; + } +end - let info = - RPC_service.post_service - ~description:"All the information about a block." - ~query: RPC_query.empty - ~input: (obj1 (dft "operations" bool true)) - ~output: block_info_encoding - block_path +module Make(Proto : PROTO)(Next_proto : PROTO) = struct - let chain_id = - RPC_service.post_service - ~description:"Returns the chain in which the block belongs." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "chain_id" Chain_id.encoding)) - RPC_path.(block_path / "chain_id") + let protocol_hash = Protocol_hash.to_b58check Proto.hash + let next_protocol_hash = Protocol_hash.to_b58check Next_proto.hash - let level = - RPC_service.post_service - ~description:"Returns the block's level." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "level" int32)) - RPC_path.(block_path / "level") - - let predecessor = - RPC_service.post_service - ~description:"Returns the previous block's id." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "predecessor" Block_hash.encoding)) - RPC_path.(block_path / "predecessor") - - let predecessors = - RPC_service.post_service - ~description: - "...." - ~query: RPC_query.empty - ~input: (obj1 (req "length" Data_encoding.uint16)) - ~output: (obj1 (req "blocks" (list Block_hash.encoding))) - RPC_path.(block_path / "predecessors") - - let hash = - RPC_service.post_service - ~description:"Returns the block's id." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "hash" Block_hash.encoding)) - RPC_path.(block_path / "hash") - - let fitness = - RPC_service.post_service - ~description:"Returns the block's fitness." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "fitness" Fitness.encoding)) - RPC_path.(block_path / "fitness") - - let context = - RPC_service.post_service - ~description:"Returns the hash of the resulting context." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "context" Context_hash.encoding)) - RPC_path.(block_path / "context") - - let raw_context_args : string RPC_arg.t = - let name = "context_path" in - let descr = "A path inside the context" in - let construct = fun s -> s in - let destruct = fun s -> Ok s in - RPC_arg.make ~name ~descr ~construct ~destruct () - - let raw_context_result_encoding : raw_context_result Data_encoding.t = - let open Data_encoding in - obj1 (req "content" - (mu "context_tree" (fun raw_context_result_encoding -> - union [ - case (Tag 0) ~name:"Key" bytes - (function Key k -> Some k | _ -> None) - (fun k -> Key k) ; - case (Tag 1) ~name:"Dir" (assoc raw_context_result_encoding) - (function Dir k -> Some k | _ -> None) - (fun k -> Dir k) ; - case (Tag 2) ~name:"Cut" null - (function Cut -> Some () | _ -> None) - (fun () -> Cut) ; - ]))) - - (* The depth query argument for the [raw_context] service, - default value is 1. *) - let depth_query : < depth: int > RPC_query.t = - let open RPC_query in - query (fun depth -> object - method depth = depth - end) - |+ field "depth" RPC_arg.int 1 (fun t -> t#depth) - |> seal - - let raw_context = - RPC_service.post_service - ~description:"Returns the raw context." - ~query: depth_query - ~input: empty - ~output: raw_context_result_encoding - RPC_path.(block_path / "raw_context" /:* raw_context_args) - - let timestamp = - RPC_service.post_service - ~description:"Returns the block's timestamp." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "timestamp" Time.encoding)) - RPC_path.(block_path / "timestamp") - - type operations_param = { - contents: bool ; + type raw_block_header = { + shell: Block_header.shell_header ; + protocol_data: Proto.block_header_data ; } - let operations_param_encoding = + let raw_block_header_encoding = + conv + (fun { shell ; protocol_data } -> (shell, protocol_data)) + (fun (shell, protocol_data) -> { shell ; protocol_data } ) + (merge_objs + Block_header.shell_header_encoding + Proto.block_header_data_encoding) + + type block_header = { + chain_id: Chain_id.t ; + hash: Block_hash.t ; + shell: Block_header.shell_header ; + protocol_data: Proto.block_header_data ; + } + + let block_header_encoding = + conv + (fun { chain_id ; hash ; shell ; protocol_data } -> + (((), chain_id, hash), { shell ; protocol_data })) + (fun (((), chain_id, hash), { shell ; protocol_data }) -> + { chain_id ; hash ; shell ; protocol_data } ) + (merge_objs + (obj3 + (req "protocol" (constant protocol_hash)) + (req "chain_id" Chain_id.encoding) + (req "hash" Block_hash.encoding)) + raw_block_header_encoding) + + type block_metadata = { + protocol_data: Proto.block_header_metadata ; + test_chain_status: Test_chain_status.t ; + (* for the next block: *) + max_operations_ttl: int ; + max_operation_data_length: int ; + max_block_header_length: int ; + operation_list_quota: operation_list_quota list ; + } + + let block_metadata_encoding = + conv + (fun { protocol_data ; test_chain_status ; max_operations_ttl ; + max_operation_data_length ; max_block_header_length ; + operation_list_quota } -> + (((), (), test_chain_status, + max_operations_ttl, max_operation_data_length, + max_block_header_length, operation_list_quota), + protocol_data)) + (fun (((), (), test_chain_status, + max_operations_ttl, max_operation_data_length, + max_block_header_length, operation_list_quota), + protocol_data) -> + { protocol_data ; test_chain_status ; max_operations_ttl ; + max_operation_data_length ; max_block_header_length ; + operation_list_quota }) + (merge_objs + (obj7 + (req "protocol" (constant protocol_hash)) + (req "next_protocol" (constant next_protocol_hash)) + (req "test_chain_status" Test_chain_status.encoding) + (req "max_operations_ttl" int31) + (req "max_operation_data_length" int31) + (req "max_block_header_length" int31) + (req "max_operation_list_length" + (dynamic_size (list operation_list_quota_encoding)))) + Proto.block_header_metadata_encoding) + + let next_operation_encoding = let open Data_encoding in def "next_operation" @@ conv - (fun { contents } -> (contents)) - (fun (contents) -> { contents }) - (obj1 (dft "contents" bool false)) + (fun Next_proto.{ shell ; protocol_data } -> ((), (shell, protocol_data))) + (fun ((), (shell, protocol_data)) -> { shell ; protocol_data } ) + (merge_objs + (obj1 (req "protocol" (constant next_protocol_hash))) + (merge_objs + (dynamic_size Operation.shell_header_encoding) + (dynamic_size Next_proto.operation_data_encoding))) - let operations = - RPC_service.post_service - ~description:"List the block operations." - ~query: RPC_query.empty - ~input: operations_param_encoding - ~output: - (obj1 - (req "operations" - (list - (list - (obj2 - (req "hash" Operation_hash.encoding) - (opt "contents" - (dynamic_size Operation.encoding))))))) - RPC_path.(block_path / "operations") - - let protocol = - RPC_service.post_service - ~description:"List the block protocol." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "protocol" Protocol_hash.encoding)) - RPC_path.(block_path / "protocol") - - let test_chain = - RPC_service.post_service - ~description:"Returns the status of the associated test chain." - ~query: RPC_query.empty - ~input: empty - ~output: Test_chain_status.encoding - RPC_path.(block_path / "test_chain") - - type preapply_param = { - timestamp: Time.t ; - protocol_data: MBytes.t ; - operations: Operation.t list list ; - sort_operations: bool ; + type operation = { + chain_id: Chain_id.t ; + hash: Operation_hash.t ; + shell: Operation.shell_header ; + protocol_data: Proto.operation_data ; + metadata: Proto.operation_metadata ; } - let preapply_param_encoding = - (conv - (fun { timestamp ; protocol_data ; operations ; sort_operations } -> - (timestamp, protocol_data, operations, sort_operations)) - (fun (timestamp, protocol_data, operations, sort_operations) -> - { timestamp ; protocol_data ; operations ; sort_operations }) - (obj4 - (req "timestamp" Time.encoding) - (req "protocol_data" bytes) - (req "operations" (list (dynamic_size (list (dynamic_size Operation.encoding))))) - (dft "sort_operations" bool false))) - - let preapply = - RPC_service.post_service - ~description: - "Simulate the validation of a block that would contain \ - the given operations and return the resulting fitness." - ~query: RPC_query.empty - ~input: preapply_param_encoding - ~output: preapply_result_encoding - RPC_path.(block_path / "preapply") - - let complete = - let prefix_arg = - let destruct s = Ok s - and construct s = s in - RPC_arg.make ~name:"prefix" ~destruct ~construct () in - RPC_service.post_service - ~description: "Try to complete a prefix of a Base58Check-encoded data. \ - This RPC is actually able to complete hashes of \ - block, operations, public_keys and contracts." - ~query: RPC_query.empty - ~input: empty - ~output: (list string) - RPC_path.(block_path / "complete" /: prefix_arg ) - - type list_param = { - include_ops: bool ; - length: int option ; - heads: Block_hash.t list option ; - monitor: bool option ; - delay: int option ; - min_date: Time.t option; - min_heads: int option; - } - let list_param_encoding = + let operation_encoding = + let open Data_encoding in conv - (fun { include_ops ; length ; heads ; monitor ; - delay ; min_date ; min_heads } -> - (include_ops, length, heads, monitor, delay, min_date, min_heads)) - (fun (include_ops, length, heads, monitor, - delay, min_date, min_heads) -> - { include_ops ; length ; heads ; monitor ; - delay ; min_date ; min_heads }) - (obj7 - (dft "include_ops" - ~description: - "Whether the resulting block informations should include the \ - list of operations' hashes. Default false." - bool false) - (opt "length" - ~description: - "The requested number of predecessors to returns (per \ - requested head)." - int31) - (opt "heads" - ~description: - "An empty argument requests blocks from the current heads. \ - A non empty list allow to request specific fragment \ - of the chain." - (list Block_hash.encoding)) - (opt "monitor" - ~description: - "When true, the socket is \"kept alive\" after the first \ - answer and new heads are streamed when discovered." - bool) - (opt "delay" - ~description: - "By default only the blocks that were validated by the node \ - are considered. \ - When this optional argument is 0, only blocks with a \ - timestamp in the past are considered. Other values allows to \ - adjust the current time." - int31) - (opt "min_date" - ~description: "When `min_date` is provided, heads with a \ - timestamp before `min_date` are filtered ouf" - Time.encoding) - (opt "min_heads" - ~description:"When `min_date` is provided, returns at least \ - `min_heads` even when their timestamp is before \ - `min_date`." - int31)) + (fun { chain_id ; hash ; shell ; protocol_data ; metadata } -> + (((), chain_id, hash), ((shell, protocol_data), metadata))) + (fun (((), chain_id, hash), ((shell, protocol_data), metadata)) -> + { chain_id ; hash ; shell ; protocol_data ; metadata } ) + (merge_objs + (obj3 + (req "protocol" (constant protocol_hash)) + (req "chain_id" Chain_id.encoding) + (req "hash" Operation_hash.encoding)) + (merge_objs + (dynamic_size + (merge_objs + Operation.shell_header_encoding + Proto.operation_data_encoding)) + (dynamic_size Proto.operation_metadata_encoding))) - let list = - RPC_service.post_service - ~description: - "Lists known heads of the blockchain sorted with decreasing fitness. \ - Optional arguments allows to returns the list of predecessors for \ - known heads or the list of predecessors for a given list of blocks." - ~query: RPC_query.empty - ~input: list_param_encoding - ~output: (obj1 (req "blocks" (list (list block_info_encoding)))) - RPC_path.(root / "blocks") + type block_info = { + chain_id: Chain_id.t ; + hash: Block_hash.t ; + header: raw_block_header ; + metadata: block_metadata ; + operations: operation list list ; + } - let list_invalid = - RPC_service.post_service - ~description: - "Lists blocks that have been declared invalid along with the errors\ - that led to them being declared invalid" - ~query: RPC_query.empty - ~input:empty - ~output:(Data_encoding.list - (obj3 - (req "block" Block_hash.encoding) - (req "level" int32) - (req "errors" RPC_error.encoding))) - RPC_path.(root / "invalid_blocks") + let block_info_encoding = + conv + (fun { chain_id ; hash ; header ; metadata ; operations } -> + ((((), chain_id, hash), (header, metadata)), operations)) + (fun ((((), chain_id, hash), (header, metadata)), operations) -> + { chain_id ; hash ; header ; metadata ; operations }) + (merge_objs + (merge_objs + (obj3 + (req "protocol" (constant protocol_hash)) + (req "chain_id" Chain_id.encoding) + (req "hash" Block_hash.encoding)) + (merge_objs + (dynamic_size raw_block_header_encoding) + (dynamic_size block_metadata_encoding))) + (obj1 (req "operations" + (list (dynamic_size (list operation_encoding)))))) - let unmark_invalid = - RPC_service.post_service - ~description: - "Unmark an invalid block" - ~query: RPC_query.empty - ~input: Data_encoding.empty - ~output: Data_encoding.empty - RPC_path.(root / "invalid_blocks" /: Block_hash.rpc_arg / "unmark" ) + module S = struct + + let path : prefix RPC_path.context = RPC_path.open_root + + let hash = + RPC_service.get_service + ~description:"The block's hash, its unique identifier." + ~query: RPC_query.empty + ~output: Block_hash.encoding + RPC_path.(path / "hash") + + module Header = struct + + let path = RPC_path.(path / "header") + + let header = + RPC_service.get_service + ~description:"The whole block header." + ~query: RPC_query.empty + ~output: block_header_encoding + path + + let shell_header = + RPC_service.get_service + ~description:"The shell-specific fragment of the block header." + ~query: RPC_query.empty + ~output: Block_header.shell_header_encoding + RPC_path.(path / "shell") + + let protocol_data = + RPC_service.get_service + ~description:"The version-specific fragment of the block header." + ~query: RPC_query.empty + ~output: + (conv + (fun h -> ((), h)) (fun ((), h) -> h) + (merge_objs + (obj1 (req "protocol" (constant protocol_hash))) + Proto.block_header_data_encoding)) + RPC_path.(path / "protocol_data") + + module Shell = struct + + let path = RPC_path.(path / "shell") + + let level = + RPC_service.get_service + ~description:"The block's level." + ~query: RPC_query.empty + ~output: int32 + RPC_path.(path / "level") + + let protocol_level = + RPC_service.get_service + ~description:"The block's protocol level (modulo 256)." + ~query: RPC_query.empty + ~output: uint8 + RPC_path.(path / "proto_level") + + let predecessor = + RPC_service.get_service + ~description:"The previous block's id." + ~query: RPC_query.empty + ~output: Block_hash.encoding + RPC_path.(path / "predecessor") + + let timestamp = + RPC_service.get_service + ~description:"The block's timestamp." + ~query: RPC_query.empty + ~output: Time.encoding + RPC_path.(path / "timestamp") + + let validation_passes = + RPC_service.get_service + ~description:"The number of validation passes for the block." + ~query: RPC_query.empty + ~output: uint8 + RPC_path.(path / "validation_passes") + + let operations_hash = + RPC_service.get_service + ~description:"The hash of merkle tree of the operations included in the block." + ~query: RPC_query.empty + ~output: Operation_list_list_hash.encoding + RPC_path.(path / "operations_hash") + + let fitness = + RPC_service.get_service + ~description:"The block's fitness." + ~query: RPC_query.empty + ~output: Fitness.encoding + RPC_path.(path / "fitness") + + let context_hash = + RPC_service.get_service + ~description:"The hash of the resulting validation context." + ~query: RPC_query.empty + ~output: Context_hash.encoding + RPC_path.(path / "context_hash") + + end + + end + + module Metadata = struct + + let path = RPC_path.(path / "metadata") + + let metadata = + RPC_service.get_service + ~description:"All the metadata associated to the block." + ~query: RPC_query.empty + ~output: block_metadata_encoding + path + + let protocol_data = + RPC_service.get_service + ~description:"The protocol-specific metadata associated to the block." + ~query: RPC_query.empty + ~output: + (conv + (fun h -> ((), h)) (fun ((), h) -> h) + (merge_objs + (obj1 (req "protocol" (constant protocol_hash))) + Proto.block_header_metadata_encoding)) + RPC_path.(path / "protocol_data") + + let protocol_hash = + RPC_service.get_service + ~description:"The protocol used to bake this block." + ~query: RPC_query.empty + ~output: Protocol_hash.encoding + RPC_path.(path / "protocol_hash") + + let next_protocol_hash = + RPC_service.get_service + ~description:"The protocol required to bake the next block." + ~query: RPC_query.empty + ~output: Protocol_hash.encoding + RPC_path.(path / "next_protocol_hash") + + let test_chain_status = + RPC_service.get_service + ~description:"The status of the associated test chain." + ~query: RPC_query.empty + ~output: Test_chain_status.encoding + RPC_path.(path / "test_chain_status") + + let max_operations_ttl = + RPC_service.get_service + ~description:"... FIXME ..." + ~query: RPC_query.empty + ~output: int31 + RPC_path.(path / "max_operations_ttl") + + let max_operation_data_length = + RPC_service.get_service + ~description:"... FIXME ..." + ~query: RPC_query.empty + ~output: int31 + RPC_path.(path / "max_operation_data_length") + + let max_block_header_length = + RPC_service.get_service + ~description:"... FIXME ..." + ~query: RPC_query.empty + ~output: int31 + RPC_path.(path / "max_block_header_length") + + let operation_list_quota = + RPC_service.get_service + ~description:"... FIXME ..." + ~query: RPC_query.empty + ~output: (list operation_list_quota_encoding) + RPC_path.(path / "operation_list_quota") + + end + + module Operation = struct + + let path = RPC_path.(path / "operations") + + let operations = + RPC_service.get_service + ~description:"All the operations included in the block." + ~query: RPC_query.empty + ~output: (list (dynamic_size (list operation_encoding))) + path + + let list_arg = + let name = "list_offset" in + let descr = + "..." in + let construct = string_of_int in + let destruct s = + try Ok (int_of_string s) + with _ -> Error (Format.sprintf "Invalid list offset (%s)" s) in + RPC_arg.make ~name ~descr ~construct ~destruct () + + let offset_arg = + let name = "operation_offset" in + let descr = + "..." in + let construct = string_of_int in + let destruct s = + try Ok (int_of_string s) + with _ -> Error (Format.sprintf "Invalid operation offset (%s)" s) in + RPC_arg.make ~name ~descr ~construct ~destruct () + + let operations_in_pass = + RPC_service.get_service + ~description: + "All the operations included in `n-th` validation pass of the block." + ~query: RPC_query.empty + ~output: (list operation_encoding) + RPC_path.(path /: list_arg) + + let operation = + RPC_service.get_service + ~description: + "The `m-th` operation in the `n-th` validation pass of the block." + ~query: RPC_query.empty + ~output: operation_encoding + RPC_path.(path /: list_arg /: offset_arg) + + end + + module Operation_hash = struct + + let path = RPC_path.(path / "operation_hashes") + + let operation_hashes = + RPC_service.get_service + ~description:"The hashes of all the operations included in the block." + ~query: RPC_query.empty + ~output: (list (list Operation_hash.encoding)) + path + + let operation_hashes_in_pass = + RPC_service.get_service + ~description: + "All the operations included in `n-th` validation pass of the block." + ~query: RPC_query.empty + ~output: (list Operation_hash.encoding) + RPC_path.(path /: Operation.list_arg) + + let operation_hash = + RPC_service.get_service + ~description: + "The hash of then `m-th` operation in the `n-th` validation pass of the block." + ~query: RPC_query.empty + ~output: Operation_hash.encoding + RPC_path.(path /: Operation.list_arg /: Operation.offset_arg) + end + + module Helpers = struct + + let path = RPC_path.(path / "helpers") + + let preapply_result_encoding = + obj2 + (req "shell_header" Block_header.shell_header_encoding) + (req "operations" + (list (Preapply_result.encoding RPC_error.encoding))) + + type preapply_param = { + timestamp: Time.t ; + protocol_data: Next_proto.block_header_data ; + operations: Next_proto.operation list list ; + } + + let preapply_param_encoding = + (conv + (fun { timestamp ; protocol_data ; operations } -> + (timestamp, protocol_data, operations)) + (fun (timestamp, protocol_data, operations) -> + { timestamp ; protocol_data ; operations }) + (obj3 + (req "timestamp" Time.encoding) + (req "protocol_data" + (conv + (fun h -> ((), h)) (fun ((), h) -> h) + (merge_objs + (obj1 (req "protocol" (constant next_protocol_hash))) + (dynamic_size Next_proto.block_header_data_encoding)))) + (req "operations" + (list (dynamic_size (list next_operation_encoding)))))) + + let preapply_query : < sort_operations: bool > RPC_query.t = + let open RPC_query in + query (fun sort -> object + method sort_operations = sort + end) + |+ flag "sort" (fun t -> t#sort_operations) + |> seal + + let preapply = + RPC_service.post_service + ~description: + "Simulate the validation of a block that would contain \ + the given operations and return the resulting fitness." + ~query: preapply_query + ~input: preapply_param_encoding + ~output: preapply_result_encoding + RPC_path.(path / "preapply") + + let complete = + let prefix_arg = + let destruct s = Ok s + and construct s = s in + RPC_arg.make ~name:"prefix" ~destruct ~construct () in + RPC_service.get_service + ~description: "Try to complete a prefix of a Base58Check-encoded data. \ + This RPC is actually able to complete hashes of \ + block, operations, public_keys and contracts." + ~query: RPC_query.empty + ~output: (list string) + RPC_path.(path / "complete" /: prefix_arg ) + + end + + module Context = struct + + let path = RPC_path.(path / "context") + + module Raw = struct + + let path = RPC_path.(path / "raw") + + let context_path_arg : string RPC_arg.t = + let name = "context_path" in + let descr = "A path inside the context" in + let construct = fun s -> s in + let destruct = fun s -> Ok s in + RPC_arg.make ~name ~descr ~construct ~destruct () + + let raw_context_query : < depth: int option > RPC_query.t = + let open RPC_query in + query (fun depth -> object + method depth = depth + end) + |+ opt_field "depth" RPC_arg.int (fun t -> t#depth) + |> seal + + let read = + RPC_service.get_service + ~description:"Returns the raw context." + ~query: raw_context_query + ~output: raw_context_encoding + RPC_path.(path /:* context_path_arg) + + end + + end + + let info = + RPC_service.get_service + ~description:"All the information about a block." + ~query: RPC_query.empty + ~output: block_info_encoding + path + + end + + let path = RPC_path.prefix Chain_services.path path + + let make_call0 s ctxt a b q p = + let s = RPC_service.prefix path s in + RPC_context.make_call2 s ctxt a b q p + + let make_call1 s ctxt a b c q p = + let s = RPC_service.prefix path s in + RPC_context.make_call3 s ctxt a b c q p + + let make_call2 s ctxt a b c d q p = + let s = RPC_service.prefix path s in + RPC_context.make_call s ctxt (((((), a), b), c), d) q p + + let hash ctxt = + let f = make_call0 S.hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + match block with + | `Hash (h, 0) -> return h + | _ -> f chain block () () + + module Header = struct + + module S = S.Header + + let header ctxt = + let f = make_call0 S.header ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + let shell_header ctxt = + let f = make_call0 S.shell_header ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + let protocol_data ctxt = + let f = make_call0 S.protocol_data ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + module Shell = struct + + module S = S.Shell + + let level ctxt = + let f = make_call0 S.level ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let protocol_level ctxt = + let f = make_call0 S.protocol_level ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let predecessor ctxt = + let f = make_call0 S.predecessor ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let timestamp ctxt = + let f = make_call0 S.timestamp ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let validation_passes ctxt = + let f = make_call0 S.validation_passes ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let operations_hash ctxt = + let f = make_call0 S.operations_hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let fitness ctxt = + let f = make_call0 S.fitness ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let context_hash ctxt = + let f = make_call0 S.context_hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + end + + end + + module Metadata = struct + + module S = S.Metadata + + let metadata ctxt = + let f = make_call0 S.metadata ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let protocol_data ctxt = + let f = make_call0 S.protocol_data ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let protocol_hash ctxt = + let f = make_call0 S.protocol_hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let next_protocol_hash ctxt = + let f = make_call0 S.next_protocol_hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let test_chain_status ctxt = + let f = make_call0 S.test_chain_status ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let max_operations_ttl ctxt = + let f = make_call0 S.max_operations_ttl ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let max_operation_data_length ctxt = + let f = make_call0 S.max_operation_data_length ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let max_block_header_length ctxt = + let f = make_call0 S.max_block_header_length ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let max_operation_list_length ctxt = + let f = make_call0 S.operation_list_quota ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + end + + module Operation = struct + + module S = S.Operation + + let operations ctxt = + let f = make_call0 S.operations ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let operations_in_pass ctxt = + let f = make_call1 S.operations_in_pass ctxt in + fun ?(chain = `Main) ?(block = `Head 0) n -> + f chain block n () () + + let operation ctxt = + let f = make_call2 S.operation ctxt in + fun ?(chain = `Main) ?(block = `Head 0) n m -> + f chain block n m () () + + end + + module Operation_hash = struct + + module S = S.Operation_hash + + let operation_hashes ctxt = + let f = make_call0 S.operation_hashes ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () + + let operation_hashes_in_pass ctxt = + let f = make_call1 S.operation_hashes_in_pass ctxt in + fun ?(chain = `Main) ?(block = `Head 0) n -> + f chain block n () () + + let operation_hash ctxt = + let f = make_call2 S.operation_hash ctxt in + fun ?(chain = `Main) ?(block = `Head 0) n m -> + f chain block n m () () + + end + + module Context = struct + + module S = S.Context + + module Raw = struct + + module S = S.Raw + + let read ctxt = + let f = make_call1 S.read ctxt in + fun ?(chain = `Main) ?(block = `Head 0) ?depth path -> + f chain block path + (object method depth = depth end) () + + end + + end + + module Helpers = struct + + module S = S.Helpers + + let preapply ctxt = + let f = make_call0 S.preapply ctxt in + fun + ?(chain = `Main) ?(block = `Head 0) + ?(sort = false) ~timestamp ~protocol_data operations -> + f chain block + (object method sort_operations = sort end) + { timestamp ; protocol_data ; operations } + + let complete ctxt = + let f = make_call1 S.complete ctxt in + fun ?(chain = `Main) ?(block = `Head 0) s -> + f chain block s () () + + end + + let info ctxt = + let f = make_call0 S.info ctxt in + fun ?(chain = `Main) ?(block = `Head 0) () -> + f chain block () () end -open RPC_context +module Fake_protocol = struct + let hash = Protocol_hash.zero + type block_header_data = unit + let block_header_data_encoding = Data_encoding.empty + type block_header_metadata = unit + let block_header_metadata_encoding = Data_encoding.empty + type operation_data = unit + let operation_data_encoding = Data_encoding.empty + type operation_metadata = unit + let operation_metadata_encoding = Data_encoding.empty + type operation = { + shell: Operation.shell_header ; + protocol_data: operation_data ; + } +end -let chain_id ctxt b = make_call1 S.chain_id ctxt b () () -let level ctxt b = make_call1 S.level ctxt b () () -let predecessor ctxt b = make_call1 S.predecessor ctxt b () () -let predecessors ctxt b n = make_call1 S.predecessors ctxt b () n -let hash ctxt b = make_call1 S.hash ctxt b () () -let timestamp ctxt b = make_call1 S.timestamp ctxt b () () -let fitness ctxt b = make_call1 S.fitness ctxt b () () -let operations ctxt ?(contents = false) h = - make_call1 S.operations ctxt h () { contents } -let protocol ctxt b = make_call1 S.protocol ctxt b () () -let test_chain ctxt b = make_call1 S.test_chain ctxt b () () -let info ctxt ?(include_ops = true) h = - make_call1 S.info ctxt h () include_ops -let monitor ?(include_ops = false) - ?length ?heads ?delay ?min_date ?min_heads ctxt = - make_streamed_call S.list ctxt () () - { include_ops ; length ; heads ; - monitor = Some true ; delay ; - min_date ; min_heads } -let list ?(include_ops = false) - ?length ?heads ?delay ?min_date ?min_heads ctxt = - make_call S.list ctxt () () - { include_ops ; length ; heads ; - monitor = Some false ; delay ; - min_date ; min_heads } -let complete ctxt b s = - make_call2 S.complete ctxt b s () () -let preapply ctxt h - ?(timestamp = Time.now ()) ?(sort = false) ~protocol_data operations = - make_call1 S.preapply ctxt h () - { timestamp ; protocol_data ; sort_operations = sort ; operations } - -let unmark_invalid ctxt h = - make_call1 S.unmark_invalid ctxt h () () - -let list_invalid ctxt = - make_call S.list_invalid ctxt () () () - -let raw_context ctxt b key depth = - let depth = object - method depth = depth - end - in - make_call2 S.raw_context ctxt b key depth () +module Empty = Make(Fake_protocol)(Fake_protocol) diff --git a/src/lib_shell_services/block_services.mli b/src/lib_shell_services/block_services.mli index e9cd02bab..c3177192e 100644 --- a/src/lib_shell_services/block_services.mli +++ b/src/lib_shell_services/block_services.mli @@ -7,223 +7,433 @@ (* *) (**************************************************************************) +open Chain_services + type block = [ | `Genesis | `Head of int - | `Test_head of int | `Hash of Block_hash.t * int ] val parse_block: string -> (block, string) result val to_string: block -> string -type block_info = { - hash: Block_hash.t ; - chain_id: Chain_id.t ; - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - validation_passes: int ; (* uint8 *) - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - context: Context_hash.t ; - protocol_data: MBytes.t ; - operations: (Operation_hash.t * Operation.t) list list option ; - protocol: Protocol_hash.t ; - test_chain: Test_chain_status.t ; +type prefix = (unit * Chain_services.chain) * block +val path: (Chain_services.prefix, Chain_services.prefix * block) RPC_path.t + +type operation_list_quota = { + max_size: int ; + max_op: int option ; } -val pp_block_info: Format.formatter -> block_info -> unit - -type preapply_result = { - shell_header: Block_header.shell_header ; - operations: error Preapply_result.t list ; -} - -open RPC_context - -val chain_id: - #simple -> block -> Chain_id.t tzresult Lwt.t -val level: - #simple -> block -> Int32.t tzresult Lwt.t -val predecessor: - #simple -> block -> Block_hash.t tzresult Lwt.t -val predecessors: - #simple -> block -> int -> Block_hash.t list tzresult Lwt.t -val hash: - #simple -> block -> Block_hash.t tzresult Lwt.t -val timestamp: - #simple -> block -> Time.t tzresult Lwt.t -val fitness: - #simple -> block -> MBytes.t list tzresult Lwt.t -val operations: - #simple -> ?contents:bool -> - block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t -val protocol: - #simple -> block -> Protocol_hash.t tzresult Lwt.t -val test_chain: - #simple -> block -> Test_chain_status.t tzresult Lwt.t - -val info: - #simple -> - ?include_ops:bool -> block -> block_info tzresult Lwt.t - -val list: - ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> - ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - #simple -> - block_info list list tzresult Lwt.t - -val monitor: - ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> - ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - #streamed -> - (block_info list list Lwt_stream.t * stopper) tzresult Lwt.t - -val preapply: - #simple -> block -> - ?timestamp:Time.t -> - ?sort:bool -> - protocol_data:MBytes.t -> - Operation.t list list -> preapply_result tzresult Lwt.t - -val complete: - #simple -> block -> string -> string list tzresult Lwt.t - -(** Encodes a directory structure returned from a context - query as a tree plus a special case [Cut] used when - the query is limited by a [depth] value. - [Cut] is encoded as [null] in json. *) -type raw_context_result = +type raw_context = | Key of MBytes.t - | Dir of (string * raw_context_result) list + | Dir of (string * raw_context) list | Cut -(** Pretty-printer for raw_context_result *) -val raw_context_result_pp : raw_context_result -> string +val pp_raw_context: Format.formatter -> raw_context -> unit -val raw_context: - #simple -> block -> string list -> int -> raw_context_result tzresult Lwt.t +type error += + | Invalid_depth_arg of (string list * int) + | Missing_key of string list -val unmark_invalid: - #simple -> Block_hash.t -> unit Error_monad.tzresult Lwt.t -val list_invalid: - #simple -> (Block_hash.t * int32 * error list) list tzresult Lwt.t +module type PROTO = sig + val hash: Protocol_hash.t + type block_header_data + val block_header_data_encoding: block_header_data Data_encoding.t + type block_header_metadata + val block_header_metadata_encoding: + block_header_metadata Data_encoding.t + type operation_data + val operation_data_encoding: operation_data Data_encoding.t + type operation_metadata + val operation_metadata_encoding: operation_metadata Data_encoding.t + type operation = { + shell: Operation.shell_header ; + protocol_data: operation_data ; + } +end -(** Signatures of all RPCs. - This module is shared between the Client and the Node. *) -module S : sig +module Make(Proto : PROTO)(Next_proto : PROTO) : sig - val blocks_arg : block RPC_arg.arg + val path: (unit, Chain_services.prefix * block) RPC_path.t + + type raw_block_header = { + shell: Block_header.shell_header ; + protocol_data: Proto.block_header_data ; + } + + type block_header = { + chain_id: Chain_id.t ; + hash: Block_hash.t ; + shell: Block_header.shell_header ; + protocol_data: Proto.block_header_data ; + } + + type block_metadata = { + protocol_data: Proto.block_header_metadata ; + test_chain_status: Test_chain_status.t ; + max_operations_ttl: int ; + max_operation_data_length: int ; + max_block_header_length: int ; + operation_list_quota: operation_list_quota list ; + } + + type operation = { + chain_id: Chain_id.t ; + hash: Operation_hash.t ; + shell: Operation.shell_header ; + protocol_data: Proto.operation_data ; + metadata: Proto.operation_metadata ; + } + + type block_info = { + chain_id: Chain_id.t ; + hash: Block_hash.t ; + header: raw_block_header ; + metadata: block_metadata ; + operations: operation list list ; + } + + open RPC_context val info: - ([ `POST ], unit, - unit * block, unit, bool, - block_info) RPC_service.t - val chain_id: - ([ `POST ], unit, - unit * block, unit, unit, - Chain_id.t) RPC_service.t - val level: - ([ `POST ], unit, - unit * block, unit, unit, - Int32.t) RPC_service.t - val predecessor: - ([ `POST ], unit, - unit * block, unit, unit, - Block_hash.t) RPC_service.t - val predecessors: - ([ `POST ], unit, - unit * block , unit, int, - Block_hash.t list) RPC_service.t + #simple -> ?chain:chain -> ?block:block -> + unit -> block_info tzresult Lwt.t + val hash: - ([ `POST ], unit, - unit * block, unit, unit, - Block_hash.t) RPC_service.t - val timestamp: - ([ `POST ], unit, - unit * block, unit, unit, - Time.t) RPC_service.t - val fitness: - ([ `POST ], unit, - unit * block, unit, unit, - MBytes.t list) RPC_service.t - val context: - ([ `POST ], unit, - unit * block, unit, unit, - Context_hash.t) RPC_service.t + #simple -> ?chain:chain -> ?block:block -> + unit -> Block_hash.t tzresult Lwt.t - (** Accepts queries of the form - /blocks/<id>/raw_context/<path>?depth=<n> - returning the sub-tree corresponding to <path> inside the context of - block <id>. The optional parameter <depth> controls the size of the - tree, default is 1. - Example: - tezos-client rpc post /blocks/head/raw_context/v1?depth=2 - *) - val raw_context: - ([ `POST ], unit, - (unit * block) * string list, <depth:int>, unit, - raw_context_result) RPC_service.t + module Header : sig - type operations_param = { - contents: bool ; - } - val operations: - ([ `POST ], unit, - unit * block, unit, operations_param, - (Operation_hash.t * Operation.t option) list list) RPC_service.t + val header: + #simple -> ?chain:chain -> ?block:block -> + unit -> block_header tzresult Lwt.t + val shell_header: + #simple -> ?chain:chain -> ?block:block -> + unit -> Block_header.shell_header tzresult Lwt.t + val protocol_data: + #simple -> ?chain:chain -> ?block:block -> + unit -> Proto.block_header_data tzresult Lwt.t - val protocol: - ([ `POST ], unit, - unit * block, unit, unit, - Protocol_hash.t) RPC_service.t - val test_chain: - ([ `POST ], unit, - unit * block, unit, unit, - Test_chain_status.t) RPC_service.t + module Shell : sig - type list_param = { - include_ops: bool ; - length: int option ; - heads: Block_hash.t list option ; - monitor: bool option ; - delay: int option ; - min_date: Time.t option; - min_heads: int option; - } - val list: - ([ `POST ], unit, - unit, unit, list_param, - block_info list list) RPC_service.t + val level: + #simple -> ?chain:chain -> ?block:block -> + unit -> Int32.t tzresult Lwt.t + val protocol_level: + #simple -> ?chain:chain -> ?block:block -> + unit -> int tzresult Lwt.t + val predecessor: + #simple -> ?chain:chain -> ?block:block -> + unit -> Block_hash.t tzresult Lwt.t + val timestamp: + #simple -> ?chain:chain -> ?block:block -> + unit -> Time.t tzresult Lwt.t + val validation_passes: + #simple -> ?chain:chain -> ?block:block -> + unit -> int tzresult Lwt.t + val operations_hash: + #simple -> ?chain:chain -> ?block:block -> + unit -> Operation_list_list_hash.t tzresult Lwt.t + val fitness: + #simple -> ?chain:chain -> ?block:block -> + unit -> Fitness.t tzresult Lwt.t + val context_hash: + #simple -> ?chain:chain -> ?block:block -> + unit -> Context_hash.t tzresult Lwt.t - val list_invalid: - ([ `POST ], unit, - unit, unit, unit, - (Block_hash.t * int32 * error list) list) RPC_service.t + end - val unmark_invalid: - ([ `POST ], unit, - unit * Block_hash.t, unit, unit, - unit) RPC_service.t + end - type preapply_param = { - timestamp: Time.t ; - protocol_data: MBytes.t ; - operations: Operation.t list list ; - sort_operations: bool ; - } + module Metadata : sig - val preapply: - ([ `POST ], unit, - unit * block, unit, preapply_param, - preapply_result) RPC_service.t + val metadata: + #simple -> ?chain:chain -> ?block:block -> + unit -> block_metadata tzresult Lwt.t + val protocol_data: + #simple -> ?chain:chain -> ?block:block -> + unit -> Proto.block_header_metadata tzresult Lwt.t + val protocol_hash: + #simple -> ?chain:chain -> ?block:block -> + unit -> Protocol_hash.t tzresult Lwt.t + val next_protocol_hash: + #simple -> ?chain:chain -> ?block:block -> + unit -> Protocol_hash.t tzresult Lwt.t + val test_chain_status: + #simple -> ?chain:chain -> ?block:block -> + unit -> Test_chain_status.t tzresult Lwt.t + val max_operations_ttl: + #simple -> ?chain:chain -> ?block:block -> + unit -> int tzresult Lwt.t + val max_operation_data_length: + #simple -> ?chain:chain -> ?block:block -> + unit -> int tzresult Lwt.t + val max_block_header_length: + #simple -> ?chain:chain -> ?block:block -> + unit -> int tzresult Lwt.t + val max_operation_list_length: + #simple -> ?chain:chain -> ?block:block -> + unit -> operation_list_quota list tzresult Lwt.t - val complete: - ([ `POST ], unit, - (unit * block) * string, unit, unit, - string list) RPC_service.t + end - val proto_path: unit -> ('a, 'a * block) RPC_path.path + module Operation : sig + + val operations: + #simple -> ?chain:chain -> ?block:block -> + unit -> operation list list tzresult Lwt.t + val operations_in_pass: + #simple -> ?chain:chain -> ?block:block -> + int -> operation list tzresult Lwt.t + val operation: + #simple -> ?chain:chain -> ?block:block -> + int -> int -> operation tzresult Lwt.t + + end + + module Operation_hash : sig + + val operation_hashes: + #simple -> ?chain:chain -> ?block:block -> + unit -> Operation_hash.t list list tzresult Lwt.t + val operation_hashes_in_pass: + #simple -> ?chain:chain -> ?block:block -> + int -> Operation_hash.t list tzresult Lwt.t + val operation_hash: + #simple -> ?chain:chain -> ?block:block -> + int -> int -> Operation_hash.t tzresult Lwt.t + + end + + module Context : sig + + module Raw : sig + + val read: + #simple -> ?chain:chain -> ?block:block -> + ?depth: int -> + string list -> raw_context tzresult Lwt.t + + end + + end + + module Helpers : sig + + val preapply: + #simple -> ?chain:chain -> ?block:block -> + ?sort:bool -> + timestamp:Time.t -> + protocol_data:Next_proto.block_header_data -> + Next_proto.operation list list -> + (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t + + val complete: + #simple -> ?chain:chain -> ?block:block -> + string -> string list tzresult Lwt.t + + end + + module S : sig + + val hash: + ([ `GET ], prefix, + prefix, unit, unit, + Block_hash.t) RPC_service.t + + val info: + ([ `GET ], prefix, + prefix, unit, unit, + block_info) RPC_service.t + + module Header : sig + + val header: + ([ `GET ], prefix, + prefix, unit, unit, + block_header) RPC_service.t + + val shell_header: + ([ `GET ], prefix, + prefix, unit, unit, + Block_header.shell_header) RPC_service.t + + val protocol_data: + ([ `GET ], prefix, + prefix, unit, unit, + Proto.block_header_data) RPC_service.t + + module Shell : sig + + val level: + ([ `GET ], prefix, + prefix, unit, unit, + Int32.t) RPC_service.t + + val protocol_level: + ([ `GET ], prefix, + prefix, unit, unit, + int) RPC_service.t + + val predecessor: + ([ `GET ], prefix, + prefix, unit, unit, + Block_hash.t) RPC_service.t + + val timestamp: + ([ `GET ], prefix, + prefix, unit, unit, + Time.t) RPC_service.t + + val validation_passes: + ([ `GET ], prefix, + prefix, unit, unit, + int) RPC_service.t + + val operations_hash: + ([ `GET ], prefix, + prefix, unit, unit, + Operation_list_list_hash.t) RPC_service.t + + val fitness: + ([ `GET ], prefix, + prefix, unit, unit, + Fitness.t) RPC_service.t + + val context_hash: + ([ `GET ], prefix, + prefix, unit, unit, + Context_hash.t) RPC_service.t + + end + + end + + module Metadata : sig + + val metadata: + ([ `GET ], prefix, + prefix, unit, unit, + block_metadata) RPC_service.t + + val protocol_data: + ([ `GET ], prefix, + prefix, unit, unit, + Proto.block_header_metadata) RPC_service.t + + val protocol_hash: + ([ `GET ], prefix, + prefix, unit, unit, + Protocol_hash.t) RPC_service.t + + val next_protocol_hash: + ([ `GET ], prefix, + prefix, unit, unit, + Protocol_hash.t) RPC_service.t + + val test_chain_status: + ([ `GET ], prefix, + prefix, unit, unit, + Test_chain_status.t) RPC_service.t + + val max_operations_ttl: + ([ `GET ], prefix, + prefix, unit, unit, + int) RPC_service.t + + val max_operation_data_length: + ([ `GET ], prefix, + prefix, unit, unit, + int) RPC_service.t + + val max_block_header_length: + ([ `GET ], prefix, + prefix, unit, unit, + int) RPC_service.t + + val operation_list_quota: + ([ `GET ], prefix, + prefix, unit, unit, + operation_list_quota list) RPC_service.t + + end + + module Operation : sig + + val operations: + ([ `GET ], prefix, + prefix, unit, unit, + operation list list) RPC_service.t + + val operations_in_pass: + ([ `GET ], prefix, + prefix * int, unit, unit, + operation list) RPC_service.t + + val operation: + ([ `GET ], prefix, + (prefix * int) * int, unit, unit, + operation) RPC_service.t + + end + + module Operation_hash : sig + + val operation_hashes: + ([ `GET ], prefix, + prefix, unit, unit, + Tezos_crypto.Operation_hash.t list list) RPC_service.t + + val operation_hashes_in_pass: + ([ `GET ], prefix, + prefix * int, unit, unit, + Tezos_crypto.Operation_hash.t list) RPC_service.t + + val operation_hash: + ([ `GET ], prefix, + (prefix * int) * int, unit, unit, + Tezos_crypto.Operation_hash.t) RPC_service.t + + end + + module Context : sig + + module Raw : sig + + val read: + ([ `GET ], prefix, + prefix * string list, < depth : int option >, unit, + raw_context) RPC_service.t + + end + + end + + module Helpers : sig + + type preapply_param = { + timestamp: Time.t ; + protocol_data: Next_proto.block_header_data ; + operations: Next_proto.operation list list ; + } + + val preapply: + ([ `POST ], prefix, + prefix, < sort_operations : bool >, preapply_param, + Block_header.shell_header * error Preapply_result.t list) RPC_service.t + + val complete: + ([ `GET ], prefix, + prefix * string, unit, unit, + string list) RPC_service.t + + end + + end end + +module Fake_protocol : PROTO +module Empty : (module type of Make(Fake_protocol)(Fake_protocol)) diff --git a/src/lib_shell_services/chain_services.ml b/src/lib_shell_services/chain_services.ml new file mode 100644 index 000000000..dd6bb63be --- /dev/null +++ b/src/lib_shell_services/chain_services.ml @@ -0,0 +1,228 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Data_encoding + +type chain = [ + | `Main + | `Test + | `Hash of Chain_id.t +] + +let parse_chain s = + try + match s with + | "main" -> Ok `Main + | "test" -> Ok `Test + | h -> Ok (`Hash (Chain_id.of_b58check_exn h)) + with _ -> Error "Cannot parse block identifier." + +let to_string = function + | `Main -> "main" + | `Test -> "test" + | `Hash h -> Chain_id.to_b58check h + +let chain_arg = + let name = "chain_id" in + let descr = + "A chain identifier. This is either a chain hash in Base58Check notation \ + or a one the predefined aliases: 'main', 'test'." in + let construct = to_string in + let destruct = parse_chain in + RPC_arg.make ~name ~descr ~construct ~destruct () + +type prefix = unit * chain +let path = RPC_path.(root / "chains" /: chain_arg) + +type invalid_block = { + hash: Block_hash.t ; + level: Int32.t ; + errors: error list ; +} + +let invalid_block_encoding = + conv + (fun { hash ; level ; errors } -> (hash, level, errors)) + (fun (hash, level, errors) -> { hash ; level ; errors }) + (obj3 + (req "block" Block_hash.encoding) + (req "level" int32) + (req "errors" RPC_error.encoding)) + +module S = struct + + let path : prefix RPC_path.context = RPC_path.open_root + + let chain_id = + RPC_service.get_service + ~description:"The chain unique identifier." + ~query: RPC_query.empty + ~output: Chain_id.encoding + RPC_path.(path / "chain_id") + + module Mempool = struct + + let operation_encoding = + merge_objs + (obj1 (req "hash" Operation_hash.encoding)) + Operation.encoding + + let pending_operations = + (* TODO: branch_delayed/... *) + RPC_service.get_service + ~description: + "List the not-yet-prevalidated operations." + ~query: RPC_query.empty + ~output: + (conv + (fun (preapplied, unprocessed) -> + ({ preapplied with + Preapply_result.refused = Operation_hash.Map.empty }, + Operation_hash.Map.bindings unprocessed)) + (fun (preapplied, unprocessed) -> + (preapplied, + List.fold_right + (fun (h, op) m -> Operation_hash.Map.add h op m) + unprocessed Operation_hash.Map.empty)) + (merge_objs + (dynamic_size + (Preapply_result.encoding RPC_error.encoding)) + (obj1 (req "unprocessed" (list (dynamic_size operation_encoding)))))) + RPC_path.(path / "mempool") + + end + + module Blocks = struct + + let list_query = + let open RPC_query in + query (fun length heads min_date -> + object + method length = length + method heads = heads + method min_date = min_date + end) + |+ opt_field "length" + ~descr: + "The requested number of predecessors to returns (per \ + requested head)." + RPC_arg.int (fun x -> x#length) + |+ multi_field "head" + ~descr: + "An empty argument requests blocks from the current heads. \ + A non empty list allow to request specific fragment \ + of the chain." + Block_hash.rpc_arg (fun x -> x#heads) + |+ opt_field "min_date" + ~descr: "When `min_date` is provided, heads with a \ + timestamp before `min_date` are filtered out" + Time.rpc_arg (fun x -> x#min_date) + |> seal + + let path = RPC_path.(path / "blocks") + + let list = + let open Data_encoding in + RPC_service.get_service + ~description: + "Lists known heads of the blockchain sorted with decreasing fitness. \ + Optional arguments allows to returns the list of predecessors for \ + known heads or the list of predecessors for a given list of blocks." + ~query: list_query + ~output: (list (list Block_hash.encoding)) + path + + end + + module Invalid_blocks = struct + + let path = RPC_path.(path / "invalid_blocks") + + let list = + RPC_service.get_service + ~description: + "Lists blocks that have been declared invalid along with the errors \ + that led to them being declared invalid." + ~query: RPC_query.empty + ~output: (list invalid_block_encoding) + path + + let get = + RPC_service.get_service + ~description: "The errors that appears during the block (in)validation." + ~query: RPC_query.empty + ~output: invalid_block_encoding + RPC_path.(path /: Block_hash.rpc_arg) + + let delete = + RPC_service.delete_service + ~description: "Remove an invalid block for the tezos storage" + ~query: RPC_query.empty + ~output: Data_encoding.empty + RPC_path.(path /: Block_hash.rpc_arg) + + end + +end + +let make_call0 s ctxt chain q p = + let s = RPC_service.prefix path s in + RPC_context.make_call1 s ctxt chain q p + +let make_call1 s ctxt chain a q p = + let s = RPC_service.prefix path s in + RPC_context.make_call2 s ctxt chain a q p + +let chain_id ctxt = + let f = make_call0 S.chain_id ctxt in + fun ?(chain = `Main) () -> + match chain with + | `Hash h -> return h + | _ -> f chain () () + +module Mempool = struct + + let pending_operations ctxt ?(chain = `Main) () = + make_call0 S.Mempool.pending_operations ctxt chain () () + +end + +module Blocks = struct + + let list ctxt = + let f = make_call0 S.Blocks.list ctxt in + fun ?(chain = `Main) ?(heads = []) ?length ?min_date () -> + f chain + (object + method heads = heads + method length = length + method min_date = min_date + end) + () + +end + +module Invalid_blocks = struct + + let list ctxt = + let f = make_call0 S.Invalid_blocks.list ctxt in + fun ?(chain = `Main) () -> + f chain () () + + let get ctxt = + let f = make_call1 S.Invalid_blocks.get ctxt in + fun ?(chain = `Main) block -> + f chain block () () + + let delete ctxt = + let f = make_call1 S.Invalid_blocks.delete ctxt in + fun ?(chain = `Main) block -> + f chain block () () + +end diff --git a/src/lib_shell_services/chain_services.mli b/src/lib_shell_services/chain_services.mli new file mode 100644 index 000000000..4ece153d8 --- /dev/null +++ b/src/lib_shell_services/chain_services.mli @@ -0,0 +1,126 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type chain = [ + | `Main + | `Test + | `Hash of Chain_id.t +] + +val parse_chain: string -> (chain, string) result +val to_string: chain -> string + +val chain_arg: chain RPC_arg.t + +type invalid_block = { + hash: Block_hash.t ; + level: Int32.t ; + errors: error list ; +} + +type prefix = unit * chain +val path: (unit, prefix) RPC_path.path + +open RPC_context + +val chain_id: + #simple -> + ?chain:chain -> + unit -> Chain_id.t tzresult Lwt.t + +module Mempool : sig + + val pending_operations: + #simple -> + ?chain:chain -> + unit -> + (error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t + +end + +module Blocks : sig + + val list: + #simple -> + ?chain:chain -> + ?heads:Block_hash.t list -> + ?length:int -> + ?min_date:Time.t -> + unit -> Block_hash.t list list tzresult Lwt.t + +end + +module Invalid_blocks : sig + + val list: + #simple -> + ?chain:chain -> + unit -> invalid_block list tzresult Lwt.t + + val get: + #simple -> + ?chain:chain -> + Block_hash.t -> invalid_block tzresult Lwt.t + + val delete: + #simple -> + ?chain:chain -> + Block_hash.t -> unit tzresult Lwt.t + +end + +module S : sig + + val chain_id: + ([ `GET ], prefix, + prefix, unit, unit, + Chain_id.t) RPC_service.t + + module Mempool : sig + + val pending_operations: + ([ `GET ], prefix, + prefix , unit, unit, + error Preapply_result.t * Operation.t Operation_hash.Map.t) RPC_service.t + + end + + module Blocks : sig + + val path: (prefix, prefix) RPC_path.t + + val list: + ([ `GET ], prefix, + prefix, < heads : Block_hash.t list; + length : int option; + min_date : Time.t option >, unit, + Block_hash.t list list) RPC_service.t + + end + + module Invalid_blocks : sig + + val list: + ([ `GET ], prefix, + prefix, unit, unit, + invalid_block list) RPC_service.t + + val get: + ([ `GET ], prefix, + prefix * Block_hash.t, unit, unit, + invalid_block) RPC_service.t + + val delete: + ([ `DELETE ], prefix, + prefix * Block_hash.t, unit, unit, + unit) RPC_service.t + + end + +end diff --git a/src/lib_shell_services/jbuild b/src/lib_shell_services/jbuild index 30e05bb8f..aaa55dfdc 100644 --- a/src/lib_shell_services/jbuild +++ b/src/lib_shell_services/jbuild @@ -4,7 +4,7 @@ ((name tezos_shell_services) (public_name tezos-shell-services) (libraries (tezos-base)) - (flags (:standard -w -9+27-30-32-40@8 + (flags (:standard -w +27@8 -safe-string -open Tezos_base__TzPervasives)))) diff --git a/src/lib_shell_services/mempool_services.ml b/src/lib_shell_services/mempool_services.ml deleted file mode 100644 index c58f40784..000000000 --- a/src/lib_shell_services/mempool_services.ml +++ /dev/null @@ -1,48 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Data_encoding - - - -module S = struct - - let pending_operations = - let operation_encoding = - merge_objs - (obj1 (req "hash" Operation_hash.encoding)) - Operation.encoding in - (* TODO: branch_delayed/... *) - RPC_service.post_service - ~description: - "List the not-yet-prevalidated operations." - ~query: RPC_query.empty - ~input: empty - ~output: - (conv - (fun (preapplied, unprocessed) -> - ({ preapplied with - Preapply_result.refused = Operation_hash.Map.empty }, - Operation_hash.Map.bindings unprocessed)) - (fun (preapplied, unprocessed) -> - (preapplied, - List.fold_right - (fun (h, op) m -> Operation_hash.Map.add h op m) - unprocessed Operation_hash.Map.empty)) - (merge_objs - (dynamic_size - (Preapply_result.encoding RPC_error.encoding)) - (obj1 (req "unprocessed" (list (dynamic_size operation_encoding)))))) - RPC_path.(root / "mempool" / "pending_operations") - -end - -open RPC_context - -let pending_operations ctxt = make_call S.pending_operations ctxt () () () diff --git a/src/lib_shell_services/shell_services.ml b/src/lib_shell_services/shell_services.ml index 88244f150..ef7de0817 100644 --- a/src/lib_shell_services/shell_services.ml +++ b/src/lib_shell_services/shell_services.ml @@ -124,19 +124,51 @@ module S = struct (req "timestamp" Time.encoding)) RPC_path.(root / "bootstrapped") - let complete = - let prefix_arg = - let destruct s = Ok s - and construct s = s in - RPC_arg.make ~name:"prefix" ~destruct ~construct () in - RPC_service.post_service - ~description: "Try to complete a prefix of a Base58Check-encoded data. \ - This RPC is actually able to complete hashes of \ - block and hashes of operations." - ~query: RPC_query.empty - ~input: empty - ~output: (list string) - RPC_path.(root / "complete" /: prefix_arg ) + module Monitor = struct + + let path = RPC_path.(root / "monitor") + + let valid_blocks_query = + let open RPC_query in + query (fun protocols next_protocols chains -> object + method protocols = protocols + method next_protocols = next_protocols + method chains = chains + end) + |+ multi_field "protocol" + Protocol_hash.rpc_arg (fun t -> t#protocols) + |+ multi_field "next_protocol" + Protocol_hash.rpc_arg (fun t -> t#next_protocols) + |+ multi_field "chain" + Chain_services.chain_arg (fun t -> t#chains) + |> seal + + let valid_blocks = + RPC_service.get_service + ~description:"" + ~query: valid_blocks_query + ~output: (obj2 + (req "chain_id" Chain_id.encoding) + (req "hash" Block_hash.encoding)) + RPC_path.(path / "valid_blocks") + + let heads_query = + let open RPC_query in + query (fun next_protocols -> object + method next_protocols = next_protocols + end) + |+ multi_field "next_protocol" + Protocol_hash.rpc_arg (fun t -> t#next_protocols) + |> seal + + let heads = + RPC_service.get_service + ~description:"" + ~query: heads_query + ~output: Block_hash.encoding + RPC_path.(path / "heads" /: Chain_services.chain_arg) + + end end @@ -162,9 +194,21 @@ let inject_protocol ctxt ?(async = false) ?force protocol = let bootstrapped ctxt = make_streamed_call S.bootstrapped ctxt () () () -let complete ctxt ?block prefix = - match block with - | None -> - make_call1 S.complete ctxt prefix () () - | Some block -> - Block_services.complete ctxt block prefix +module Monitor = struct + + module S = S.Monitor + + let valid_blocks + ctxt ?(chains = [`Main]) ?(protocols = []) ?(next_protocols = []) () = + make_streamed_call S.valid_blocks ctxt () (object + method chains = chains + method protocols = protocols + method next_protocols = next_protocols + end) () + + let heads ctxt ?(next_protocols = []) chain = + make_streamed_call S.heads ctxt ((), chain) (object + method next_protocols = next_protocols + end) () + +end diff --git a/src/lib_shell_services/shell_services.mli b/src/lib_shell_services/shell_services.mli index ab27f3ff5..97ef52c2b 100644 --- a/src/lib_shell_services/shell_services.mli +++ b/src/lib_shell_services/shell_services.mli @@ -41,9 +41,22 @@ val inject_protocol: val bootstrapped: #streamed -> ((Block_hash.t * Time.t) Lwt_stream.t * stopper) tzresult Lwt.t -val complete: - #simple -> - ?block:Block_services.block -> string -> string list tzresult Lwt.t +module Monitor : sig + + val valid_blocks: + #streamed -> + ?chains:Chain_services.chain list -> + ?protocols:Protocol_hash.t list -> + ?next_protocols:Protocol_hash.t list -> + unit -> ((Chain_id.t * Block_hash.t) Lwt_stream.t * stopper) tzresult Lwt.t + + val heads: + #streamed -> + ?next_protocols:Protocol_hash.t list -> + Chain_services.chain -> + (Block_hash.t Lwt_stream.t * stopper) tzresult Lwt.t + +end module S : sig @@ -80,9 +93,21 @@ module S : sig unit, unit, unit, Block_hash.t * Time.t) RPC_service.t - val complete: - ([ `POST ], unit, - unit * string, unit, unit, - string list) RPC_service.t + module Monitor : sig + + val valid_blocks: + ([ `GET ], unit, + unit, < chains : Chain_services.chain list; + next_protocols : Protocol_hash.t list; + protocols : Protocol_hash.t list >, unit, + Chain_id.t * Block_hash.t) RPC_service.t + + val heads: + ([ `GET ], unit, + unit * Chain_services.chain, + < next_protocols : Protocol_hash.t list >, unit, + Block_hash.t) RPC_service.t + + end end diff --git a/src/lib_shell_services/worker_services.ml b/src/lib_shell_services/worker_services.ml index 29fa61817..002721640 100644 --- a/src/lib_shell_services/worker_services.ml +++ b/src/lib_shell_services/worker_services.ml @@ -13,12 +13,6 @@ module Prevalidators = struct module S = struct - let (chain_id_arg : Chain_id.t RPC_arg.t) = - RPC_arg.like - Chain_id.rpc_arg - ~descr:"The chain identifier of whom the prevalidator is responsible." - "chain_id" - let list = RPC_service.post_service ~description:"Lists the Prevalidator workers and their status." diff --git a/src/proto_alpha/lib_baking/client_baking_blocks.ml b/src/proto_alpha/lib_baking/client_baking_blocks.ml index 18a8e4bd9..4db2397ed 100644 --- a/src/proto_alpha/lib_baking/client_baking_blocks.ml +++ b/src/proto_alpha/lib_baking/client_baking_blocks.ml @@ -17,68 +17,48 @@ type block_info = { fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t ; + next_protocol: Protocol_hash.t ; level: Level.t ; } -let convert_block_info cctxt - ( { hash ; chain_id ; predecessor ; fitness ; timestamp ; protocol } - : Block_services.block_info ) = - Alpha_services.Context.level cctxt (`Hash (hash, 0)) >>= function - | Ok level -> - Lwt.return - (Some { hash ; chain_id ; predecessor ; - fitness ; timestamp ; protocol ; level }) - | Error _ -> - (* TODO log error *) - Lwt.return_none +let info cctxt ?(chain = `Main) block = + Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> + Block_services.hash cctxt ~chain ~block () >>=? fun hash -> + Block_services.Header.shell_header cctxt ~chain ~block () >>=? fun header -> + Block_services.Metadata.next_protocol_hash + cctxt ~chain ~block () >>=? fun next_protocol -> + Block_services.Metadata.protocol_hash + cctxt ~chain ~block () >>=? fun protocol -> + Alpha_services.Context.level cctxt (chain, block) >>=? fun level -> + let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; _ } = header in + return { hash ; chain_id ; predecessor ; fitness ; + timestamp ; protocol ; next_protocol ; level } -let convert_block_info_err cctxt - ( { hash ; chain_id ; predecessor ; fitness ; timestamp ; protocol } - : Block_services.block_info ) = - Alpha_services.Context.level cctxt (`Hash (hash, 0)) >>=? fun level -> - return { hash ; chain_id ; predecessor ; fitness ; timestamp ; protocol ; level } +let monitor_valid_blocks cctxt ?chains ?protocols ?next_protocols () = + Shell_services.Monitor.valid_blocks cctxt + ?chains ?protocols ?next_protocols () >>=? fun (block_stream, _stop) -> + return (Lwt_stream.map_s + (fun (chain, block) -> + info cctxt ~chain:(`Hash chain) (`Hash (block, 0))) block_stream) -let info cctxt ?include_ops block = - Block_services.info cctxt ?include_ops block >>=? fun block -> - convert_block_info_err cctxt block +let monitor_heads cctxt ?next_protocols chain = + Shell_services.Monitor.heads + cctxt ?next_protocols chain >>=? fun (block_stream, _stop) -> + return (Lwt_stream.map_s + (fun block -> info cctxt ~chain (`Hash (block, 0))) + block_stream) -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 cctxt ?(compare = compare) blocks = - Lwt_list.filter_map_p (convert_block_info cctxt) blocks >|= fun blocks -> - List.sort compare blocks - -let monitor cctxt - ?include_ops ?length ?heads ?delay - ?min_date ?min_heads ?compare () = - Block_services.monitor - ?include_ops ?length ?heads ?delay ?min_date ?min_heads - cctxt >>=? fun (block_stream, _stop) -> - let convert blocks = - sort_blocks cctxt ?compare (List.flatten blocks) >>= return in - return (Lwt_stream.map_s convert block_stream) - -let blocks_from_cycle cctxt block cycle = - Alpha_services.Context.level cctxt block >>=? fun level -> - Alpha_services.Helpers.levels cctxt block cycle >>=? fun (first, last) -> +let blocks_from_cycle cctxt ?(chain = `Main) block cycle = + Block_services.hash cctxt ~chain ~block () >>=? fun hash -> + Alpha_services.Context.level cctxt (chain, block) >>=? fun level -> + Alpha_services.Helpers.levels cctxt (chain, block) cycle >>=? fun (first, last) -> let length = Int32.to_int (Raw_level.diff level.level first) in - Block_services.predecessors cctxt block length >>=? fun blocks -> + Chain_services.Blocks.list cctxt ~heads:[hash] ~length () >>=? fun blocks -> let blocks = List.remove - (length - (1 + Int32.to_int (Raw_level.diff last first))) blocks in + (length - (Int32.to_int (Raw_level.diff last first))) + (List.hd blocks) in if Raw_level.(level.level = last) then - Block_services.hash cctxt block >>=? fun last -> - return (last :: blocks) + return (hash :: blocks) else return blocks diff --git a/src/proto_alpha/lib_baking/client_baking_blocks.mli b/src/proto_alpha/lib_baking/client_baking_blocks.mli index bc69e6399..806aec258 100644 --- a/src/proto_alpha/lib_baking/client_baking_blocks.mli +++ b/src/proto_alpha/lib_baking/client_baking_blocks.mli @@ -17,25 +17,32 @@ type block_info = { fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t ; + next_protocol: Protocol_hash.t ; level: Level.t ; } val info: #Proto_alpha.rpc_context -> - ?include_ops:bool -> Block_services.block -> block_info tzresult Lwt.t + ?chain:Chain_services.chain -> + Block_services.block -> + block_info tzresult Lwt.t -val compare: - block_info -> block_info -> int - -val monitor: +val monitor_valid_blocks: #Proto_alpha.rpc_context -> - ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> - ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - ?compare:(block_info -> block_info -> int) -> - unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t + ?chains:Chain_services.chain list -> + ?protocols:Protocol_hash.t list -> + ?next_protocols:Protocol_hash.t list -> + unit -> block_info tzresult Lwt_stream.t tzresult Lwt.t + +val monitor_heads: + #Proto_alpha.rpc_context -> + ?next_protocols:Protocol_hash.t list -> + Chain_services.chain -> + block_info tzresult Lwt_stream.t tzresult Lwt.t val blocks_from_cycle: #Proto_alpha.rpc_context -> + ?chain:Chain_services.chain -> Block_services.block -> Cycle.t -> Block_hash.t list tzresult Lwt.t diff --git a/src/proto_alpha/lib_baking/client_baking_daemon.ml b/src/proto_alpha/lib_baking/client_baking_daemon.ml index ec93f516a..dfbafc777 100644 --- a/src/proto_alpha/lib_baking/client_baking_daemon.ml +++ b/src/proto_alpha/lib_baking/client_baking_daemon.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -let run (cctxt : #Proto_alpha.full) ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking = +let run (cctxt : #Proto_alpha.full) ?max_priority ~delay delegates ~endorsement ~denunciation ~baking = begin match delegates with | [] -> @@ -23,8 +23,7 @@ let run (cctxt : #Proto_alpha.full) ?max_priority ~delay ?min_date delegates ~en (* TODO really detach... *) let endorsement = if endorsement then - Client_baking_blocks.monitor - cctxt ?min_date ~min_heads:1 () >>=? fun block_stream -> + Client_baking_blocks.monitor_heads cctxt `Main >>=? fun block_stream -> Client_baking_endorsement.create cctxt ~delay delegates block_stream >>= fun () -> return () else @@ -41,12 +40,10 @@ let run (cctxt : #Proto_alpha.full) ?max_priority ~delay ?min_date delegates ~en in let forge = if baking then begin - Client_baking_blocks.monitor - cctxt ?min_date ~min_heads:1 () >>=? fun block_stream -> - Client_baking_operations.monitor_endorsement - cctxt >>=? fun endorsement_stream -> + Client_baking_blocks.monitor_heads + cctxt `Main >>=? fun block_stream -> Client_baking_forge.create cctxt - ?max_priority delegates block_stream endorsement_stream >>=? fun () -> + ?max_priority delegates block_stream >>=? fun () -> return () end else return () diff --git a/src/proto_alpha/lib_baking/client_baking_daemon.mli b/src/proto_alpha/lib_baking/client_baking_daemon.mli index 76ffb370d..db798d8ca 100644 --- a/src/proto_alpha/lib_baking/client_baking_daemon.mli +++ b/src/proto_alpha/lib_baking/client_baking_daemon.mli @@ -14,7 +14,6 @@ val run: #Proto_alpha.full -> ?max_priority: int -> delay: int -> - ?min_date: Time.t -> public_key_hash list -> endorsement:bool -> denunciation:bool -> diff --git a/src/proto_alpha/lib_baking/client_baking_endorsement.ml b/src/proto_alpha/lib_baking/client_baking_endorsement.ml index 70acbcdee..3ba276e1d 100644 --- a/src/proto_alpha/lib_baking/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_baking/client_baking_endorsement.ml @@ -82,33 +82,35 @@ end = struct end -let get_signing_slots cctxt ?max_priority block delegate level = +let get_signing_slots cctxt ?max_priority ?(chain = `Main) block delegate level = Alpha_services.Delegate.Endorser.rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level - block delegate >>=? fun possibilities -> + (chain, block) delegate >>=? fun possibilities -> let slots = List.map (fun (_,slot) -> slot) @@ List.filter (fun (l, _) -> l = level) possibilities in return slots -let inject_endorsement (cctxt : #Proto_alpha.full) - block level ?async +let inject_endorsement + (cctxt : #Proto_alpha.full) + ?(chain = `Main) block level ?async src_sk slots = - Block_services.info cctxt block >>=? fun bi -> + Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> + Block_services.hash cctxt ~chain ~block () >>=? fun hash -> Alpha_services.Forge.Consensus.endorsement cctxt - block - ~branch:bi.hash - ~block:bi.hash + (chain, block) + ~branch:hash + ~block:hash ~level:level ~slots () >>=? fun bytes -> Client_keys.append src_sk ~watermark:Endorsement bytes >>=? fun signed_bytes -> Shell_services.inject_operation - cctxt ?async ~chain_id:bi.chain_id signed_bytes >>=? fun oph -> + cctxt ?async ~chain_id signed_bytes >>=? fun oph -> iter_s (fun slot -> - State.record_endorsement cctxt level bi.hash slot oph) + State.record_endorsement cctxt level hash slot oph) slots >>=? fun () -> return oph @@ -127,22 +129,22 @@ let check_endorsement cctxt level slot = let forge_endorsement (cctxt : #Proto_alpha.full) - block + ?(chain = `Main) block ~src_sk ?slots ?max_priority src_pk = let src_pkh = Signature.Public_key.hash src_pk in - Alpha_services.Context.level cctxt block >>=? fun { level } -> + Alpha_services.Context.level cctxt (chain, block) >>=? fun { level } -> begin match slots with | Some slots -> return slots | None -> get_signing_slots - cctxt ?max_priority block src_pkh level >>=? function + cctxt ?max_priority ~chain block src_pkh level >>=? function | [] -> cctxt#error "No slot found at level %a" Raw_level.pp level | slots -> return slots end >>=? fun slots -> iter_s (check_endorsement cctxt level) slots >>=? fun () -> inject_endorsement cctxt - block level + ~chain block level src_sk slots @@ -188,7 +190,7 @@ let drop_old_endorsement ~before state = (fun { block } -> Fitness.compare before block.fitness <= 0) state.to_endorse -let schedule_endorsements (cctxt : #Proto_alpha.full) state bis = +let schedule_endorsements (cctxt : #Proto_alpha.full) state bi = let may_endorse (block: Client_baking_blocks.block_info) delegate time = Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> lwt_log_info "May endorse block %a for %s" @@ -253,9 +255,7 @@ let schedule_endorsements (cctxt : #Proto_alpha.full) state bis = get_delegates cctxt state >>=? fun delegates -> iter_p (fun delegate -> - iter_p - (fun bi -> may_endorse bi delegate time) - bis) + may_endorse bi delegate time) delegates let schedule_endorsements (cctxt : #Proto_alpha.full) state bis = @@ -316,9 +316,9 @@ let compute_timeout state = let create (cctxt : #Proto_alpha.full) ~delay contracts block_stream = lwt_log_info "Starting endorsement daemon" >>= fun () -> Lwt_stream.get block_stream >>= function - | None | Some (Ok []) | Some (Error _) -> + | None | Some (Error _) -> cctxt#error "Can't fetch the current block head." - | Some (Ok (bi :: _ as initial_heads)) -> + | Some (Ok head) -> let last_get_block = ref None in let get_block () = match !last_get_block with @@ -327,17 +327,17 @@ let create (cctxt : #Proto_alpha.full) ~delay contracts block_stream = last_get_block := Some t ; t | Some t -> t in - let state = create_state contracts bi (Int64.of_int delay) in + let state = create_state contracts head (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 | Some (Error _)) -> Lwt.return_unit - | `Hash (Some (Ok bis)) -> + | `Hash (Some (Ok bi)) -> Lwt.cancel timeout ; last_get_block := None ; - schedule_endorsements cctxt state bis >>= fun () -> + schedule_endorsements cctxt state bi >>= fun () -> worker_loop () | `Timeout -> begin @@ -350,5 +350,5 @@ let create (cctxt : #Proto_alpha.full) ~delay contracts block_stream = Lwt.return_unit end >>= fun () -> worker_loop () in - schedule_endorsements cctxt state initial_heads >>= fun () -> + schedule_endorsements cctxt state head >>= fun () -> worker_loop () diff --git a/src/proto_alpha/lib_baking/client_baking_endorsement.mli b/src/proto_alpha/lib_baking/client_baking_endorsement.mli index c2d613c1a..8262f2745 100644 --- a/src/proto_alpha/lib_baking/client_baking_endorsement.mli +++ b/src/proto_alpha/lib_baking/client_baking_endorsement.mli @@ -12,6 +12,7 @@ open Alpha_context val forge_endorsement: #Proto_alpha.full -> + ?chain:Chain_services.chain -> Block_services.block -> src_sk:Client_keys.sk_uri -> ?slots:int list -> @@ -23,4 +24,4 @@ val create : #Proto_alpha.full -> delay:int -> public_key_hash list -> - Client_baking_blocks.block_info list tzresult Lwt_stream.t -> unit Lwt.t + Client_baking_blocks.block_info tzresult Lwt_stream.t -> unit Lwt.t diff --git a/src/proto_alpha/lib_baking/client_baking_forge.ml b/src/proto_alpha/lib_baking/client_baking_forge.ml index 079e96b77..ab1b78535 100644 --- a/src/proto_alpha/lib_baking/client_baking_forge.ml +++ b/src/proto_alpha/lib_baking/client_baking_forge.ml @@ -22,9 +22,10 @@ let generate_seed_nonce () = | Ok nonce -> nonce let forge_block_header - (cctxt : #Proto_alpha.full) block delegate_sk shell priority seed_nonce_hash = + (cctxt : #Proto_alpha.full) + ?(chain = `Main) block delegate_sk shell priority seed_nonce_hash = Alpha_services.Constants.proof_of_work_threshold - cctxt block >>=? fun stamp_threshold -> + cctxt (chain, block) >>=? fun stamp_threshold -> let rec loop () = let proof_of_work_nonce = generate_proof_of_work_nonce () in let contents = @@ -44,11 +45,11 @@ let empty_proof_of_work_nonce = (String.make Constants_repr.proof_of_work_nonce_size '\000') let forge_faked_protocol_data ~priority ~seed_nonce_hash = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.protocol_data_encoding - { contents = { priority ; seed_nonce_hash ; - proof_of_work_nonce = empty_proof_of_work_nonce } ; - signature = Signature.zero } + Alpha_context.Block_header.{ + contents = { priority ; seed_nonce_hash ; + proof_of_work_nonce = empty_proof_of_work_nonce } ; + signature = Signature.zero + } let assert_valid_operations_hash shell_header operations = let operations_hash = @@ -64,14 +65,15 @@ let assert_valid_operations_hash shell_header operations = inconsistent header.") let inject_block cctxt - ?force ?chain_id + ?force ?(chain = `Main) ~shell_header ~priority ?seed_nonce_hash ~src_sk operations = assert_valid_operations_hash shell_header operations >>=? fun () -> let block = `Hash (shell_header.Tezos_base.Block_header.predecessor, 0) in - forge_block_header cctxt block + forge_block_header cctxt ~chain block src_sk shell_header priority seed_nonce_hash >>=? fun signed_header -> + Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> Shell_services.inject_block cctxt - ?force ?chain_id signed_header operations >>=? fun block_hash -> + ?force ~chain_id signed_header operations >>=? fun block_hash -> return block_hash type error += @@ -97,21 +99,33 @@ let () = | _ -> None) (fun (hash, err) -> Failed_to_preapply (hash, err)) -let classify_operations (ops: Operation.raw list) = +let classify_operations (ops: Operation.t list) = let t = Array.make (List.length Proto_alpha.Main.validation_passes) [] in List.iter - (fun (op: Operation.raw) -> - match Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto with - | Some o -> - List.iter - (fun pass -> t.(pass) <- op :: t.(pass)) - (Proto_alpha.Main.acceptable_passes - { shell = op.shell ; protocol_data = o }) - | None -> ()) + (fun (op: Operation.t) -> + List.iter + (fun pass -> t.(pass) <- op :: t.(pass)) + (Proto_alpha.Main.acceptable_passes op)) ops ; Array.fold_right (fun ops acc -> List.rev ops :: acc) t [] -let forge_block cctxt block +let parse (op : Operation.raw) : Operation.t = { + shell = op.shell ; + protocol_data = + Data_encoding.Binary.of_bytes_exn + Alpha_context.Operation.protocol_data_encoding + op.proto +} + +let forge (op : Operation.t) : Operation.raw = { + shell = op.shell ; + proto = + Data_encoding.Binary.to_bytes_exn + Alpha_context.Operation.protocol_data_encoding + op.protocol_data +} + +let forge_block cctxt ?(chain = `Main) block ?force ?operations ?(best_effort = operations = None) ?(sort = best_effort) ?timestamp @@ -120,9 +134,10 @@ let forge_block cctxt block begin match operations with | None -> - Mempool_services.pending_operations - cctxt >>=? fun (ops, pendings) -> + Chain_services.Mempool.pending_operations + cctxt ~chain () >>=? fun (ops, pendings) -> let ops = + List.map parse @@ List.map snd @@ Operation_hash.Map.bindings @@ Operation_hash.Map.fold @@ -137,20 +152,20 @@ let forge_block cctxt block match priority with | `Set priority -> begin Alpha_services.Helpers.minimal_time - cctxt block ~priority >>=? fun time -> + cctxt (chain, block) ~priority >>=? fun time -> return (priority, time) end | `Auto (src_pkh, max_priority, free_baking) -> - Alpha_services.Context.next_level cctxt block >>=? fun { level } -> + Alpha_services.Context.next_level cctxt (chain, block) >>=? fun { level } -> Alpha_services.Delegate.Baker.rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level - block src_pkh >>=? fun possibilities -> + (chain, block) src_pkh >>=? fun possibilities -> try begin if free_baking then - Alpha_services.Constants.first_free_baking_slot cctxt block + Alpha_services.Constants.first_free_baking_slot cctxt (chain, block) else return 0 end >>=? fun min_prio -> @@ -177,10 +192,13 @@ let forge_block cctxt block let request = List.length operations in let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in let operations = classify_operations operations in - Block_services.preapply - cctxt block ~timestamp ~sort ~protocol_data operations >>=? - fun { operations = result ; shell_header } -> - let valid = List.fold_left (fun acc r -> acc + List.length r.Preapply_result.applied) 0 result in + Block_services.Helpers.preapply + cctxt ~block ~timestamp ~sort ~protocol_data operations >>=? + fun (shell_header, result) -> + let valid = + List.fold_left + (fun acc r -> acc + List.length r.Preapply_result.applied) + 0 result in lwt_log_info "Found %d valid operations (%d refused) for timestamp %a" valid (request - valid) Time.pp_hum timestamp >>= fun () -> @@ -194,11 +212,12 @@ let forge_block cctxt block result then let operations = - if not best_effort then operations - else List.map (fun l -> List.map snd l.Preapply_result.applied) result in - Block_services.info cctxt block >>=? fun {chain_id} -> + if not best_effort then + List.map (List.map forge) operations + else + List.map (fun l -> List.map snd l.Preapply_result.applied) result in inject_block cctxt - ?force ~chain_id ~shell_header ~priority ?seed_nonce_hash ~src_sk + ?force ~chain ~shell_header ~priority ?seed_nonce_hash ~src_sk operations else let result = @@ -226,6 +245,7 @@ let forge_block cctxt block Lwt.return_error @@ List.filter_map (fun op -> + let op = forge op in let h = Tezos_base.Operation.hash op in try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused)) @@ -302,6 +322,7 @@ end let get_baking_slot cctxt ?max_priority (bi: Client_baking_blocks.block_info) delegates = + let chain = `Hash bi.chain_id in let block = `Hash (bi.hash, 0) in let level = Raw_level.succ bi.level.level in Lwt_list.filter_map_p @@ -310,7 +331,7 @@ let get_baking_slot cctxt ?max_priority ~first_level:level ~last_level:level - block delegate >>= function + (chain, block) delegate >>= function | Error errs -> log_error "Error while fetching baking possibilities:\n%a" pp_print_error errs ; @@ -370,8 +391,9 @@ let compute_timeout { future_slots } = else Lwt_unix.sleep (Int64.to_float delay) -let get_unrevealed_nonces (cctxt : #Proto_alpha.full) ?(force = false) block = - Alpha_services.Context.next_level cctxt block >>=? fun level -> +let get_unrevealed_nonces + (cctxt : #Proto_alpha.full) ?(force = false) ?(chain = `Main) block = + Alpha_services.Context.next_level cctxt (chain, block) >>=? fun level -> let cur_cycle = level.cycle in match Cycle.pred cur_cycle with | None -> return [] @@ -383,12 +405,12 @@ let get_unrevealed_nonces (cctxt : #Proto_alpha.full) ?(force = false) block = | None -> return None | Some nonce -> Alpha_services.Context.level - cctxt (`Hash (hash, 0)) >>=? fun level -> + cctxt (chain, `Hash (hash, 0)) >>=? fun level -> if force then return (Some (hash, (level.level, nonce))) else Alpha_services.Nonce.get - cctxt block level.level >>=? function + cctxt (chain, block) level.level >>=? function | Missing nonce_hash when Nonce.check_hash nonce nonce_hash -> cctxt#warning "Found nonce for %a (level: %a)@." @@ -455,8 +477,8 @@ let pop_baking_slots state = state.future_slots <- future_slots ; slots -let insert_blocks cctxt ?max_priority state bis = - iter_s (insert_block cctxt ?max_priority state) bis >>= function +let insert_blocks cctxt ?max_priority state bi = + insert_block cctxt ?max_priority state bi >>= function | Ok () -> Lwt.return_unit | Error err -> @@ -468,8 +490,9 @@ let bake (cctxt : #Proto_alpha.full) state = let seed_nonce_hash = Nonce.hash seed_nonce in filter_map_s (fun (timestamp, (bi, priority, delegate)) -> - let block = `Hash (bi.Client_baking_blocks.hash, 0) in - Alpha_services.Context.next_level cctxt block >>=? fun next_level -> + let chain = `Hash bi.Client_baking_blocks.chain_id in + let block = `Hash (bi.hash, 0) in + Alpha_services.Context.next_level cctxt (chain, block) >>=? fun next_level -> let timestamp = if Block_hash.equal bi.Client_baking_blocks.hash state.genesis then Time.now () @@ -479,9 +502,10 @@ let bake (cctxt : #Proto_alpha.full) state = lwt_debug "Try baking after %a (slot %d) for %s (%a)" Block_hash.pp_short bi.hash priority name Time.pp_hum timestamp >>= fun () -> - Mempool_services.pending_operations cctxt - >>=? fun (res, ops) -> + Chain_services.Mempool.pending_operations + cctxt ~chain () >>=? fun (res, ops) -> let operations = + List.map parse @@ List.map snd @@ Operation_hash.Map.bindings @@ Operation_hash.Map.(fold add) @@ -495,14 +519,14 @@ let bake (cctxt : #Proto_alpha.full) state = let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in let operations = classify_operations operations in - Block_services.preapply cctxt block + Block_services.Helpers.preapply cctxt ~chain ~block ~timestamp ~sort:true ~protocol_data operations >>= function | Error errs -> lwt_log_error "Error while prevalidating operations:@\n%a" pp_print_error errs >>= fun () -> return None - | Ok { operations ; shell_header } -> + | Ok (shell_header, operations) -> lwt_debug "Computed candidate block after %a (slot %d): %a/%d fitness: %a" Block_hash.pp_short bi.hash priority @@ -538,8 +562,9 @@ let bake (cctxt : #Proto_alpha.full) state = Block_hash.pp_short bi.hash priority Fitness.pp shell_header.fitness >>= fun () -> Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) -> + let chain = `Hash bi.Client_baking_blocks.chain_id in inject_block cctxt - ~force:true ~chain_id:bi.chain_id + ~force:true ~chain ~shell_header ~priority ?seed_nonce_hash ~src_sk operations |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash -> @@ -572,14 +597,12 @@ let bake (cctxt : #Proto_alpha.full) state = let create (cctxt : #Proto_alpha.full) ?max_priority delegates (block_stream: - Client_baking_blocks.block_info list tzresult Lwt_stream.t) - (endorsement_stream: - Client_baking_operations.valid_endorsement tzresult Lwt_stream.t) = + Client_baking_blocks.block_info tzresult Lwt_stream.t) = Lwt_stream.get block_stream >>= function - | None | Some (Ok [] | Error _) -> + | None | Some (Error _) -> cctxt#error "Can't fetch the current block head." - | Some (Ok (bi :: _ as initial_heads)) -> - Block_services.hash cctxt `Genesis >>=? fun genesis_hash -> + | Some (Ok bi) -> + Block_services.hash cctxt ~block:`Genesis () >>=? fun genesis_hash -> let last_get_block = ref None in let get_block () = match !last_get_block with @@ -588,45 +611,24 @@ let create 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 bi in - insert_blocks cctxt ?max_priority state initial_heads >>= fun () -> + insert_blocks cctxt ?max_priority state bi >>= 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 | Some (Error _)) - | `Endorsement (None | Some (Error _)) -> + | `Hash (None | Some (Error _)) -> Lwt.return_unit - | `Hash (Some (Ok bis)) -> begin + | `Hash (Some (Ok bi)) -> 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_baking_blocks.hash)) - bis - >>= fun () -> - insert_blocks cctxt ?max_priority state bis >>= fun () -> + "Discoverered block: %a" + Block_hash.pp_short bi.Client_baking_blocks.hash >>= fun () -> + insert_blocks cctxt ?max_priority state bi >>= fun () -> worker_loop () end - | `Endorsement (Some (Ok e)) -> - Lwt.cancel timeout ; - last_get_endorsement := None ; - Client_keys.Public_key_hash.name cctxt - e.Client_baking_operations.source >>= fun _source -> - (* TODO *) - worker_loop () | `Timeout -> lwt_debug "Waking up for baking..." >>= fun () -> begin diff --git a/src/proto_alpha/lib_baking/client_baking_forge.mli b/src/proto_alpha/lib_baking/client_baking_forge.mli index 23ee8dae7..b408269fd 100644 --- a/src/proto_alpha/lib_baking/client_baking_forge.mli +++ b/src/proto_alpha/lib_baking/client_baking_forge.mli @@ -19,7 +19,7 @@ val generate_seed_nonce: unit -> Nonce.t val inject_block: #Proto_alpha.full -> ?force:bool -> - ?chain_id:Chain_id.t -> + ?chain:Chain_services.chain -> shell_header:Block_header.shell_header -> priority:int -> ?seed_nonce_hash:Nonce_hash.t -> @@ -37,9 +37,10 @@ type error += val forge_block: #Proto_alpha.full -> + ?chain:Chain_services.chain -> Block_services.block -> ?force:bool -> - ?operations:Operation.raw list -> + ?operations:Operation.t list -> ?best_effort:bool -> ?sort:bool -> ?timestamp:Time.t -> @@ -79,12 +80,12 @@ val create: #Proto_alpha.full -> ?max_priority: int -> public_key_hash list -> - Client_baking_blocks.block_info list tzresult Lwt_stream.t -> - Client_baking_operations.valid_endorsement tzresult Lwt_stream.t -> + Client_baking_blocks.block_info tzresult Lwt_stream.t -> unit tzresult Lwt.t val get_unrevealed_nonces: #Proto_alpha.full -> ?force:bool -> + ?chain:Chain_services.chain -> Block_services.block -> (Block_hash.t * (Raw_level.t * Nonce.t)) list tzresult Lwt.t diff --git a/src/proto_alpha/lib_baking/client_baking_lib.ml b/src/proto_alpha/lib_baking/client_baking_lib.ml index 6ba235dcc..7e94935e5 100644 --- a/src/proto_alpha/lib_baking/client_baking_lib.ml +++ b/src/proto_alpha/lib_baking/client_baking_lib.ml @@ -10,7 +10,8 @@ open Proto_alpha open Alpha_context -let bake_block (cctxt : #Proto_alpha.full) block +let bake_block (cctxt : #Proto_alpha.full) + ?(chain = `Main) block ?force ?max_priority ?(free_baking=false) ?(minimal_timestamp=false) ?src_sk delegate = begin @@ -20,7 +21,7 @@ let bake_block (cctxt : #Proto_alpha.full) block return src_sk | Some sk -> return sk end >>=? fun src_sk -> - Alpha_services.Context.next_level cctxt block >>=? fun level -> + Alpha_services.Context.next_level cctxt (chain, block) >>=? fun level -> let seed_nonce, seed_nonce_hash = if level.expected_commitment then let seed_nonce = Client_baking_forge.generate_seed_nonce () in @@ -104,6 +105,5 @@ let run_daemon cctxt ?max_priority ~endorsement_delay delegates ~endorsement ~ba Client_baking_daemon.run cctxt ?max_priority ~delay:endorsement_delay - ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L))) ~endorsement ~baking ~denunciation delegates diff --git a/src/proto_alpha/lib_baking/client_baking_lib.mli b/src/proto_alpha/lib_baking/client_baking_lib.mli index bf1b1e926..4da34232c 100644 --- a/src/proto_alpha/lib_baking/client_baking_lib.mli +++ b/src/proto_alpha/lib_baking/client_baking_lib.mli @@ -13,6 +13,7 @@ open Alpha_context (** Mine a block *) val bake_block: #Proto_alpha.full -> + ?chain:Chain_services.chain -> Block_services.block -> ?force:bool -> ?max_priority: int -> diff --git a/src/proto_alpha/lib_baking/client_baking_revelation.ml b/src/proto_alpha/lib_baking/client_baking_revelation.ml index fbfac4d43..56978ee98 100644 --- a/src/proto_alpha/lib_baking/client_baking_revelation.ml +++ b/src/proto_alpha/lib_baking/client_baking_revelation.ml @@ -10,30 +10,31 @@ open Proto_alpha open Alpha_context -let inject_seed_nonce_revelation rpc_config block ?async nonces = +let inject_seed_nonce_revelation rpc_config ?(chain = `Main) block ?async nonces = let operations = List.map (fun (level, nonce) -> Seed_nonce_revelation { level ; nonce }) nonces in - Block_services.info rpc_config block >>=? fun bi -> + Chain_services.chain_id rpc_config ~chain () >>=? fun chain_id -> + Block_services.hash rpc_config ~chain ~block () >>=? fun branch -> Alpha_services.Forge.Anonymous.operations rpc_config - block ~branch:bi.hash operations >>=? fun bytes -> + (chain, block) ~branch operations >>=? fun bytes -> Shell_services.inject_operation - rpc_config ?async ~chain_id:bi.chain_id - bytes >>=? fun oph -> + rpc_config ?async ~chain_id bytes >>=? fun oph -> return oph let forge_seed_nonce_revelation (cctxt: #Proto_alpha.full) + ?(chain = `Main) block nonces = - Block_services.hash cctxt block >>=? fun hash -> + Block_services.hash cctxt ~chain ~block () >>=? fun hash -> match nonces with | [] -> cctxt#message "No nonce to reveal for block %a" Block_hash.pp_short hash >>= fun () -> return () | _ -> - inject_seed_nonce_revelation cctxt block nonces >>=? fun oph -> + inject_seed_nonce_revelation cctxt ~chain block nonces >>=? fun oph -> cctxt#answer "Operation successfully injected %d revelation(s) for %a." (List.length nonces) diff --git a/src/proto_alpha/lib_baking/client_baking_revelation.mli b/src/proto_alpha/lib_baking/client_baking_revelation.mli index c2a102ccb..59c8e2c09 100644 --- a/src/proto_alpha/lib_baking/client_baking_revelation.mli +++ b/src/proto_alpha/lib_baking/client_baking_revelation.mli @@ -12,6 +12,7 @@ open Alpha_context val inject_seed_nonce_revelation: #Proto_alpha.rpc_context -> + ?chain: Chain_services.chain -> Block_services.block -> ?async:bool -> (Raw_level.t * Nonce.t) list -> @@ -19,6 +20,7 @@ val inject_seed_nonce_revelation: val forge_seed_nonce_revelation: #Proto_alpha.full -> + ?chain: Chain_services.chain -> Block_services.block -> (Raw_level.t * Nonce.t) list -> unit tzresult Lwt.t diff --git a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml index ab70edb93..3c499b690 100644 --- a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml +++ b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml @@ -150,7 +150,7 @@ let level block = Alpha_services.Context.level !rpc_ctxt block let rpc_raw_context block path depth = - Block_services.raw_context !rpc_ctxt block path depth + Block_services.Context.Raw.read !rpc_ctxt ~block ~depth path module Account = struct @@ -254,7 +254,8 @@ module Account = struct Tezos_signer_backends.Unencrypted.make_sk account.sk in Client_proto_context.transfer (new wrap_full (no_write_context !rpc_config ~block)) - block + ~chain:`Main + ~block ~source:account.contract ~src_pk:account.pk ~src_sk @@ -278,7 +279,8 @@ module Account = struct Tezos_signer_backends.Unencrypted.make_sk src.sk in Client_proto_context.originate_account (new wrap_full (no_write_context !rpc_config)) - block + ~chain:`Main + ~block ~source:src.contract ~src_pk:src.pk ~src_sk @@ -299,7 +301,8 @@ module Account = struct delegate_opt = Client_proto_context.set_delegate (new wrap_full (no_write_context ~block !rpc_config)) - block + ~chain:`Main + ~block ~fee contract ~src_pk @@ -309,45 +312,55 @@ module Account = struct let balance ?(block = `Head 0) (account : t) = Alpha_services.Contract.balance !rpc_ctxt - block account.contract + (`Main, block) account.contract (* TODO: gather contract related functions in a Contract module? *) let delegate ?(block = `Head 0) (contract : Contract.t) = - Alpha_services.Contract.delegate_opt !rpc_ctxt block contract + Alpha_services.Contract.delegate_opt !rpc_ctxt (`Main, block) contract end +let sign ?watermark src_sk shell contents = + let contents = Sourced_operation contents in + let bytes = + Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + (shell, contents) in + let signature = Some (Signature.sign ?watermark src_sk bytes) in + let protocol_data = { contents ; signature } in + return { shell ; protocol_data } + module Protocol = struct open Account let voting_period_kind ?(block = `Head 0) () = - Alpha_services.Context.voting_period_kind !rpc_ctxt block + Alpha_services.Context.voting_period_kind !rpc_ctxt (`Main, block) let proposals ?(block = `Head 0) ~src:({ pkh; sk } : Account.t) proposals = - Block_services.info !rpc_ctxt block >>=? fun block_info -> - Alpha_services.Context.next_level !rpc_ctxt block >>=? fun next_level -> - Alpha_services.Forge.Amendment.proposals !rpc_ctxt block - ~branch:block_info.hash - ~source:pkh - ~period:next_level.voting_period - ~proposals - () >>=? fun bytes -> - let signed_bytes = Signature.append ~watermark:Generic_operation sk bytes in - return (Tezos_base.Operation.of_bytes_exn signed_bytes) + Block_services.hash !rpc_ctxt ~block () >>=? fun hash -> + Alpha_services.Context.next_level + !rpc_ctxt (`Main, block) >>=? fun next_level -> + let shell = { Tezos_base.Operation.branch = hash } in + let contents = + Amendment_operation + { source = pkh ; + operation = Proposals { period = next_level.voting_period ; + proposals } } in + sign ~watermark:Generic_operation sk shell contents let ballot ?(block = `Head 0) ~src:({ pkh; sk } : Account.t) ~proposal ballot = - Block_services.info !rpc_ctxt block >>=? fun block_info -> - Alpha_services.Context.next_level !rpc_ctxt block >>=? fun next_level -> - Alpha_services.Forge.Amendment.ballot !rpc_ctxt block - ~branch:block_info.hash - ~source:pkh - ~period:next_level.voting_period - ~proposal - ~ballot - () >>=? fun bytes -> - let signed_bytes = Signature.append ~watermark:Generic_operation sk bytes in - return (Tezos_base.Operation.of_bytes_exn signed_bytes) + Block_services.hash !rpc_ctxt ~block () >>=? fun hash -> + Alpha_services.Context.next_level + !rpc_ctxt (`Main, block) >>=? fun next_level -> + let shell = { Tezos_base.Operation.branch = hash } in + let contents = + Amendment_operation + { source = pkh ; + operation = Ballot { period = next_level.voting_period ; + proposal ; + ballot } } in + sign ~watermark:Generic_operation sk shell contents end @@ -415,7 +428,7 @@ module Assert = struct match op with | None -> true | Some op -> - let h = hash op and h' = hash op' in + let h = Operation.hash op and h' = hash op' in Operation_hash.equal h h' end && List.exists (ecoproto_error f) err | _ -> false @@ -473,7 +486,8 @@ module Assert = struct end let check_protocol ?msg ~block h = - Block_services.protocol !rpc_ctxt block >>=? fun block_proto -> + Block_services.Metadata.next_protocol_hash + !rpc_ctxt ~block () >>=? fun block_proto -> return @@ equal ?msg ~prn:Protocol_hash.to_b58check @@ -481,7 +495,7 @@ module Assert = struct block_proto h let check_voting_period_kind ?msg ~block kind = - Alpha_services.Context.voting_period_kind !rpc_ctxt block + Alpha_services.Context.voting_period_kind !rpc_ctxt (`Main, block) >>=? fun current_kind -> return @@ equal ?msg @@ -498,7 +512,7 @@ module Baking = struct let bake block (contract: Account.t) operations = let ctxt = (new wrap_full (no_write_context ~block !rpc_config)) in - Alpha_services.Context.next_level ctxt block >>=? fun level -> + Alpha_services.Context.next_level ctxt (`Main, block) >>=? fun level -> let seed_nonce_hash = if level.Level.expected_commitment then let seed_nonce = @@ -531,17 +545,13 @@ module Endorse = struct block src_sk slot = - Block_services.info !rpc_ctxt block >>=? fun { hash ; _ } -> - Alpha_services.Context.level !rpc_ctxt (`Hash (hash, 0)) >>=? fun level -> - Alpha_services.Forge.Consensus.endorsement !rpc_ctxt - block - ~branch:hash - ~block:hash - ~level:level.level - ~slots:[slot] - () >>=? fun bytes -> - let signed_bytes = Signature.append ~watermark:Endorsement src_sk bytes in - return (Tezos_base.Operation.of_bytes_exn signed_bytes) + Block_services.hash !rpc_ctxt ~block () >>=? fun hash -> + Alpha_services.Context.level !rpc_ctxt (`Main, block) >>=? fun { level } -> + let shell = { Tezos_base.Operation.branch = hash } in + let contents = + Consensus_operation + (Endorsements { block = hash ; level ; slots = [ slot ]}) in + sign ~watermark:Endorsement src_sk shell contents let signing_slots ?(max_priority = 1024) @@ -550,7 +560,7 @@ module Endorse = struct level = Alpha_services.Delegate.Endorser.rights_for_delegate !rpc_ctxt ~max_priority ~first_level:level ~last_level:level - block delegate >>=? fun possibilities -> + (`Main, block) delegate >>=? fun possibilities -> let slots = List.map (fun (_,slot) -> slot) @@ List.filter (fun (l, _) -> l = level) possibilities in @@ -560,7 +570,7 @@ module Endorse = struct ?slot (contract : Account.t) block = - Alpha_services.Context.level !rpc_ctxt block >>=? fun { level } -> + Alpha_services.Context.level !rpc_ctxt (`Main, block) >>=? fun { level } -> begin match slot with | Some slot -> return slot @@ -579,7 +589,7 @@ module Endorse = struct let endorsers_list block = let get_endorser_list result (account : Account.t) level block = Alpha_services.Delegate.Endorser.rights_for_delegate - !rpc_ctxt block account.pkh + !rpc_ctxt (`Main, block) account.pkh ~max_priority:16 ~first_level:level ~last_level:level >>|? fun slots -> @@ -587,7 +597,7 @@ module Endorse = struct in let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in let result = Array.make 16 b1 in - Alpha_services.Context.level !rpc_ctxt block >>=? fun level -> + Alpha_services.Context.level !rpc_ctxt (`Main, block) >>=? fun level -> let level = level.level in get_endorser_list result b1 level block >>=? fun () -> get_endorser_list result b2 level block >>=? fun () -> @@ -599,7 +609,7 @@ module Endorse = struct let endorsement_rights ?(max_priority = 1024) (contract : Account.t) block = - Alpha_services.Context.level !rpc_ctxt block >>=? fun level -> + Alpha_services.Context.level !rpc_ctxt (`Main, block) >>=? fun level -> let delegate = contract.pkh in let level = level.level in Alpha_services.Delegate.Endorser.rights_for_delegate @@ -607,17 +617,17 @@ module Endorse = struct ~max_priority ~first_level:level ~last_level:level - block delegate + (`Main, block) delegate end let display_level block = - Alpha_services.Context.level !rpc_ctxt block >>=? fun lvl -> + Alpha_services.Context.level !rpc_ctxt (`Main, block) >>=? fun lvl -> Format.eprintf "Level: %a@." Level.pp_full lvl ; return () let endorsement_security_deposit block = - Constants_services.endorsement_security_deposit !rpc_ctxt block + Constants_services.endorsement_security_deposit !rpc_ctxt (`Main, block) let () = Client_keys.register_signer diff --git a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.mli b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.mli index 46944ba01..2a81dcd92 100644 --- a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.mli +++ b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.mli @@ -19,11 +19,11 @@ val init : forked Tezos node and the block info of the block from where the tests will begin. *) -val level : Block_services.block -> Alpha_context.Level.t tzresult Lwt.t +val level : Chain_services.chain * Block_services.block -> Alpha_context.Level.t tzresult Lwt.t (** Calls the rpc service raw_context using the right rpc context *) val rpc_raw_context : Block_services.block -> string list -> int -> - Block_services.raw_context_result tzresult Lwt.t + Block_services.raw_context tzresult Lwt.t module Account : sig @@ -103,7 +103,7 @@ module Baking : sig val bake: Block_services.block -> Account.t -> - Operation.raw list -> + Operation.t list -> Block_hash.t tzresult Lwt.t end @@ -114,7 +114,7 @@ module Endorse : sig ?slot:int -> Account.t -> Block_services.block -> - Operation.raw tzresult Lwt.t + Operation.t tzresult Lwt.t val endorsers_list : Block_services.block -> @@ -134,14 +134,14 @@ module Protocol : sig ?block:Block_services.block -> src:Account.t -> Protocol_hash.t list -> - Operation.raw tzresult Lwt.t + Operation.t tzresult Lwt.t val ballot : ?block:Block_services.block -> src:Account.t -> proposal:Protocol_hash.t -> Vote.ballot -> - Operation.raw tzresult Lwt.t + Operation.t tzresult Lwt.t end @@ -166,7 +166,7 @@ module Assert : sig val failed_to_preapply: msg:string -> - ?op:Tezos_base.Operation.t -> + ?op:Operation.t -> (Alpha_environment.Error_monad.error -> bool) -> 'a tzresult -> unit diff --git a/src/proto_alpha/lib_baking/test/test_rpc.ml b/src/proto_alpha/lib_baking/test/test_rpc.ml index afae734da..4f72ed8a1 100644 --- a/src/proto_alpha/lib_baking/test/test_rpc.ml +++ b/src/proto_alpha/lib_baking/test/test_rpc.ml @@ -14,13 +14,13 @@ module Assert = Helpers.Assert A similar test is bin_client/test/test_basic.sh *) let run blkid = - let open Block_services in + let open Block_services in let is_equal a = function | Ok b -> a = b | _ -> false in - let is_not_found : raw_context_result tzresult -> bool = function + let is_not_found : raw_context tzresult -> bool = function | Error [RPC_context.Not_found _] -> true | _ -> false in @@ -38,15 +38,24 @@ let run blkid = let tests = [((["version"],1), is_equal version); (([""],0), is_equal dir_depth0); ((["delegates";"ed25519"],2), is_equal dir_depth2); - (([""],-1), is_not_found); + (* (([""],-1), is_not_found); *) ((["not-existent"],1), is_not_found); ((["not-existent"],0), is_not_found); - ((["not-existent"],-1), is_not_found); + (* ((["not-existent"],-1), is_not_found); *) ] in + + let success = ref true in iter_s (fun ((path,depth),predicate) -> Helpers.rpc_raw_context blkid path depth >>= fun result -> - return (assert (predicate result)) - ) tests + let res = predicate result in + Format.eprintf "/%s (%d) -> %B@." (String.concat "/" path) depth res ; + success := !success && res ; + return () + ) tests >>=? fun () -> + if !success then + return () + else + failwith "Error!" let exe = try Sys.argv.(1) with _ -> "tezos-node" let rpc_port = try int_of_string Sys.argv.(2) with _ -> 18500 diff --git a/src/proto_alpha/lib_baking/test/test_vote.ml b/src/proto_alpha/lib_baking/test/test_vote.ml index 67ff0298e..dc1d832df 100644 --- a/src/proto_alpha/lib_baking/test/test_vote.ml +++ b/src/proto_alpha/lib_baking/test/test_vote.ml @@ -16,7 +16,7 @@ let demo_protocol = "ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9" let print_level head = - level (`Hash (head, 0)) >>=? fun lvl -> + level (`Main, `Hash (head, 0)) >>=? fun lvl -> return @@ Format.eprintf "voting_period = %a.%ld@." Voting_period.pp lvl.voting_period lvl.voting_period_position diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index d8be3a892..a76cc7f2b 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -13,11 +13,11 @@ open Tezos_micheline open Client_proto_contracts open Client_keys -let get_balance (rpc : #Proto_alpha.rpc_context) block contract = - Alpha_services.Contract.balance rpc block contract +let get_balance (rpc : #Proto_alpha.rpc_context) ~chain ~block contract = + Alpha_services.Contract.balance rpc (chain, block) contract -let get_storage (rpc : #Proto_alpha.rpc_context) block contract = - Alpha_services.Contract.storage_opt rpc block contract +let get_storage (rpc : #Proto_alpha.rpc_context) ~chain ~block contract = + Alpha_services.Contract.storage_opt rpc (chain, block) contract let parse_expression arg = Lwt.return @@ -25,9 +25,10 @@ let parse_expression arg = (Michelson_v1_parser.parse_expression arg)) let append_reveal - cctxt block + cctxt ~chain ~block ~source ~src_pk ops = - Alpha_services.Contract.manager_key cctxt block source >>=? fun (_pkh, pk) -> + Alpha_services.Contract.manager_key + cctxt (chain, block) source >>=? fun (_pkh, pk) -> let is_reveal = function | Reveal _ -> true | _ -> false in @@ -37,7 +38,7 @@ let append_reveal | _ -> return ops let transfer (cctxt : #Proto_alpha.full) - block ?confirmations + ~chain ~block ?confirmations ?branch ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee ?(gas_limit = Z.minus_one) ?(storage_limit = -1L) () = begin match arg with @@ -47,26 +48,28 @@ let transfer (cctxt : #Proto_alpha.full) | None -> return None end >>=? fun parameters -> Alpha_services.Contract.counter - cctxt block source >>=? fun pcounter -> + cctxt (chain, block) source >>=? fun pcounter -> let counter = Int32.succ pcounter in let parameters = Option.map ~f:Script.lazy_expr parameters in let operations = [Transaction { amount ; parameters ; destination }] in - append_reveal cctxt block ~source ~src_pk operations >>=? fun operations -> + append_reveal cctxt ~chain ~block + ~source ~src_pk operations >>=? fun operations -> let contents = Sourced_operation (Manager_operations { source ; fee ; counter ; gas_limit ; storage_limit ; operations }) in - Injection.inject_operation cctxt block ?confirmations + Injection.inject_operation cctxt ~chain ~block ?confirmations ?branch ~src_sk contents >>=? fun (_oph, _op, result as res) -> Lwt.return (Injection.originated_contracts result) >>=? fun contracts -> return (res, contracts) let reveal cctxt - block ?confirmations + ~chain ~block ?confirmations ?branch ~source ~src_pk ~src_sk ~fee () = - Alpha_services.Contract.counter cctxt block source >>=? fun pcounter -> + Alpha_services.Contract.counter + cctxt (chain, block) source >>=? fun pcounter -> let counter = Int32.succ pcounter in - append_reveal cctxt block ~source ~src_pk [] >>=? fun operations -> + append_reveal cctxt ~chain ~block ~source ~src_pk [] >>=? fun operations -> match operations with | [] -> failwith "The manager key was previously revealed." @@ -76,24 +79,25 @@ let reveal cctxt (Manager_operations { source ; fee ; counter ; gas_limit = Z.zero ; storage_limit = 0L ; operations }) in - Injection.inject_operation cctxt block ?confirmations + Injection.inject_operation cctxt ~chain ~block ?confirmations ?branch ~src_sk contents >>=? fun res -> return res let originate - cctxt block ?confirmations + cctxt ~chain ~block ?confirmations ?branch ~source ~src_pk ~src_sk ~fee ?(gas_limit = Z.minus_one) ?(storage_limit = -1L) origination = - Alpha_services.Contract.counter cctxt block source >>=? fun pcounter -> + Alpha_services.Contract.counter + cctxt (chain, block) source >>=? fun pcounter -> let counter = Int32.succ pcounter in let operations = [origination] in append_reveal - cctxt block ~source ~src_pk operations >>=? fun operations -> + cctxt ~chain ~block ~source ~src_pk operations >>=? fun operations -> let contents = Sourced_operation (Manager_operations { source ; fee ; counter ; gas_limit ; storage_limit ; operations }) in - Injection.inject_operation cctxt block ?confirmations + Injection.inject_operation cctxt ~chain ~block ?confirmations ?branch ~src_sk contents >>=? fun (_oph, _op, result as res) -> Lwt.return (Injection.originated_contracts result) >>=? function | [ contract ] -> return (res, contract) @@ -103,7 +107,7 @@ let originate (List.length contracts) let originate_account - cctxt block ?confirmations + cctxt ~chain ~block ?confirmations ?branch ~source ~src_pk ~src_sk ~manager_pkh ?(delegatable = false) ?delegate ~balance ~fee () = let origination = @@ -115,32 +119,32 @@ let originate_account credit = balance ; preorigination = None } in originate - cctxt block ?confirmations + cctxt ~chain ~block ?confirmations ?branch ~source ~gas_limit:Z.zero~src_pk ~src_sk ~fee origination let delegate_contract cctxt - block ?branch ?confirmations + ~chain ~block ?branch ?confirmations ~source ~src_pk ~src_sk ~fee delegate_opt = Alpha_services.Contract.counter - cctxt block source >>=? fun pcounter -> + cctxt (chain, block) source >>=? fun pcounter -> let counter = Int32.succ pcounter in let operations = [Delegation delegate_opt] in append_reveal - cctxt block ~source ~src_pk operations >>=? fun operations -> + cctxt ~chain ~block ~source ~src_pk operations >>=? fun operations -> let contents = Sourced_operation (Manager_operations { source ; fee ; counter ; gas_limit = Z.zero ; storage_limit = 0L ; operations }) in - Injection.inject_operation cctxt block ?confirmations + Injection.inject_operation cctxt ~chain ~block ?confirmations ?branch ~src_sk contents >>=? fun res -> return res let list_contract_labels (cctxt : #Proto_alpha.full) - block = - Alpha_services.Contract.list cctxt block >>=? fun contracts -> + ~chain ~block = + Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> map_s (fun h -> begin match Contract.is_implicit h with | Some m -> begin @@ -169,32 +173,39 @@ let message_added_contract (cctxt : #Proto_alpha.full) name = let get_manager (cctxt : #Proto_alpha.full) - block source = + ~chain ~block source = Client_proto_contracts.get_manager - cctxt block source >>=? fun src_pkh -> + cctxt ~chain ~block source >>=? fun src_pkh -> Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> return (src_name, src_pkh, src_pk, src_sk) -let dictate rpc_config block ?confirmations command src_sk = +let dictate rpc_config ~chain ~block ?confirmations command src_sk = let contents = Sourced_operation (Dictator_operation command) in Injection.inject_operation - rpc_config block ?confirmations + rpc_config ~chain ~block ?confirmations ~src_sk contents >>=? fun res -> return res -let set_delegate cctxt block ?confirmations ~fee contract ~src_pk ~manager_sk opt_delegate = +let set_delegate + cctxt ~chain ~block ?confirmations + ~fee contract ~src_pk ~manager_sk opt_delegate = delegate_contract - cctxt block ?confirmations ~source:contract ~src_pk ~src_sk:manager_sk ~fee opt_delegate + cctxt ~chain ~block ?confirmations + ~source:contract ~src_pk ~src_sk:manager_sk ~fee opt_delegate -let register_as_delegate cctxt block ?confirmations ~fee ~manager_sk src_pk = +let register_as_delegate + cctxt ~chain ~block ?confirmations + ~fee ~manager_sk src_pk = let source = Signature.Public_key.hash src_pk in delegate_contract - cctxt block ?confirmations + cctxt ~chain ~block ?confirmations ~source:(Contract.implicit_contract source) ~src_pk ~src_sk:manager_sk ~fee (Some source) -let source_to_keys (wallet : #Proto_alpha.full) block source = - get_manager wallet block source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> +let source_to_keys (wallet : #Proto_alpha.full) ~chain ~block source = + get_manager + wallet ~chain ~block + source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> return (src_pk, src_sk) let save_contract ~force cctxt alias_name contract = @@ -204,7 +215,7 @@ let save_contract ~force cctxt alias_name contract = let originate_contract (cctxt : #Proto_alpha.full) - block ?confirmations ?branch + ~chain ~block ?confirmations ?branch ~fee ?gas_limit ?storage_limit @@ -231,7 +242,7 @@ let originate_contract delegatable ; credit = balance ; preorigination = None } in - originate cctxt block ?confirmations + originate cctxt ~chain ~block ?confirmations ?branch ~source ~src_pk ~src_sk ~fee ?gas_limit ?storage_limit origination type activation_key = @@ -295,8 +306,10 @@ let read_key key = let pkh = Signature.Public_key.hash pk in return (pkh, pk, sk) -let claim_commitment (cctxt : #Proto_alpha.full) - ?(encrypted = false) ?confirmations ?force block key name = +let claim_commitment + (cctxt : #Proto_alpha.full) + ~chain ~block ?confirmations + ?(encrypted = false) ?force key name = read_key key >>=? fun (pkh, pk, sk) -> fail_unless (Signature.Public_key_hash.equal pkh (Ed25519 key.pkh)) (failure "@[<v 2>Inconsistent activation key:@ \ @@ -307,7 +320,9 @@ let claim_commitment (cctxt : #Proto_alpha.full) let contents = Anonymous_operations [ Activation { id = key.pkh ; activation_code = key.activation_code } ] in - Injection.inject_operation cctxt ?confirmations block contents >>=? fun (_oph, _op, _result as res) -> + Injection.inject_operation + cctxt ?confirmations ~chain ~block + contents >>=? fun (_oph, _op, _result as res) -> let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in begin if encrypted then @@ -322,7 +337,7 @@ let claim_commitment (cctxt : #Proto_alpha.full) return () | Some _confirmations -> Alpha_services.Contract.balance - cctxt (`Head 0) + cctxt (`Main, `Head 0) (Contract.implicit_contract pkh) >>=? fun balance -> cctxt#message "Account %s (%a) created with %s%a." name diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index dd3d31235..554a5c827 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -12,31 +12,36 @@ open Alpha_context val list_contract_labels : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> (string * string * string) list tzresult Lwt.t val get_storage : #Proto_alpha.rpc_context -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> Script.expr option tzresult Lwt.t val get_manager : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> (string * public_key_hash * public_key * Client_keys.sk_uri) tzresult Lwt.t val get_balance: #Proto_alpha.rpc_context -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> Tez.t tzresult Lwt.t val set_delegate : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> fee:Tez.tez -> Contract.t -> @@ -47,7 +52,8 @@ val set_delegate : val register_as_delegate: #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> fee:Tez.tez -> manager_sk:Client_keys.sk_uri -> @@ -56,13 +62,15 @@ val register_as_delegate: val source_to_keys: #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> (public_key * Client_keys.sk_uri) tzresult Lwt.t val originate_account : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> ?branch:int -> source:Contract.t -> @@ -84,7 +92,8 @@ val save_contract : val originate_contract: #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> ?branch:int -> fee:Tez.t -> @@ -104,7 +113,8 @@ val originate_contract: val transfer : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> ?branch:int -> source:Contract.t -> @@ -121,7 +131,8 @@ val transfer : val reveal : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> ?branch:int -> source:Contract.t -> @@ -132,7 +143,8 @@ val reveal : val dictate : #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> dictator_operation -> Client_keys.sk_uri -> @@ -151,10 +163,11 @@ val activation_key_encoding: activation_key Data_encoding.t val claim_commitment: #Proto_alpha.full -> - ?encrypted:bool -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> + ?encrypted:bool -> ?force:bool -> - Block_services.block -> activation_key -> string -> Injection.result tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_contracts.ml b/src/proto_alpha/lib_client/client_proto_contracts.ml index af70e1bc0..fb8a73f21 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts.ml @@ -129,13 +129,13 @@ let list_contracts cctxt = keys >>=? fun accounts -> return (contracts @ accounts) -let get_manager cctxt block source = +let get_manager cctxt ~chain ~block source = match Contract.is_implicit source with | Some hash -> return hash - | None -> Alpha_services.Contract.manager cctxt block source + | None -> Alpha_services.Contract.manager cctxt (chain, block) source -let get_delegate cctxt block source = - Alpha_services.Contract.delegate_opt cctxt block source +let get_delegate cctxt ~chain ~block source = + Alpha_services.Contract.delegate_opt cctxt (chain, block) source let may_check_key sourcePubKey sourcePubKeyHash = match sourcePubKey with diff --git a/src/proto_alpha/lib_client/client_proto_contracts.mli b/src/proto_alpha/lib_client/client_proto_contracts.mli index 96ca06dfc..421acec0c 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.mli +++ b/src/proto_alpha/lib_client/client_proto_contracts.mli @@ -43,13 +43,15 @@ val list_contracts: val get_manager: #Proto_alpha.rpc_context -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> public_key_hash tzresult Lwt.t val get_delegate: #Proto_alpha.rpc_context -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> Contract.t -> public_key_hash option tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 182cc394e..9c98f3e25 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -86,51 +86,75 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = | Error errs -> print_errors cctxt errs ~show_source ~parsed -let get_contract cctxt block contract = +let get_contract cctxt ?(chain = `Main) block contract = match contract with | Some contract -> return contract | None -> (* TODO use local contract by default *) - Alpha_services.Contract.list cctxt block >>|? List.hd + Alpha_services.Contract.list cctxt (chain, block) >>|? List.hd let run + (cctxt : #Proto_alpha.rpc_context) + ?(chain = `Main) + block ?contract ?(amount = Tez.fifty_cents) ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) ~(input : Michelson_v1_parser.parsed) - block - (cctxt : #RPC_context.simple) = - get_contract cctxt block contract >>=? fun contract -> + () = + get_contract cctxt ~chain block contract >>=? fun contract -> Alpha_services.Helpers.run_code cctxt - block program.expanded (storage.expanded, input.expanded, amount, contract) + (chain, block) + program.expanded (storage.expanded, input.expanded, amount, contract) let trace + (cctxt : #Proto_alpha.rpc_context) + ?(chain = `Main) + block ?contract ?(amount = Tez.fifty_cents) ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) ~(input : Michelson_v1_parser.parsed) - block - (cctxt : #RPC_context.simple) = - get_contract cctxt block contract >>=? fun contract -> + () = + get_contract cctxt ~chain block contract >>=? fun contract -> Alpha_services.Helpers.trace_code cctxt - block program.expanded (storage.expanded, input.expanded, amount, contract) + (chain, block) + program.expanded (storage.expanded, input.expanded, amount, contract) -let hash_and_sign ?gas (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt = - Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) -> +let hash_and_sign + cctxt + ?(chain = `Main) + block + ?gas + (data : Michelson_v1_parser.parsed) + (typ : Michelson_v1_parser.parsed) + sk = + Alpha_services.Helpers.hash_data + cctxt (chain, block) (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) -> Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature -> return (hash, Signature.to_b58check signature, gas) let typecheck_data + cctxt + ?(chain = `Main) + block ?gas ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) - block cctxt = - Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded, gas) + () = + Alpha_services.Helpers.typecheck_data + cctxt (chain, block) + (data.expanded, ty.expanded, gas) -let typecheck_program ?gas (program : Michelson_v1_parser.parsed) block cctxt = - Alpha_services.Helpers.typecheck_code cctxt block (program.expanded, gas) +let typecheck_program + cctxt + ?(chain = `Main) + block + ?gas + (program : Michelson_v1_parser.parsed) = + Alpha_services.Helpers.typecheck_code cctxt (chain, block) (program.expanded, gas) let print_typecheck_result ~emacs ~show_types ~print_source_on_error diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 150afef7d..aa3cb27ad 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -15,25 +15,29 @@ module Program : Client_aliases.Alias with type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result val run : + #Proto_alpha.rpc_context -> + ?chain:Chain_services.chain -> + Block_services.block -> ?contract:Contract.t -> ?amount:Tez.t -> program:Michelson_v1_parser.parsed -> storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> - Block_services.block -> - #Proto_alpha.rpc_context -> + unit -> (Script.expr * internal_operation list * Contract.big_map_diff option) tzresult Lwt.t val trace : + #Proto_alpha.rpc_context -> + ?chain:Chain_services.chain -> + Block_services.block -> ?contract:Contract.t -> ?amount:Tez.t -> program:Michelson_v1_parser.parsed -> storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> - Block_services.block -> - #Proto_alpha.rpc_context -> + unit -> (Script.expr * internal_operation list * Script_interpreter.execution_trace * @@ -58,27 +62,31 @@ val print_trace_result : tzresult -> unit tzresult Lwt.t val hash_and_sign : + #Proto_alpha.full -> + ?chain:Chain_services.chain -> + Block_services.block -> ?gas:Z.t -> Michelson_v1_parser.parsed -> Michelson_v1_parser.parsed -> Client_keys.sk_uri -> - Block_services.block -> - #Proto_alpha.full -> (string * string * Gas.t) tzresult Lwt.t val typecheck_data : + #Proto_alpha.rpc_context -> + ?chain:Chain_services.chain -> + Block_services.block -> ?gas:Z.t -> data:Michelson_v1_parser.parsed -> ty:Michelson_v1_parser.parsed -> - 'a -> - 'a #Proto_alpha.Alpha_environment.RPC_context.simple -> + unit -> Gas.t tzresult Lwt.t val typecheck_program : + #Proto_alpha.rpc_context -> + ?chain:Chain_services.chain -> + Block_services.block -> ?gas:Z.t -> Michelson_v1_parser.parsed -> - Block_services.block -> - #Proto_alpha.rpc_context -> (Script_tc_errors.type_map * Gas.t) tzresult Lwt.t val print_typecheck_result : diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index a75d12748..f1f30105e 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -11,24 +11,24 @@ open Proto_alpha open Alpha_context open Apply_operation_result -let get_branch rpc_config (block : Block_services.block) branch = +let get_branch (rpc_config: #Proto_alpha.full) + ~chain ~(block : Block_services.block) branch = let branch = Option.unopt ~default:0 branch in (* TODO export parameter *) begin match block with | `Head n -> return (`Head (n+branch)) - | `Test_head n -> return (`Test_head (n+branch)) | `Hash (h,n) -> return (`Hash (h,n+branch)) | `Genesis -> return `Genesis end >>=? fun block -> - Block_services.hash rpc_config block >>=? fun hash -> + Block_services.hash rpc_config ~chain ~block () >>=? fun hash -> return hash type result = Operation_hash.t * operation * operation_result let preapply - cctxt block + (cctxt: #Proto_alpha.full) ~chain ~block ?branch ?src_sk contents = - get_branch cctxt block branch >>=? fun branch -> + get_branch cctxt ~chain ~block branch >>=? fun branch -> let bytes = Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding @@ -51,9 +51,9 @@ let preapply { shell = { branch } ; protocol_data = { contents ; signature } } in let oph = Operation.hash op in - Block_services.hash cctxt block >>=? fun bh -> + Block_services.hash cctxt ~chain ~block () >>=? fun bh -> Alpha_services.Helpers.apply_operation cctxt - block bh oph bytes signature >>=? fun result -> + (chain, block) bh oph bytes signature >>=? fun result -> return (oph, op, result) let estimated_gas = function @@ -117,17 +117,18 @@ let detect_script_failure = function | _ -> Ok () let may_patch_limits - (cctxt : #Proto_alpha.full) block ?branch + (cctxt : #Proto_alpha.full) ~chain ~block ?branch ?src_sk contents = - Alpha_services.Constants.hard_gas_limits cctxt block >>=? fun (_, gas_limit) -> - Alpha_services.Constants.hard_storage_limits cctxt block >>=? fun (_, storage_limit) -> + Alpha_services.Constants.hard_gas_limits cctxt (chain, block) >>=? fun (_, gas_limit) -> + Alpha_services.Constants.hard_storage_limits cctxt (chain, block) >>=? fun (_, storage_limit) -> + match contents with | Sourced_operation (Manager_operations c) when c.gas_limit < Z.zero || gas_limit < c.gas_limit || c.storage_limit < 0L || storage_limit < c.storage_limit -> let contents = Sourced_operation (Manager_operations { c with gas_limit ; storage_limit }) in - preapply cctxt block ?branch ?src_sk contents >>=? fun (_, _, result) -> + preapply cctxt ~chain ~block ?branch ?src_sk contents >>=? fun (_, _, result) -> begin if c.gas_limit < Z.zero || gas_limit < c.gas_limit then Lwt.return (estimated_gas result) >>=? fun gas -> begin @@ -160,11 +161,11 @@ let may_patch_limits | op -> return op let inject_operation - cctxt block + cctxt ~chain ~block ?confirmations ?branch ?src_sk contents = may_patch_limits - cctxt block ?branch ?src_sk contents >>=? fun contents -> - preapply cctxt block + cctxt ~chain ~block ?branch ?src_sk contents >>=? fun contents -> + preapply cctxt ~chain ~block ?branch ?src_sk contents >>=? fun (_oph, op, result) -> begin match detect_script_failure result with | Ok () -> return () @@ -175,7 +176,7 @@ let inject_operation Lwt.return res end >>=? fun () -> let bytes = Data_encoding.Binary.to_bytes_exn Operation.encoding op in - Block_services.chain_id cctxt block >>=? fun chain_id -> + Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> Shell_services.inject_operation cctxt ~chain_id bytes >>=? fun oph -> cctxt#message "Operation successfully injected in the node." >>= fun () -> cctxt#message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -185,7 +186,7 @@ let inject_operation | Some confirmations -> cctxt#message "Waiting for the operation to be included..." >>= fun () -> Client_confirmations.wait_for_operation_inclusion - ~confirmations cctxt oph >>=? fun () -> + ~confirmations cctxt ~chain oph >>=? fun () -> return () end >>=? fun () -> cctxt#message diff --git a/src/proto_alpha/lib_client/injection.mli b/src/proto_alpha/lib_client/injection.mli index 6f08f02a1..d794849c1 100644 --- a/src/proto_alpha/lib_client/injection.mli +++ b/src/proto_alpha/lib_client/injection.mli @@ -15,7 +15,8 @@ type result = Operation_hash.t * operation * operation_result val preapply: #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?branch:int -> ?src_sk:Client_keys.sk_uri -> Operation.contents -> @@ -23,7 +24,8 @@ val preapply: val inject_operation: #Proto_alpha.full -> - Block_services.block -> + chain:Chain_services.chain -> + block:Block_services.block -> ?confirmations:int -> ?branch:int -> ?src_sk:Client_keys.sk_uri -> diff --git a/src/proto_alpha/lib_client/proto_alpha.ml b/src/proto_alpha/lib_client/proto_alpha.ml index 74e960d62..fac34e681 100644 --- a/src/proto_alpha/lib_client/proto_alpha.ml +++ b/src/proto_alpha/lib_client/proto_alpha.ml @@ -9,11 +9,16 @@ module Name = struct let name = "alpha" end module Alpha_environment = Tezos_protocol_environment_faked.MakeV1(Name)() -include Tezos_protocol_alpha.Functor.Make(Alpha_environment) +module Proto = Tezos_protocol_alpha.Functor.Make(Alpha_environment) +module Block_services = struct + include Block_services + include Block_services.Make(Proto)(Proto) +end +include Proto class type rpc_context = object inherit RPC_context.json - inherit [Block_services.block] Alpha_environment.RPC_context.simple + inherit [Chain_services.chain * Block_services.block] Alpha_environment.RPC_context.simple end class wrap_proto_context (t : RPC_context.json) : rpc_context = object @@ -27,17 +32,20 @@ class wrap_proto_context (t : RPC_context.json) : rpc_context = object on_chunk: ('o -> unit) -> on_close: (unit -> unit) -> 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t = t#call_streamed_service - inherit [Block_services.block] Alpha_environment.proto_rpc_context - (t :> RPC_context.t) (Block_services.S.proto_path ()) + inherit [Chain_services.chain, + Block_services.block] Alpha_environment.proto_rpc_context + (t :> RPC_context.t) + Block_services.path end class type full = object inherit Client_context.full - inherit [Block_services.block] Alpha_environment.RPC_context.simple + inherit [Chain_services.chain * Block_services.block] Alpha_environment.RPC_context.simple end class wrap_full (t : Client_context.full) : full = object inherit Client_context.proxy_context t - inherit [Block_services.block] Alpha_environment.proto_rpc_context - (t :> RPC_context.t) (Block_services.S.proto_path ()) + inherit [Chain_services.chain, Block_services.block] Alpha_environment.proto_rpc_context + (t :> RPC_context.t) + Block_services.path end diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 88f47989c..c32018f70 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -56,8 +56,8 @@ let commands () = (switch ~doc:"output time in seconds" ~short:'s' ~long:"seconds" ())) (fixed [ "get" ; "timestamp" ]) begin fun seconds (cctxt : Proto_alpha.full) -> - Block_services.timestamp - cctxt cctxt#block >>=? fun v -> + Block_services.Header.Shell.timestamp + cctxt ~block:cctxt#block () >>=? fun v -> begin if seconds then cctxt#message "%Ld" (Time.to_seconds v) @@ -70,7 +70,8 @@ let commands () = no_options (fixed [ "list" ; "contracts" ]) begin fun () (cctxt : Proto_alpha.full) -> - list_contract_labels cctxt cctxt#block >>=? fun contracts -> + list_contract_labels cctxt + ~chain:`Main ~block:cctxt#block >>=? fun contracts -> Lwt_list.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> @@ -83,7 +84,9 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) begin fun () (_, contract) (cctxt : Proto_alpha.full) -> - get_balance cctxt cctxt#block contract >>=? fun amount -> + get_balance cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? fun amount -> cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () -> return () end ; @@ -94,7 +97,9 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) begin fun () (_, contract) (cctxt : Proto_alpha.full) -> - get_storage cctxt cctxt#block contract >>=? function + get_storage cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? function | None -> cctxt#error "This is not a smart contract." | Some storage -> @@ -108,8 +113,9 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) begin fun () (_, contract) (cctxt : Proto_alpha.full) -> - Client_proto_contracts.get_manager - cctxt cctxt#block contract >>=? fun manager -> + Client_proto_contracts.get_manager cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? fun manager -> Public_key_hash.rev_find cctxt manager >>=? fun mn -> Public_key_hash.to_source manager >>=? fun m -> cctxt#message "%s (%s)" m @@ -123,8 +129,9 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) begin fun () (_, contract) (cctxt : Proto_alpha.full) -> - Client_proto_contracts.get_delegate - cctxt cctxt#block contract >>=? function + Client_proto_contracts.get_delegate cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? function | None -> cctxt#message "none" >>= fun () -> return () @@ -145,9 +152,11 @@ let commands () = ~name: "mgr" ~desc: "new delegate of the contract" @@ stop) begin fun fee (_, contract) (_, delegate) (cctxt : Proto_alpha.full) -> - source_to_keys cctxt cctxt#block contract >>=? fun (src_pk, manager_sk) -> - set_delegate - cctxt cctxt#block ?confirmations:cctxt#confirmations + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? fun (src_pk, manager_sk) -> + set_delegate cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations contract (Some delegate) ~fee ~src_pk ~manager_sk >>=? fun _ -> return () end ; @@ -158,9 +167,11 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) begin fun fee (_, contract) (cctxt : Proto_alpha.full) -> - source_to_keys cctxt cctxt#block contract >>=? fun (src_pk, manager_sk) -> - set_delegate - cctxt cctxt#block ?confirmations:cctxt#confirmations + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + contract >>=? fun (src_pk, manager_sk) -> + set_delegate cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations contract None ~fee ~src_pk ~manager_sk >>=? fun _ -> return () end ; @@ -183,20 +194,13 @@ let commands () = begin fun (fee, delegate, delegatable, force) new_contract manager_pkh balance (_, source) (cctxt : Proto_alpha.full) -> RawContractAlias.of_fresh cctxt force new_contract >>=? fun alias_name -> - source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> - originate_account - cctxt - cctxt#block - ?confirmations:cctxt#confirmations - ~fee - ?delegate - ~delegatable - ~manager_pkh - ~balance - ~source - ~src_pk - ~src_sk - () >>=? fun (_res, contract) -> + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + source >>=? fun (src_pk, src_sk) -> + originate_account cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations + ~fee ?delegate ~delegatable ~manager_pkh ~balance + ~source ~src_pk ~src_sk () >>=? fun (_res, contract) -> save_contract ~force cctxt alias_name contract >>=? fun () -> return () end ; @@ -226,8 +230,11 @@ let commands () = alias_name manager balance (_, source) program (cctxt : Proto_alpha.full) -> RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name -> Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } -> - source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> - originate_contract cctxt cctxt#block ?confirmations:cctxt#confirmations + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + source >>=? fun (src_pk, src_sk) -> + originate_contract cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~fee ?gas_limit ?storage_limit ~delegate ~delegatable ~spendable ~initial_storage ~manager ~balance ~source ~src_pk ~src_sk ~code () >>= fun errors -> report_michelson_errors ~no_print_source ~msg:"origination simulation failed" cctxt errors >>= function @@ -250,8 +257,11 @@ let commands () = ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) begin fun (fee, gas_limit, storage_limit, arg, no_print_source) amount (_, source) (_, destination) cctxt -> - source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> - transfer cctxt cctxt#block ?confirmations:cctxt#confirmations + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + source >>=? fun (src_pk, src_sk) -> + transfer cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~source ~fee ~src_pk ~src_sk ~destination ~arg ~amount ?gas_limit ?storage_limit () >>= report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt >>= function | None -> return () @@ -266,8 +276,11 @@ let commands () = ~name: "src" ~desc: "name of the source contract" @@ stop) begin fun fee (_, source) cctxt -> - source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> - reveal cctxt cctxt#block ?confirmations:cctxt#confirmations + source_to_keys cctxt + ~chain:`Main ~block:cctxt#block + source >>=? fun (src_pk, src_sk) -> + reveal cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~source ~fee ~src_pk ~src_sk () >>=? fun _res -> return () end; @@ -281,8 +294,9 @@ let commands () = @@ stop) begin fun fee src_pkh cctxt -> Client_keys.get_key cctxt src_pkh >>=? fun (_, src_pk, src_sk) -> - register_as_delegate cctxt ?confirmations:cctxt#confirmations - ~fee cctxt#block ~manager_sk:src_sk src_pk >>=? fun _res -> + register_as_delegate cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations + ~fee ~manager_sk:src_sk src_pk >>=? fun _res -> return () end; @@ -309,8 +323,8 @@ let commands () = (fun ppf -> Data_encoding.Json.print_error ppf) exn Data_encoding.Json.pp json | key -> - claim_commitment - cctxt cctxt#block ?confirmations:cctxt#confirmations + claim_commitment cctxt + ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~encrypted ~force key name >>=? fun _res -> return () ); @@ -325,7 +339,8 @@ let commands () = ~name:"password" ~desc:"dictator's key" @@ stop) begin fun () hash seckey cctxt -> - dictate cctxt cctxt#block + dictate cctxt + ~chain:`Main ~block:cctxt#block (Activate hash) seckey >>=? fun _ -> return () end ; @@ -366,7 +381,7 @@ let commands () = fail_when (predecessors < 0) (failure "check-previous cannot be negative") >>=? fun () -> Client_confirmations.wait_for_operation_inclusion ctxt - ~confirmations ~predecessors operation_hash >>=? fun _ -> + ~chain:`Main ~confirmations ~predecessors operation_hash >>=? fun _ -> return () end ; @@ -380,7 +395,8 @@ let commands () = ~name:"password" ~desc:"dictator's key" @@ stop) begin fun () hash seckey cctxt -> - dictate cctxt cctxt#block + dictate cctxt + ~chain:`Main ~block:cctxt#block (Activate_testchain hash) seckey >>=? fun _res -> return () end ; diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 25c98af99..353db62d7 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -55,7 +55,7 @@ let commands () = with _ -> failwith "invalid gas limit (must be a positive number)")) in let resolve_max_gas cctxt block = function | None -> - Alpha_services.Constants.hard_gas_limits cctxt block >>=? fun (_, gas) -> + Alpha_services.Constants.hard_gas_limits cctxt (`Main, block) >>=? fun (_, gas) -> return gas | Some gas -> return gas in let data_parameter = @@ -123,10 +123,10 @@ let commands () = Lwt.return @@ Micheline_parser.no_parsing_error program >>=? fun program -> let show_source = not no_print_source in (if trace_exec then - trace ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res -> + trace cctxt cctxt#block ~amount ~program ~storage ~input () >>= fun res -> print_trace_result cctxt ~show_source ~parsed:program res else - run ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res -> + run cctxt cctxt#block ~amount ~program ~storage ~input () >>= fun res -> print_run_result cctxt ~show_source ~parsed:program res)) ; command ~group ~desc: "Ask the node to typecheck a program." (args4 show_types_switch emacs_mode_switch no_print_source_flag custom_gas_flag) @@ -137,7 +137,7 @@ let commands () = match program with | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> - typecheck_program ~gas:original_gas program cctxt#block cctxt >>= fun res -> + typecheck_program cctxt cctxt#block ~gas:original_gas program >>= fun res -> print_typecheck_result ~emacs:emacs_mode ~show_types @@ -171,7 +171,8 @@ let commands () = @@ stop) (fun (no_print_source, custom_gas) data ty cctxt -> resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas -> - Client_proto_programs.typecheck_data ~gas:original_gas ~data ~ty cctxt#block cctxt >>= function + Client_proto_programs.typecheck_data cctxt cctxt#block + ~gas:original_gas ~data ~ty () >>= function | Ok gas -> cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]" Proto_alpha.Alpha_context.Gas.pp gas >>= fun () -> @@ -198,8 +199,8 @@ let commands () = @@ stop) (fun custom_gas data typ cctxt -> resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas -> - Alpha_services.Helpers.hash_data cctxt - cctxt#block (data.expanded, typ.expanded, Some original_gas) >>= function + Alpha_services.Helpers.hash_data cctxt (`Main, cctxt#block) + (data.expanded, typ.expanded, Some original_gas) >>= function | Ok (hash, remaining_gas) -> cctxt#message "%S@,Gas remaining: %a" hash Proto_alpha.Alpha_context.Gas.pp remaining_gas >>= fun () -> @@ -231,7 +232,8 @@ let commands () = @@ stop) (fun gas data typ sk cctxt -> resolve_max_gas cctxt cctxt#block gas >>=? fun gas -> - Client_proto_programs.hash_and_sign ~gas data typ sk cctxt#block cctxt >>= begin function + Client_proto_programs.hash_and_sign cctxt cctxt#block + ~gas data typ sk >>= begin function | Ok (hash, signature, current_gas) -> cctxt#message "@[<v 0>Hash: %S@,Signature: %S@,Remaining gas: %a@]" hash signature diff --git a/src/proto_alpha/lib_protocol/src/alpha_services.ml b/src/proto_alpha/lib_protocol/src/alpha_services.ml index f640afbeb..a9ec6ca73 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/src/alpha_services.ml @@ -11,98 +11,6 @@ open Alpha_context let custom_root = RPC_path.open_root -module S = struct - - open Data_encoding - - let operations = - RPC_service.post_service - ~description: "All the operations of the block (fully decoded)." - ~query: RPC_query.empty - ~input: empty - ~output: (list (list (merge_objs - (obj1 (req "hash" Operation_hash.encoding)) - (dynamic_size Operation.encoding)))) - RPC_path.(custom_root / "operations") - - let header = - RPC_service.post_service - ~description: "The header of the block (fully decoded)." - ~query: RPC_query.empty - ~input: empty - ~output: Block_header.encoding - RPC_path.(custom_root / "header") - - let priority = - RPC_service.post_service - ~description: "Baking priority of the block." - ~query: RPC_query.empty - ~input: empty - ~output: (obj1 (req "priority" uint16)) - RPC_path.(custom_root / "header" / "priority") - - let seed_nonce_hash = - RPC_service.post_service - ~description: "Hash of the seed nonce of the block." - ~query: RPC_query.empty - ~input: empty - ~output: Nonce_hash.encoding - RPC_path.(custom_root / "header" / "seed_nonce_hash") - -end - -let parse_operation (op: Operation.raw) = - match Data_encoding.Binary.of_bytes - Operation.protocol_data_encoding - op.proto with - | Some protocol_data -> - ok { shell = op.shell ; protocol_data } - | None -> error Helpers_services.Cannot_parse_operation - -let parse_block_header - ({ shell ; protocol_data } : Block_header.raw) : Block_header.t tzresult = - match - Data_encoding.Binary.of_bytes - Block_header.protocol_data_encoding - protocol_data - with - | None -> Error [Helpers_services.Cant_parse_block_header] - | Some protocol_data -> Ok { shell ; protocol_data } - - -let () = - let open Services_registration in - register0_fullctxt S.operations begin fun ctxt () () -> - ctxt.operation_hashes () >>= fun operation_hashes -> - ctxt.operations () >>= fun operations -> - map2_s - (map2_s (fun h op -> - Lwt.return (parse_operation op) >>=? fun op -> - return (h, op))) - operation_hashes operations - end ; - register0_fullctxt S.header begin fun { block_header ; _ } () () -> - Lwt.return (parse_block_header block_header) >>=? fun block_header -> - return block_header - end ; - register0_fullctxt S.priority begin fun { block_header ; _ } () () -> - Lwt.return (parse_block_header block_header) >>=? fun block_header -> - return block_header.protocol_data.contents.priority - end ; - opt_register0_fullctxt S.seed_nonce_hash begin fun { block_header ; _ } () ( )-> - Lwt.return (parse_block_header block_header) >>=? fun block_header -> - return block_header.protocol_data.contents.seed_nonce_hash - end - -let operations ctxt block = - RPC_context.make_call0 S.operations ctxt block () () -let header ctxt block = - RPC_context.make_call0 S.header ctxt block () () -let priority ctxt block = - RPC_context.make_call0 S.priority ctxt block () () -let seed_nonce_hash ctxt block = - RPC_context.make_call0 S.seed_nonce_hash ctxt block () () - module Context = struct module S = struct diff --git a/src/proto_alpha/lib_protocol/src/alpha_services.mli b/src/proto_alpha/lib_protocol/src/alpha_services.mli index 75c56503b..3dd64bab3 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_services.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_services.mli @@ -9,15 +9,6 @@ open Alpha_context -val operations: - 'a #RPC_context.simple -> 'a -> (Operation_hash.t * Operation.t) list list shell_tzresult Lwt.t -val header: - 'a #RPC_context.simple -> 'a -> Block_header.t shell_tzresult Lwt.t -val priority: - 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t -val seed_nonce_hash: - 'a #RPC_context.simple -> 'a -> Nonce_hash.t shell_tzresult Lwt.t - module Context : sig val level: diff --git a/src/proto_alpha/lib_protocol/src/block_header_repr.ml b/src/proto_alpha/lib_protocol/src/block_header_repr.ml index 712c26808..eab573190 100644 --- a/src/proto_alpha/lib_protocol/src/block_header_repr.ml +++ b/src/proto_alpha/lib_protocol/src/block_header_repr.ml @@ -99,13 +99,30 @@ let metadata_encoding = (** Constants *) let max_header_length = - let fake = { priority = 0 ; - proof_of_work_nonce = - MBytes.create Constants_repr.proof_of_work_nonce_size ; - seed_nonce_hash = Some Nonce_hash.zero } in + let fake_shell = { + Block_header.level = 0l ; + proto_level = 0 ; + predecessor = Block_hash.zero ; + timestamp = Time.of_seconds 0L ; + validation_passes = 0 ; + operations_hash = Operation_list_list_hash.zero ; + fitness = Fitness_repr.from_int64 0L ; + context = Context_hash.zero ; + } + and fake_contents = + { priority = 0 ; + proof_of_work_nonce = + MBytes.create Constants_repr.proof_of_work_nonce_size ; + seed_nonce_hash = Some Nonce_hash.zero + } in Data_encoding.Binary.length - protocol_data_encoding - { contents = fake ; signature = Signature.zero} + encoding + { shell = fake_shell ; + protocol_data = { + contents = fake_contents ; + signature = Signature.zero ; + } + } (** Header parsing entry point *) diff --git a/src/proto_alpha/lib_protocol/src/services_registration.ml b/src/proto_alpha/lib_protocol/src/services_registration.ml index 8debf4dd7..c1b2f1002 100644 --- a/src/proto_alpha/lib_protocol/src/services_registration.ml +++ b/src/proto_alpha/lib_protocol/src/services_registration.ml @@ -11,20 +11,17 @@ open Alpha_context type rpc_context = { block_hash: Block_hash.t ; - block_header: Block_header.raw ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.raw list list Lwt.t ; + block_header: Block_header.shell_header ; context: Alpha_context.t ; } let rpc_init (rpc_context : Updater.rpc_context Lwt.t) = - rpc_context >>= fun { block_hash ; block_header ; - operation_hashes ; operations ; context } -> - let level = block_header.shell.level in - let timestamp = block_header.shell.timestamp in - let fitness = block_header.shell.fitness in + rpc_context >>= fun { block_hash ; block_header ; context } -> + let level = block_header.level in + let timestamp = block_header.timestamp in + let fitness = block_header.fitness in Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context -> - return { block_hash ; block_header ; operation_hashes ; operations ; context } + return { block_hash ; block_header ; context } let rpc_services = ref (RPC_directory.empty : Updater.rpc_context Lwt.t RPC_directory.t) diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 8dd6967cb..fb072077e 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -21,13 +21,9 @@ type t = { type block = t let rpc_context block = - let operations_hashes = - lazy [ List.map Operation.hash block.operations ] in Lwt.return { Alpha_environment.Updater.block_hash = block.hash ; - block_header = (Block_header.raw block.header) ; - operation_hashes = (fun () -> Lwt.return (Lazy.force operations_hashes)) ; - operations = (fun () -> Lwt.return [ List.map Operation.raw block.operations ]) ; + block_header = block.header.shell ; context = block.context ; } diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 334b0d6bb..4b28a72ed 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -24,19 +24,10 @@ let predecessor { predecessor ; _ } = predecessor let level st = st.header.shell.level let rpc_context st = - let operations = lazy (List.rev st.rev_operations) in - let operations_hashes = - lazy (List.map Operation.hash (Lazy.force operations)) in let result = Alpha_context.finalize st.state.ctxt in Lwt.return { Alpha_environment.Updater.block_hash = Block_hash.zero ; - block_header = - Block_header.raw - { st.header with - shell = { st.header.shell with fitness = result.fitness }} ; - operation_hashes = (fun () -> Lwt.return [Lazy.force operations_hashes]) ; - operations = (fun () -> - Lwt.return [List.map Operation.raw (Lazy.force operations)]) ; + block_header = { st.header.shell with fitness = result.fitness } ; context = result.context ; } diff --git a/src/proto_genesis/lib_client/client_proto_main.ml b/src/proto_genesis/lib_client/client_proto_main.ml index bb2f90b8c..1fb9dee89 100644 --- a/src/proto_genesis/lib_client/client_proto_main.ml +++ b/src/proto_genesis/lib_client/client_proto_main.ml @@ -14,13 +14,10 @@ let protocol = "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" let bake cctxt ?(timestamp = Time.now ()) block command sk = - let protocol_data = - Data_encoding.Binary.to_bytes_exn - Proto_genesis.block_header_data_encoding - { command ; signature = Signature.zero } in - Block_services.preapply - cctxt block ~timestamp ~protocol_data - [] >>=? fun { shell_header } -> + let protocol_data = { command ; signature = Signature.zero } in + Block_services.Helpers.preapply + cctxt ~block ~timestamp ~protocol_data + [] >>=? fun (shell_header, _) -> let blk = Data.Command.forge shell_header command in Client_keys.append sk blk >>=? fun signed_blk -> Shell_services.inject_block cctxt signed_blk [] diff --git a/src/proto_genesis/lib_client/proto_genesis.ml b/src/proto_genesis/lib_client/proto_genesis.ml index cf45e0674..84bf9e1bc 100644 --- a/src/proto_genesis/lib_client/proto_genesis.ml +++ b/src/proto_genesis/lib_client/proto_genesis.ml @@ -9,4 +9,9 @@ module Name = struct let name = "genesis" end module Genesis_environment = Tezos_protocol_environment_faked.MakeV1(Name)() -include Tezos_protocol_genesis.Functor.Make(Genesis_environment) +module Proto = Tezos_protocol_genesis.Functor.Make(Genesis_environment) +module Block_services = struct + include Block_services + include Block_services.Make(Proto)(Proto) +end +include Proto