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

@@ -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 <url>``.
+client using this command ``tezos-admin-client rpc (get|post) <url>``.
 
 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 :

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" },

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

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 ####################################################################

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

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

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
 

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

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

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

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

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

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

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)

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
+

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

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 () ->

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

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
-             "@[<v 2>Hash: %a\
-              @ Level: %ld\
-              @ Errors: @[<v>%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
+    "@[<v 2>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 "@[<v>%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
-           "@[<v 0>@{<title>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 ()) ;
   ]

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

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 =

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

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

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)
 

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
 

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

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

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
+

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

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

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

src/lib_shell/node_rpc.ml

@@ -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
-

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)

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
+

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

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

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

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

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) =

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
 

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

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

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))

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

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

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))))
 

src/lib_shell_services/mempool_services.ml

@@ -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  () () () 

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

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

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

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

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

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 ()

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

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 ()

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

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

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

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

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

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)

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

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

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

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

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
 

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

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

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

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
 

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

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 :

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

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

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

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 ;

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

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

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:

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  *)
 

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)
 

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

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

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 []

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