Client: update proto_demo

The client registers three commands.
- demo tests an echo RPC,
- fail tests an always failing RPC,
- bake creates a new block with empty protocol content.

.gitlab-ci.yml

@@ -548,6 +548,10 @@ opam:63:tezos-baker-alpha-commands:
   variables:
     package: tezos-baker-alpha-commands
 
+opam:63:tezos-client-demo:
+  <<: *opam_definition
+  variables:
+    package: tezos-client-demo
 
 ##END_OPAM##
 

src/bin_client/dune

@@ -7,6 +7,7 @@
             tezos-client-base
             tezos-client-commands
             tezos-client-genesis
+            tezos-client-demo
             tezos-client-alpha
             tezos-stdlib-unix
             tezos-client-base-unix

src/proto_demo/lib_client/client_proto_main.ml

@@ -23,78 +23,48 @@
 (*                                                                           *)
 (*****************************************************************************)
 
+open Proto_demo
+
 let protocol =
   Protocol_hash.of_b58check_exn
     "ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9"
 
-let demo cctxt =
+let bake (cctxt : full) : unit tzresult Lwt.t =
-  let block = Client_commands.(cctxt.config.block) in
+  let protocol_data = MBytes.create 0 in
-  cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () ->
+  Demo_block_services.Helpers.Preapply.block cctxt [] ~protocol_data >>=? fun (shell, _) ->
+  let block : Block_header.t = { shell = shell; protocol_data } in
+  Demo_block_services.Helpers.Forge.block_header cctxt block >>=? fun encoded_header ->
+  Shell_services.Injection.block cctxt encoded_header [] >>=? fun block_hash ->
+  cctxt#message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
+  return_unit
+
+let demo (cctxt : full) : unit tzresult Lwt.t =
+  let block = cctxt#block in
+  let chain = `Main in
   let msg = "test" in
-  Client_proto_rpcs.echo cctxt.rpc_config block msg >>=? fun reply ->
+  cctxt#message "Calling the 'echo' RPC with value %s." msg >>= fun () ->
-  fail_unless (reply = msg) (failure "...") >>=? fun () ->
+  Services.echo cctxt (chain, block) msg >>=? fun reply ->
-  begin
+  cctxt#message "Received value: %s" reply >>= fun () ->
-    cctxt.message "Calling the 'failing' RPC." >>= fun () ->
-    Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function
-    | Error [Environment.Ecoproto_error [Error.Demo_error 3]] ->
-        return_unit
-    | _ -> failwith "..."
-  end >>=? fun () ->
-  cctxt.message "Direct call to `demo_error`." >>= fun () ->
-  begin Error.demo_error 101010 >|= Environment.wrap_error >>= function
-    | Error [Environment.Ecoproto_error [Error.Demo_error 101010]] ->
-        return_unit
-    | _ -> failwith "...."
-  end >>=? fun () ->
-  cctxt.answer "All good!" >>= fun () ->
   return_unit
 
-let bake cctxt =
+let error (cctxt : full) : unit tzresult Lwt.t =
-  Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi ->
+  let block = cctxt#block in
-  let fitness =
+  let chain = `Main in
-    match bi.fitness with
+  Services.failing cctxt (chain, block) 42 >>=? fun () ->
-    | [ v ; b ] ->
-        let f = MBytes.get_int64 b 0 in
-        MBytes.set_int64 b 0 (Int64.succ f) ;
-        [ v ; b ]
-    | _ ->
-        Lwt.ignore_result
-          (cctxt.message "Cannot parse fitness: %a" Environment.Fitness.pp bi.fitness);
-        exit 2 in
-  Client_node_rpcs.forge_block_header cctxt.rpc_config
-    { shell = { predecessor = bi.hash ;
-                proto_level = bi.proto_level ;
-                level = Int32.succ bi.level ;
-                timestamp = Time.now () ;
-                fitness ;
-                validation_passes = 0 ;
-                operations_hash = Operation_list_list_hash.empty } ;
-      proto = MBytes.create 0 } >>=? fun bytes ->
-  Client_node_rpcs.inject_block cctxt.rpc_config ~chain_id:bi.chain_id bytes [] >>=? fun hash ->
-  cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
   return_unit
 
-let handle_error cctxt = function
+let commands () : full Clic.command list =
-  | Ok res ->
-      Lwt.return res
-  | Error exns ->
-      pp_print_error Format.err_formatter exns ;
-      cctxt.Client_commands.error "%s" "cannot continue"
-
-let commands () =
   let open Clic in
   let group = {name = "demo" ; title = "Some demo command" } in
   [
     command ~group ~desc: "A demo command"
       no_options
       (fixed [ "demo" ])
-      (fun () cctxt -> demo cctxt) ;
+      (fun () (cctxt : full) -> demo cctxt) ;
     command ~group ~desc: "A failing command"
       no_options
       (fixed [ "fail" ])
-      (fun () _cctxt ->
+      (fun () (cctxt : full) -> error cctxt) ;
-         Error.demo_error 101010
-         >|= Environment.wrap_error) ;
     command ~group ~desc: "Bake an empty block"
       no_options
       (fixed [ "bake" ])
@@ -102,5 +72,6 @@ let commands () =
   ]
 
 let () =
-  Client_commands.register protocol @@
+  Client_commands.register protocol @@ fun _network ->
+  List.map (Clic.map_command (new wrap_full)) @@
   commands ()

src/proto_demo/lib_client/client_proto_rpcs.ml

@@ -1,36 +0,0 @@
-(*****************************************************************************)
-(*                                                                           *)
-(* Open Source License                                                       *)
-(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
-(*                                                                           *)
-(* Permission is hereby granted, free of charge, to any person obtaining a   *)
-(* copy of this software and associated documentation files (the "Software"),*)
-(* to deal in the Software without restriction, including without limitation *)
-(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
-(* and/or sell copies of the Software, and to permit persons to whom the     *)
-(* Software is furnished to do so, subject to the following conditions:      *)
-(*                                                                           *)
-(* The above copyright notice and this permission notice shall be included   *)
-(* in all copies or substantial portions of the Software.                    *)
-(*                                                                           *)
-(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
-(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
-(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
-(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
-(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
-(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
-(* DEALINGS IN THE SOFTWARE.                                                 *)
-(*                                                                           *)
-(*****************************************************************************)
-
-let call_service1 cctxt s block a1 =
-  Client_rpcs.call_service1 cctxt
-    (s Block_services.proto_path) block a1
-let call_error_service1 cctxt s block a1 =
-  call_service1 cctxt s block a1 >>= function
-  | Ok (Error _ as err) -> Lwt.return (Environment.wrap_error err)
-  | Ok (Ok v) -> return v
-  | Error _ as err -> Lwt.return err
-
-let echo cctxt = call_service1 cctxt Services.echo_service
-let failing cctxt = call_error_service1 cctxt Services.failing_service

src/proto_demo/lib_client/dune

@@ -0,0 +1,21 @@
+(library
+ (name tezos_client_demo)
+ (public_name tezos-client-demo)
+ (libraries tezos-base
+            tezos-shell-services
+            tezos-client-base
+            tezos-client-commands
+            tezos-protocol-environment
+            tezos-protocol-demo)
+ (library_flags (:standard -linkall))
+ (flags (:standard -w -9+27-30-32-40@8
+                   -safe-string
+                   -open Tezos_base__TzPervasives
+                   -open Tezos_shell_services
+                   -open Tezos_client_base
+                   -open Tezos_client_commands)))
+
+(alias
+ (name runtest_indent)
+ (deps (glob_files *.ml{,i}))
+ (action (run bash %{libexec:tezos-stdlib:test-ocp-indent.sh} %{deps})))

src/proto_demo/lib_client/proto_demo.ml

@@ -24,5 +24,24 @@
 (*****************************************************************************)
 
 module Name = struct let name = "demo" end
-module Environment = Tezos_client_environment.Environment.Make(Name)()
+module Demo_environment = Tezos_protocol_environment_faked.MakeV1(Name)()
-include Tezos_protocol_demo.Functor.Make(Environment)
+module Proto = Tezos_protocol_demo.Functor.Make(Demo_environment)
+module Demo_block_services = Block_services.Make(Proto)(Proto)
+include Proto
+
+class type rpc_context = object
+  inherit RPC_context.json
+  inherit [Shell_services.chain * Shell_services.block] Demo_environment.RPC_context.simple
+end
+
+class type full = object
+  inherit Client_context.full
+  inherit [Shell_services.chain * Shell_services.block] Demo_environment.RPC_context.simple
+end
+
+class wrap_full (t : Client_context.full) : full = object
+  inherit Client_context.proxy_context t
+  inherit [Shell_services.chain, Shell_services.block] Demo_environment.proto_rpc_context
+      (t :> RPC_context.t)
+      Shell_services.Blocks.path
+end

src/proto_demo/lib_client/tezos-client-demo.opam

@@ -0,0 +1,24 @@
+opam-version: "1.2"
+version: "dev"
+maintainer: "contact@tezos.com"
+authors: [ "Tezos devteam" ]
+homepage: "https://www.tezos.com/"
+bug-reports: "https://gitlab.com/tezos/tezos/issues"
+dev-repo: "https://gitlab.com/tezos/tezos.git"
+license: "MIT"
+depends: [
+  "ocamlfind" { build }
+  "dune" { build & >= "1.0.1" }
+  "tezos-base"
+  "tezos-shell-services"
+  "tezos-client-base"
+  "tezos-client-commands"
+  "tezos-protocol-environment"
+  "tezos-protocol-genesis"
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "dune" "runtest" "-p" name "-j" jobs ]
+]

src/proto_demo/lib_protocol/src/main.ml

@@ -62,48 +62,19 @@ let compare_operations _ _ = 0
 
 type validation_state = {
   context : Context.t ;
-  fitness : Int64.t ;
+  fitness : Fitness.t ;
 }
 
 let current_context { context ; _ } =
   return context
 
-module Fitness = struct
-
-  type error += Invalid_fitness
-  type error += Invalid_fitness2
-
-  let int64_to_bytes i =
-    let b = MBytes.create 8 in
-    MBytes.set_int64 b 0 i;
-    b
-
-  let int64_of_bytes b =
-    if Compare.Int.(MBytes.length b <> 8) then
-      fail Invalid_fitness2
-    else
-      return (MBytes.get_int64 b 0)
-
-  let from_int64 fitness =
-    [ int64_to_bytes fitness ]
-
-  let to_int64 = function
-    | [ fitness ] -> int64_of_bytes fitness
-    | [] -> return 0L
-    | _ -> fail Invalid_fitness
-
-  let get { fitness ; _ } = fitness
-
-end
-
 let begin_application
     ~chain_id:_
     ~predecessor_context:context
     ~predecessor_timestamp:_
     ~predecessor_fitness:_
     (raw_block: block_header) =
-  Fitness.to_int64 raw_block.shell.fitness >>=? fun fitness ->
+  return { context ; fitness = raw_block.shell.fitness }
-  return { context ; fitness }
 
 let begin_partial_application
     ~chain_id
@@ -127,26 +98,34 @@ let begin_construction
     ~predecessor:_
     ~timestamp:_
     ?protocol_data:_ () =
-  Fitness.to_int64 pred_fitness >>=? fun pred_fitness ->
+
-  let fitness = Int64.succ pred_fitness in
+  let increase_fitness = function
+    | [ v ; b ] ->
+        let f = MBytes.get_int64 b 0 in
+        let b' = MBytes.copy b in
+        MBytes.set_int64 b' 0 (Int64.succ f) ;
+        return [ v ;  b' ]
+    | [ ] -> return MBytes.[create 0; create 0]
+    | _ -> assert false
+  in
+  increase_fitness pred_fitness >>=? fun fitness ->
   return { context ; fitness }
 
 let apply_operation ctxt _ =
   return (ctxt, ())
 
 let finalize_block ctxt =
-  let fitness = Fitness.get ctxt in
+  let fitness = ctxt.fitness in
-  let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
+  let message = Some (Format.asprintf "fitness <- %a" Fitness.pp fitness) in
-  let fitness = Fitness.from_int64 fitness in
   return ({ Updater.message ; context = ctxt.context ; fitness ;
             max_operations_ttl = 0 ; last_allowed_fork_level = 0l ;
           }, ())
 
-let rpc_services = Services.rpc_services
-
 let init context block_header =
   return { Updater.message = None ; context ;
            fitness = block_header.Block_header.fitness ;
            max_operations_ttl = 0 ;
            last_allowed_fork_level = block_header.level ;
          }
+
+let rpc_services = Services.rpc_services

src/proto_demo/lib_protocol/src/services.ml

@@ -23,34 +23,46 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-let echo_service custom_root =
+module S = struct
+
+  let path = RPC_path.open_root
+
+  let echo_service =
     RPC_service.post_service
-    ~description: "An dummy echo service"
+      ~description: "A dummy echo service"
       ~query: RPC_query.empty
       ~input: Data_encoding.(obj1 (req "msg" string))
       ~output: Data_encoding.(obj1 (req "msg" string))
-    RPC_path.(custom_root / "echo")
+      RPC_path.(path / "echo")
 
-let failing_service custom_root =
+  let failing_service =
     RPC_service.post_service
       ~description: "A failing service"
       ~query: RPC_query.empty
       ~input: Data_encoding.(obj1 (req "arg" int31))
       ~output: Data_encoding.empty
-    RPC_path.(custom_root / "failing")
+      RPC_path.(path / "failing")
+
+end
+
+let echo ctxt block msg =
+  RPC_context.make_call0 S.echo_service ctxt block () msg
+
+let failing ctxt block n =
+  RPC_context.make_call0 S.failing_service ctxt block () n
 
 let rpc_services : Updater.rpc_context RPC_directory.t =
   let dir = RPC_directory.empty in
   let dir =
     RPC_directory.register
       dir
-      (failing_service RPC_path.open_root)
+      S.failing_service
       (fun _ctxt () x -> Error.demo_error x)
   in
   let dir =
     RPC_directory.register
       dir
-      (echo_service RPC_path.open_root)
+      S.echo_service
       (fun _ctxt () x -> return x)
   in
   dir

src/proto_demo/lib_protocol/src/services.mli

@@ -23,11 +23,10 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-open Shell_services
+val failing:
+  'a #RPC_context.simple -> 'a -> int -> unit shell_tzresult Lwt.t
 
 val echo :
-  Client_rpcs.config ->
+  'a #RPC_context.simple -> 'a -> string -> string shell_tzresult Lwt.t
-  Blocks.block -> string -> string tzresult Lwt.t
+
-val failing:
+val rpc_services : Updater.rpc_context RPC_directory.t
-  Client_rpcs.config ->
-  Blocks.block -> int -> unit tzresult Lwt.t