Baking: fix baking daemon error when run on genesis

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
+  let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; level ; _ } =
-    ~chain ~block () >>=? fun { protocol_data = { level } } ->
+    shell_header in
-  let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; _ } =
+  match Raw_level.of_int32 level with
-    header.Tezos_base.Block_header.shell in
+  | Ok level ->
-  return { hash ; chain_id ; predecessor ; fitness ;
+      return { hash ; chain_id ; predecessor ; fitness ;
-           timestamp ; protocol ; next_protocol ; level }
+               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  ->
+    cctxt ~chain ~block () >>=? fun shell_header  ->
-  Shell_services.Blocks.Header.raw_protocol_data
+  raw_info cctxt ~chain hash shell_header
-    cctxt ~chain ~block () >>=? fun protocol_data ->
-  raw_info cctxt ~chain hash { shell ; protocol_data }
 
 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) ->
+            (fun ((chain, block), { Tezos_base.Block_header.shell }) ->
-               raw_info cctxt ~chain:(`Hash chain) block header)
+               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
+  Shell_services.Blocks.Header.shell_header
-    cctxt ~chain ~block () >>=? fun { protocol_data = { level } } ->
+    cctxt ~chain ~block () >>=? fun { level } ->
   Alpha_services.Helpers.levels_in_current_cycle
-    cctxt ~offset (chain, block) >>=? fun (first, last) ->
+    cctxt ~offset (chain, block) >>= function
-  let length = Int32.to_int (Raw_level.diff level.level first) in
+  | Error [RPC_context.Not_found _] ->
-  Shell_services.Blocks.list cctxt ~heads:[hash] ~length () >>=? fun blocks ->
+      return []
-  let blocks =
+  | Error _ as err -> Lwt.return err
-    List.remove
+  | Ok (first, last) ->
-      (length - (Int32.to_int (Raw_level.diff last first)))
+      let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in
-      (List.hd blocks) in
+      Shell_services.Blocks.list cctxt ~heads:[hash] ~length () >>=? fun blocks ->
-  if Raw_level.(level.level = last) then
+      let blocks =
-    return (hash :: blocks)
+        List.remove
-  else
+          (length - (Int32.to_int (Raw_level.diff last first)))
-    return blocks
+          (List.hd blocks) in
+      if Int32.equal level (Raw_level.to_int32 last) then
+        return (hash :: blocks)
+      else
+        return blocks

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:

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

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

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
 

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
+    match levels with
-    let last = List.hd levels in
+    | [] -> raise Not_found
-    return (first.level, last.level)
+    | _ ->
+        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 =