2018-06-04 14:35:06 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Copyright (c) 2014 - 2018. *)
|
|
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Proto_alpha
|
|
|
|
open Alpha_context
|
|
|
|
|
|
|
|
type t = {
|
|
|
|
predecessor: Block.t ;
|
|
|
|
state: M.validation_state ;
|
2018-06-07 12:47:20 +02:00
|
|
|
rev_operations: Operation.packed list ;
|
2018-06-04 14:35:06 +02:00
|
|
|
header: Block_header.t ;
|
|
|
|
delegate: Account.t ;
|
|
|
|
}
|
|
|
|
type incremental = t
|
|
|
|
|
|
|
|
let predecessor { predecessor ; _ } = predecessor
|
2018-05-22 16:58:14 +02:00
|
|
|
let header st = st.header
|
2018-06-04 14:35:06 +02:00
|
|
|
|
|
|
|
let level st = st.header.shell.level
|
|
|
|
|
|
|
|
let rpc_context st =
|
|
|
|
let result = Alpha_context.finalize st.state.ctxt in
|
2018-04-23 01:21:33 +02:00
|
|
|
{
|
2018-06-04 14:35:06 +02:00
|
|
|
Alpha_environment.Updater.block_hash = Block_hash.zero ;
|
2018-04-16 00:44:24 +02:00
|
|
|
block_header = { st.header.shell with fitness = result.fitness } ;
|
2018-06-04 14:35:06 +02:00
|
|
|
context = result.context ;
|
|
|
|
}
|
|
|
|
|
|
|
|
let rpc_ctxt =
|
|
|
|
new Alpha_environment.proto_rpc_context_of_directory
|
|
|
|
rpc_context Proto_alpha.rpc_services
|
|
|
|
|
|
|
|
let begin_construction ?(priority=0) ?timestamp (predecessor : Block.t) =
|
|
|
|
Block.get_next_baker ~policy:(Block.By_priority priority)
|
|
|
|
predecessor >>=? fun (delegate, priority, real_timestamp) ->
|
|
|
|
Account.find delegate >>=? fun delegate ->
|
|
|
|
let timestamp = Option.unopt ~default:real_timestamp timestamp in
|
|
|
|
let contents = Block.Forge.contents ~priority () in
|
|
|
|
let protocol_data = {
|
|
|
|
Block_header.contents ;
|
|
|
|
signature = Signature.zero ;
|
|
|
|
} in
|
|
|
|
let header = {
|
|
|
|
Block_header.shell = {
|
|
|
|
predecessor = predecessor.hash ;
|
|
|
|
proto_level = predecessor.header.shell.proto_level ;
|
|
|
|
validation_passes = predecessor.header.shell.validation_passes ;
|
|
|
|
fitness = predecessor.header.shell.fitness ;
|
|
|
|
timestamp ;
|
|
|
|
(* TODO : CHECK THAT OUT -- incoherent level *)
|
|
|
|
level = predecessor.header.shell.level ;
|
|
|
|
context = Context_hash.zero ;
|
|
|
|
operations_hash = Operation_list_list_hash.zero ;
|
|
|
|
} ;
|
|
|
|
protocol_data = {
|
|
|
|
contents ;
|
|
|
|
signature = Signature.zero ;
|
|
|
|
} ;
|
|
|
|
} in
|
|
|
|
M.begin_construction
|
|
|
|
~predecessor_context: predecessor.context
|
|
|
|
~predecessor_timestamp: predecessor.header.shell.timestamp
|
|
|
|
~predecessor_fitness: predecessor.header.shell.fitness
|
|
|
|
~predecessor_level: predecessor.header.shell.level
|
|
|
|
~predecessor:predecessor.hash
|
|
|
|
~timestamp
|
|
|
|
~protocol_data
|
|
|
|
() >>=? fun state ->
|
|
|
|
return {
|
|
|
|
predecessor ;
|
|
|
|
state ;
|
|
|
|
rev_operations = [] ;
|
|
|
|
header ;
|
|
|
|
delegate ;
|
|
|
|
}
|
|
|
|
|
2018-06-23 01:24:34 +02:00
|
|
|
let detect_script_failure :
|
|
|
|
type kind. kind Apply_operation_result.operation_metadata -> _ =
|
|
|
|
let rec detect_script_failure :
|
|
|
|
type kind. kind Apply_operation_result.contents_result_list -> _ =
|
|
|
|
let open Apply_operation_result in
|
|
|
|
let detect_script_failure_single
|
|
|
|
(type kind)
|
|
|
|
(Manager_operation_result { operation_result ;
|
|
|
|
internal_operation_results }
|
|
|
|
: kind Kind.manager Apply_operation_result.contents_result) =
|
|
|
|
let detect_script_failure (type kind) (result : kind manager_operation_result) =
|
|
|
|
match result with
|
|
|
|
| Applied _ -> Ok ()
|
|
|
|
| Skipped _ -> assert false
|
2018-06-26 18:04:19 +02:00
|
|
|
| Backtracked (_, None) ->
|
|
|
|
(* there must be another error for this to happen *)
|
|
|
|
Ok ()
|
|
|
|
| Backtracked (_, Some errs) ->
|
|
|
|
Alpha_environment.wrap_error (Error errs)
|
2018-06-23 01:24:34 +02:00
|
|
|
| Failed (_, errs) ->
|
2018-06-23 01:56:28 +02:00
|
|
|
Alpha_environment.wrap_error (Error errs) in
|
2018-06-23 01:24:34 +02:00
|
|
|
List.fold_left
|
|
|
|
(fun acc (Internal_operation_result (_, r)) ->
|
|
|
|
acc >>? fun () ->
|
|
|
|
detect_script_failure r)
|
|
|
|
(detect_script_failure operation_result)
|
|
|
|
internal_operation_results in
|
|
|
|
function
|
|
|
|
| Single_result (Manager_operation_result _ as res) ->
|
|
|
|
detect_script_failure_single res
|
|
|
|
| Single_result _ ->
|
|
|
|
Ok ()
|
|
|
|
| Cons_result (res, rest) ->
|
|
|
|
detect_script_failure_single res >>? fun () ->
|
|
|
|
detect_script_failure rest in
|
|
|
|
fun { contents } -> detect_script_failure contents
|
|
|
|
|
2018-06-23 01:56:28 +02:00
|
|
|
let add_operation ?expect_failure st op =
|
2018-06-23 01:24:34 +02:00
|
|
|
let open Apply_operation_result in
|
|
|
|
M.apply_operation st.state op >>=? function
|
|
|
|
| state, Operation_metadata result ->
|
2018-06-23 01:56:28 +02:00
|
|
|
Lwt.return @@ detect_script_failure result >>= fun result ->
|
|
|
|
begin match expect_failure with
|
|
|
|
| None ->
|
|
|
|
Lwt.return result
|
|
|
|
| Some f ->
|
|
|
|
match result with
|
|
|
|
| Ok _ ->
|
|
|
|
failwith "Error expected while adding operation"
|
|
|
|
| Error e ->
|
|
|
|
f e
|
2018-06-23 01:24:34 +02:00
|
|
|
end >>=? fun () ->
|
|
|
|
return { st with state ; rev_operations = op :: st.rev_operations }
|
|
|
|
| state, No_operation_metadata ->
|
|
|
|
return { st with state ; rev_operations = op :: st.rev_operations }
|
2018-06-04 14:35:06 +02:00
|
|
|
|
|
|
|
let finalize_block st =
|
|
|
|
M.finalize_block st.state >>=? fun (result, _) ->
|
|
|
|
let operations = List.rev st.rev_operations in
|
|
|
|
let operations_hash =
|
|
|
|
Operation_list_list_hash.compute [
|
2018-06-07 12:47:20 +02:00
|
|
|
Operation_list_hash.compute (List.map Operation.hash_packed operations)
|
2018-06-04 14:35:06 +02:00
|
|
|
] in
|
|
|
|
let header =
|
|
|
|
{ st.header with
|
|
|
|
shell = {
|
|
|
|
st.header.shell with
|
|
|
|
operations_hash ; fitness = result.fitness ;
|
|
|
|
} } in
|
|
|
|
let hash = Block_header.hash header in
|
|
|
|
return {
|
|
|
|
Block.hash ;
|
|
|
|
header ;
|
|
|
|
operations ;
|
|
|
|
context = result.context ;
|
|
|
|
}
|