diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.ml b/src/proto_alpha/lib_delegate/client_baking_blocks.ml index c4698d503..362ddae0f 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.ml @@ -18,58 +18,62 @@ type block_info = { timestamp: Time.t ; protocol: Protocol_hash.t ; next_protocol: Protocol_hash.t ; - level: Level.t ; + level: Raw_level.t ; } -let raw_info cctxt ?(chain = `Main) hash header = +let raw_info cctxt ?(chain = `Main) hash shell_header = let block = `Hash (hash, 0) in Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> Shell_services.Blocks.protocols cctxt ~chain ~block () >>=? fun { current_protocol = protocol ; next_protocol } -> - Alpha_block_services.metadata cctxt - ~chain ~block () >>=? fun { protocol_data = { level } } -> - let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; _ } = - header.Tezos_base.Block_header.shell in - return { hash ; chain_id ; predecessor ; fitness ; - timestamp ; protocol ; next_protocol ; level } + let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; level ; _ } = + shell_header in + match Raw_level.of_int32 level with + | Ok level -> + return { hash ; chain_id ; predecessor ; fitness ; + timestamp ; protocol ; next_protocol ; level } + | Error _ -> + failwith "Cannot convert level into int32" let info cctxt ?(chain = `Main) block = Shell_services.Blocks.hash cctxt ~chain ~block () >>=? fun hash -> Shell_services.Blocks.Header.shell_header - cctxt ~chain ~block () >>=? fun shell -> - Shell_services.Blocks.Header.raw_protocol_data - cctxt ~chain ~block () >>=? fun protocol_data -> - raw_info cctxt ~chain hash { shell ; protocol_data } + cctxt ~chain ~block () >>=? fun shell_header -> + raw_info cctxt ~chain hash shell_header 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), header) -> - raw_info cctxt ~chain:(`Hash chain) block header) + (fun ((chain, block), { Tezos_base.Block_header.shell }) -> + raw_info cctxt ~chain:(`Hash chain) block shell) block_stream) let monitor_heads cctxt ?next_protocols chain = Monitor_services.heads cctxt ?next_protocols chain >>=? fun (block_stream, _stop) -> return (Lwt_stream.map_s - (fun (block, header) -> raw_info cctxt ~chain block header) + (fun (block, { Tezos_base.Block_header.shell }) -> raw_info cctxt ~chain block shell) block_stream) let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = Shell_services.Blocks.hash cctxt ~chain ~block () >>=? fun hash -> - Alpha_block_services.metadata - cctxt ~chain ~block () >>=? fun { protocol_data = { level } } -> + Shell_services.Blocks.Header.shell_header + cctxt ~chain ~block () >>=? fun { level } -> Alpha_services.Helpers.levels_in_current_cycle - cctxt ~offset (chain, block) >>=? fun (first, last) -> - let length = Int32.to_int (Raw_level.diff level.level first) in - Shell_services.Blocks.list cctxt ~heads:[hash] ~length () >>=? fun blocks -> - let blocks = - List.remove - (length - (Int32.to_int (Raw_level.diff last first))) - (List.hd blocks) in - if Raw_level.(level.level = last) then - return (hash :: blocks) - else - return blocks + cctxt ~offset (chain, block) >>= function + | Error [RPC_context.Not_found _] -> + return [] + | Error _ as err -> Lwt.return err + | Ok (first, last) -> + let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in + Shell_services.Blocks.list cctxt ~heads:[hash] ~length () >>=? fun blocks -> + let blocks = + List.remove + (length - (Int32.to_int (Raw_level.diff last first))) + (List.hd blocks) in + if Int32.equal level (Raw_level.to_int32 last) then + return (hash :: blocks) + else + return blocks diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.mli b/src/proto_alpha/lib_delegate/client_baking_blocks.mli index e8f9aba04..a342e7ce8 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.mli +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.mli @@ -18,7 +18,7 @@ type block_info = { timestamp: Time.t ; protocol: Protocol_hash.t ; next_protocol: Protocol_hash.t ; - level: Level.t ; + level: Raw_level.t ; } val info: diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index 885e3f571..535fa50fa 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -166,7 +166,7 @@ let get_delegates cctxt state = let endorse_for_delegate cctxt { delegate ; block ; slots ; } = let hash = block.hash in let b = `Hash (hash, 0) in - let level = block.level.level in + let level = block.level in Client_keys.get_key cctxt delegate >>=? fun (name, _pk, sk) -> lwt_debug "Endorsing %a for %s (level %a using %d slots)!" Block_hash.pp_short hash name @@ -215,7 +215,7 @@ let allowed_to_endorse cctxt state (block: Client_baking_blocks.block_info) dele lwt_log_info "Checking if allowed to endorse block %a for %s" Block_hash.pp_short block.hash name >>= fun () -> let b = `Hash (block.hash, 0) in - let level = block.level.level in + let level = block.level in get_signing_slots cctxt b delegate level >>=? fun slots -> lwt_debug "Found slots for %a/%s (%d)" Block_hash.pp_short block.hash name (List.length slots) >>= fun () -> diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index da7ab4638..69ca1c21e 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -335,7 +335,7 @@ 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 + let level = Raw_level.succ bi.level in Alpha_services.Delegate.Baking_rights.get cctxt ?max_priority ~levels:[level] @@ -389,24 +389,13 @@ let drop_old_slots ~before state = (fun (t, _slot) -> Time.compare before t <= 0) state.future_slots -let compute_timeout time = - let delay = Time.diff time (Time.now ()) in - if delay < 0L then - None - else - Some (Lwt_unix.sleep (Int64.to_float delay)) - let compute_timeout { future_slots } = match future_slots with | [] -> (* No slots, just wait for new blocks which will give more info *) Lwt_utils.never_ending | (timestamp, _) :: _ -> -<<<<<<< b5e65a0d6c1a7a6a1d78fa8c73a36fdda43fc8c1 match Client_baking_scheduling.sleep_until timestamp with -======= - match compute_timeout timestamp with ->>>>>>> Alpha/Baker: keeping future slot for each delegate | None -> Lwt_utils.never_ending | Some timeout -> timeout @@ -486,13 +475,6 @@ let insert_block Time.pp_hum timestamp name Block_hash.pp_short bi.hash >>= fun () -> -<<<<<<< b5e65a0d6c1a7a6a1d78fa8c73a36fdda43fc8c1 - (* FIXME: the timestamp returned by [get_baking_slot] is always now. - This needs a proper fix, but in the meantime, we artifically - increase this time to be able to work on the rest of the code. *) - let slot = (Time.(max (add (now ()) 60L) (fst slot)), snd slot) in -======= ->>>>>>> Alpha/Baker: keeping future slot for each delegate state.future_slots <- insert_baking_slot slot state.future_slots ; return () ) @@ -609,7 +591,7 @@ let bake (cctxt : #Proto_alpha.full) state = match candidates with | (bi, priority, shell_header, operations, delegate, seed_nonce_hash) :: _ when fit_enough state shell_header -> begin - let level = Raw_level.succ bi.level.level in + let level = Raw_level.succ bi.level in cctxt#message "Select candidate block after %a (slot %d) fitness: %a" Block_hash.pp_short bi.hash priority @@ -721,20 +703,7 @@ let create ?max_priority (delegates: public_key_hash list) (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t) = -<<<<<<< b5e65a0d6c1a7a6a1d78fa8c73a36fdda43fc8c1 Client_baking_scheduling.wait_for_first_block ~info:cctxt#message block_stream (create cctxt ?max_priority delegates block_stream) -======= - let rec wait_for_first_block () = - Lwt_stream.get block_stream >>= function - | None | Some (Error _) -> - cctxt#message "Can't fetch the current block head. Retrying soon." >>= fun () -> - (* NOTE: this is not a tight loop because of Lwt_stream.get *) - wait_for_first_block () - | Some (Ok bi) -> - create cctxt ?max_priority delegates block_stream bi - in - wait_for_first_block () ->>>>>>> Alpha/Baker: keeping future slot for each delegate diff --git a/src/proto_alpha/lib_delegate/client_baking_lib.ml b/src/proto_alpha/lib_delegate/client_baking_lib.ml index c0e579c0d..4e77a1db2 100644 --- a/src/proto_alpha/lib_delegate/client_baking_lib.ml +++ b/src/proto_alpha/lib_delegate/client_baking_lib.ml @@ -93,7 +93,7 @@ let reveal_block_nonces (cctxt : #Proto_alpha.full) block_hashes = Block_hash.pp_short bi.hash >>= fun () -> return None | Some nonce -> - return (Some (bi.hash, (bi.level.level, nonce)))) + return (Some (bi.hash, (bi.level, nonce)))) block_infos >>=? fun blocks -> do_reveal cctxt cctxt#block blocks diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index d29ccc8e1..a98a3de7c 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -532,9 +532,12 @@ let register () = end ; register0 S.levels_in_current_cycle begin fun ctxt q () -> let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in - let first = List.hd (List.rev levels) in - let last = List.hd levels in - return (first.level, last.level) + match levels with + | [] -> raise Not_found + | _ -> + let first = List.hd (List.rev levels) in + let last = List.hd levels in + return (first.level, last.level) end let current_level ctxt ?(offset = 0l) block =