balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'feature/move-to-carthage' into 'dev'

Browse Source 
[LIGO-460] carthage update

See merge request ligolang/ligo!414
This commit is contained in:
Rémi Lesenechal 2020-02-17 17:14:28 +00:00
commit 3a1cd0bc94
141 changed files with 23845 additions and 17412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/main/run/of_michelson.ml
View File

@ -97,7 +97,7 @@ let fetch_lambda_types (contract_ty:ex_ty) =
| _ -> simple_fail "failed to fetch lambda types"
let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : run_res result =
let open! Tezos_raw_protocol_005_PsBabyM1 in
let open! Tezos_raw_protocol_006_PsCARTHA in
let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in
let%bind input =
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
@ -127,7 +127,7 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi
| _ -> fail @@ Errors.unknown_failwith_type () )
let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result =
let open! Tezos_raw_protocol_005_PsBabyM1 in
let open! Tezos_raw_protocol_006_PsCARTHA in
let (Ex_ty exp_type') = exp_type in
let exp = Michelson.strip_annots exp in
let top_level = Script_ir_translator.Lambda

2
vendors/ligo-utils/memory-proto-alpha/dune vendored
View File

@ -3,6 +3,6 @@
(public_name tezos-memory-proto-alpha)
(libraries
tezos-protocol-environment
tezos-protocol-005-PsBabyM1
tezos-protocol-006-PsCARTHA
)
)

4
vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml vendored
View File

@ -1,9 +1,9 @@
module Name = struct let name = "alpha" end
module Alpha_environment = Tezos_protocol_005_PsBabyM1.Protocol.Environment
module Alpha_environment = Tezos_protocol_006_PsCARTHA.Protocol.Environment
type alpha_error = Alpha_environment.Error_monad.error
type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult
module Alpha_error_monad = Alpha_environment.Error_monad
module Proto = Tezos_protocol_005_PsBabyM1
module Proto = Tezos_protocol_006_PsCARTHA
include Proto

2
vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam vendored
View File

@ -10,7 +10,7 @@ bug-reports: "https://gitlab.com/ligolang/tezos/issues"
depends: [
"dune"
"tezos-protocol-environment"
"tezos-protocol-005-PsBabyM1"
"tezos-protocol-006-PsCARTHA"
]
build: [
["dune" "build" "-p" name]

4
vendors/ligo-utils/proto-alpha-utils/dune vendored
View File

@ -4,10 +4,10 @@
(libraries
tezos-error-monad
tezos-stdlib-unix
tezos-protocol-005-PsBabyM1-parameters
tezos-protocol-006-PsCARTHA-parameters
tezos-memory-proto-alpha
simple-utils
tezos-utils
)
(flags (:standard -open Simple_utils ))
(flags (:standard -open Simple_utils))
)

2
vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml vendored
View File

@ -105,7 +105,7 @@ module Context_init = struct
Pervasives.failwith "Must have one account with a roll to bake";
(* Check there is at least one roll *)
let constants : Constants_repr.parametric = Tezos_protocol_005_PsBabyM1_parameters.Default_parameters.constants_test in
let constants : Constants_repr.parametric = Tezos_protocol_006_PsCARTHA_parameters.Default_parameters.constants_test in
check_constants_consistency constants >>=? fun () ->
let hash =

2
vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam vendored
View File

@ -41,7 +41,7 @@ depends: [
"tezos-data-encoding"
"tezos-protocol-environment"
"tezos-protocol-alpha"
"tezos-protocol-005-PsBabyM1-parameters"
"tezos-protocol-006-PsCARTHA"
"michelson-parser"
"simple-utils"
"tezos-utils"

175
vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml vendored
View File

@ -25,90 +25,98 @@
open Protocol
let constants_mainnet = Constants_repr.{
preserved_cycles = 5 ;
blocks_per_cycle = 4096l ;
blocks_per_commitment = 32l ;
blocks_per_roll_snapshot = 256l ;
blocks_per_voting_period = 32768l ;
time_between_blocks =
List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ;
endorsers_per_block = 32 ;
hard_gas_limit_per_operation = Z.of_int 800_000 ;
hard_gas_limit_per_block = Z.of_int 8_000_000 ;
proof_of_work_threshold =
Int64.(sub (shift_left 1L 46) 1L) ;
tokens_per_roll = Tez_repr.(mul_exn one 8_000) ;
michelson_maximum_type_size = 1000 ;
seed_nonce_revelation_tip = begin
match Tez_repr.(one /? 8L) with
| Ok c -> c
| Error _ -> assert false
end ;
origination_size = 257 ;
block_security_deposit = Tez_repr.(mul_exn one 512) ;
endorsement_security_deposit = Tez_repr.(mul_exn one 64) ;
block_reward = Tez_repr.(mul_exn one 16) ;
endorsement_reward = Tez_repr.(mul_exn one 2) ;
hard_storage_limit_per_operation = Z.of_int 60_000 ;
cost_per_byte = Tez_repr.of_mutez_exn 1_000L ;
test_chain_duration = Int64.mul 32768L 60L ;
quorum_min = 20_00l ; (* quorum is in centile of a percentage *)
quorum_max = 70_00l ;
min_proposal_quorum = 5_00l ;
initial_endorsers = 24 ;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ;
let constants_mainnet =
Constants_repr.
{
preserved_cycles = 5;
blocks_per_cycle = 4096l;
blocks_per_commitment = 32l;
blocks_per_roll_snapshot = 256l;
blocks_per_voting_period = 32768l;
time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L];
endorsers_per_block = 32;
hard_gas_limit_per_operation = Z.of_int 1_040_000;
hard_gas_limit_per_block = Z.of_int 10_400_000;
proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L);
tokens_per_roll = Tez_repr.(mul_exn one 8_000);
michelson_maximum_type_size = 1000;
seed_nonce_revelation_tip =
(match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
origination_size = 257;
block_security_deposit = Tez_repr.(mul_exn one 512);
endorsement_security_deposit = Tez_repr.(mul_exn one 64);
baking_reward_per_endorsement =
Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 187_500L];
endorsement_reward =
Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 833_333L];
hard_storage_limit_per_operation = Z.of_int 60_000;
cost_per_byte = Tez_repr.of_mutez_exn 1_000L;
test_chain_duration = Int64.mul 32768L 60L;
quorum_min = 20_00l;
(* quorum is in centile of a percentage *)
quorum_max = 70_00l;
min_proposal_quorum = 5_00l;
initial_endorsers = 24;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L;
}
let constants_sandbox = Constants_repr.{
let constants_sandbox =
Constants_repr.
{
constants_mainnet with
preserved_cycles = 2 ;
blocks_per_cycle = 8l ;
blocks_per_commitment = 4l ;
blocks_per_roll_snapshot = 4l ;
blocks_per_voting_period = 64l ;
time_between_blocks =
List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ;
proof_of_work_threshold = Int64.of_int (-1) ;
initial_endorsers = 1 ;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ;
preserved_cycles = 2;
blocks_per_cycle = 8l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 4l;
blocks_per_voting_period = 64l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
initial_endorsers = 1;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
}
let constants_test = Constants_repr.{
let constants_test =
Constants_repr.
{
constants_mainnet with
blocks_per_cycle = 128l ;
blocks_per_commitment = 4l ;
blocks_per_roll_snapshot = 32l ;
blocks_per_voting_period = 256l ;
time_between_blocks =
List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ;
proof_of_work_threshold = Int64.of_int (-1) ;
initial_endorsers = 1 ;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ;
blocks_per_cycle = 128l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 32l;
blocks_per_voting_period = 256l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
initial_endorsers = 1;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
}
let bootstrap_accounts_strings = [
"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" ;
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" ;
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" ;
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" ;
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ;
]
let bootstrap_accounts_strings =
[ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]
let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L
let bootstrap_accounts = List.map (fun s ->
let bootstrap_accounts =
List.map
(fun s ->
let public_key = Signature.Public_key.of_b58check_exn s in
let public_key_hash = Signature.Public_key.hash public_key in
Parameters_repr.{
public_key_hash ;
public_key = Some public_key ;
amount = boostrap_balance ;
Parameters_repr.
{
public_key_hash;
public_key = Some public_key;
amount = boostrap_balance;
})
bootstrap_accounts_strings
(* TODO this could be generated from OCaml together with the faucet
for now these are harcoded values in the tests *)
let commitments =
let json_result = Data_encoding.Json.from_string {json|
let json_result =
Data_encoding.Json.from_string
{json|
[
[ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
[ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
@ -123,26 +131,27 @@ let commitments =
]|json}
in
match json_result with
| Error err -> raise (Failure err)
| Ok json -> Data_encoding.Json.destruct
(Data_encoding.list Commitment_repr.encoding) json
| Error err ->
raise (Failure err)
| Ok json ->
Data_encoding.Json.destruct
(Data_encoding.list Commitment_repr.encoding)
json
let make_bootstrap_account (pkh, pk, amount) =
Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount }
Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}
let parameters_of_constants
?(bootstrap_accounts = bootstrap_accounts)
?(bootstrap_contracts = [])
?(with_commitments = false)
constants =
let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
?(bootstrap_contracts = []) ?(with_commitments = false) constants =
let commitments = if with_commitments then commitments else [] in
Parameters_repr.{
bootstrap_accounts ;
bootstrap_contracts ;
commitments ;
constants ;
security_deposit_ramp_up_cycles = None ;
no_reward_cycles = None ;
Parameters_repr.
{
bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles = None;
no_reward_cycles = None;
}
let json_of_parameters parameters =

17
vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli vendored
View File

@ -25,18 +25,21 @@
open Protocol
val constants_mainnet: Constants_repr.parametric
val constants_sandbox: Constants_repr.parametric
val constants_test: Constants_repr.parametric
val constants_mainnet : Constants_repr.parametric
val make_bootstrap_account:
val constants_sandbox : Constants_repr.parametric
val constants_test : Constants_repr.parametric
val make_bootstrap_account :
Signature.public_key_hash * Signature.public_key * Tez_repr.t ->
Parameters_repr.bootstrap_account
val parameters_of_constants:
val parameters_of_constants :
?bootstrap_accounts:Parameters_repr.bootstrap_account list ->
?bootstrap_contracts:Parameters_repr.bootstrap_contract list ->
?with_commitments:bool ->
Constants_repr.parametric -> Parameters_repr.t
Constants_repr.parametric ->
Parameters_repr.t
val json_of_parameters: Parameters_repr.t -> Data_encoding.json
val json_of_parameters : Parameters_repr.t -> Data_encoding.json

12
vendors/ligo-utils/tezos-protocol-alpha-parameters/dune vendored
View File

@ -1,22 +1,22 @@
(library
(name tezos_protocol_005_PsBabyM1_parameters)
(public_name tezos-protocol-005-PsBabyM1-parameters)
(name tezos_protocol_006_PsCARTHA_parameters)
(public_name tezos-protocol-006-PsCARTHA-parameters)
(modules :standard \ gen)
(libraries tezos-base
tezos-protocol-environment
tezos-protocol-005-PsBabyM1)
tezos-protocol-006-PsCARTHA)
(flags (:standard -open Tezos_base__TzPervasives
-open Tezos_protocol_005_PsBabyM1
-open Tezos_protocol_006_PsCARTHA
-linkall))
)
(executable
(name gen)
(libraries tezos-base
tezos-protocol-005-PsBabyM1-parameters)
tezos-protocol-006-PsCARTHA-parameters)
(modules gen)
(flags (:standard -open Tezos_base__TzPervasives
-open Tezos_protocol_005_PsBabyM1_parameters
-open Tezos_protocol_006_PsCARTHA_parameters
-linkall)))
(rule

2
vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project vendored
View File

@ -1,2 +1,2 @@
(lang dune 1.11)
(name tezos-protocol-005-PsBabyM1-parameters)
(name tezos-protocol-006-PsCARTHA-parameters)

26
vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml vendored
View File

@ -29,18 +29,19 @@
let () =
let print_usage_and_fail s =
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]"
Sys.argv.(0) ;
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
raise (Invalid_argument s)
in
let dump parameters file =
let str = Data_encoding.Json.to_string
(Default_parameters.json_of_parameters parameters) in
let fd = open_out file in
output_string fd str ;
close_out fd
let str =
Data_encoding.Json.to_string
(Default_parameters.json_of_parameters parameters)
in
if Array.length Sys.argv < 2 then print_usage_and_fail "" else
let fd = open_out file in
output_string fd str ; close_out fd
in
if Array.length Sys.argv < 2 then print_usage_and_fail ""
else
match Sys.argv.(1) with
| "--sandbox" ->
dump
@ -48,10 +49,13 @@ let () =
"sandbox-parameters.json"
| "--test" ->
dump
Default_parameters.(parameters_of_constants ~with_commitments:true constants_sandbox)
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_sandbox)
"test-parameters.json"
| "--mainnet" ->
dump
Default_parameters.(parameters_of_constants ~with_commitments:true constants_mainnet)
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_mainnet)
"mainnet-parameters.json"
| s -> print_usage_and_fail s
| s ->
print_usage_and_fail s

7
vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam → vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-006-PsCARTHA-parameters.opam vendored
View File

@ -8,12 +8,13 @@ license: "MIT"
depends: [
"tezos-tooling" { with-test }
"ocamlfind" { build }
"dune" { build & >= "1.7" }
"dune" { >= "1.7" }
"tezos-base"
"tezos-protocol-environment"
"tezos-protocol-005-PsBabyM1"
"tezos-protocol-006-PsCARTHA"
]
build: [
[ "dune" "build" "-p" name "-j" jobs ]
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "Tezos/Protocol: parameters"

2
vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL vendored
View File

@ -1,5 +1,5 @@
{
"hash": "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS",
"hash": "PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb",
"modules": [
"Misc",
"Storage_description",

123
vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml vendored
View File

@ -24,13 +24,17 @@
(*****************************************************************************)
type t = Raw_context.t
type context = t
module type BASIC_DATA = sig
type t
include Compare.S with type t := t
val encoding: t Data_encoding.t
val pp: Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end
module Tez = Tez_repr
@ -38,60 +42,76 @@ module Period = Period_repr
module Timestamp = struct
include Time_repr
let current = Raw_context.current_timestamp
end
include Operation_repr
module Operation = struct
type 'kind t = 'kind operation = {
shell: Operation.shell_header ;
protocol_data: 'kind protocol_data ;
shell : Operation.shell_header;
protocol_data : 'kind protocol_data;
}
type packed = packed_operation
let unsigned_encoding = unsigned_operation_encoding
include Operation_repr
end
module Block_header = Block_header_repr
module Vote = struct
include Vote_repr
include Vote_storage
end
module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr
module Script_timestamp = struct
include Script_timestamp_repr
let now ctxt =
let { Constants_repr.time_between_blocks ; _ } =
Raw_context.constants ctxt in
let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in
match time_between_blocks with
| [] -> failwith "Internal error: 'time_between_block' constants \
is an empty list."
| [] ->
failwith
"Internal error: 'time_between_block' constants is an empty list."
| first_delay :: _ ->
let current_timestamp = Raw_context.predecessor_timestamp ctxt in
Time.add current_timestamp (Period_repr.to_seconds first_delay)
|> Timestamp.to_seconds
|> of_int64
|> Timestamp.to_seconds |> of_int64
end
module Script = struct
include Michelson_v1_primitives
include Script_repr
let force_decode ctxt lexpr =
Lwt.return
(Script_repr.force_decode lexpr >>? fun (v, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(v, ctxt))
( Script_repr.force_decode lexpr
>>? fun (v, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) )
let force_bytes ctxt lexpr =
Lwt.return
(Script_repr.force_bytes lexpr >>? fun (b, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(b, ctxt))
( Script_repr.force_bytes lexpr
>>? fun (b, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) )
module Legacy_support = Legacy_script_support_repr
end
module Fees = Fees_storage
type public_key = Signature.Public_key.t
type public_key_hash = Signature.Public_key_hash.t
type signature = Signature.t
module Constants = struct
@ -103,66 +123,95 @@ module Voting_period = Voting_period_repr
module Gas = struct
include Gas_limit_repr
type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high
let check_limit = Raw_context.check_gas_limit
let set_limit = Raw_context.set_gas_limit
let set_unlimited = Raw_context.set_gas_unlimited
let consume = Raw_context.consume_gas
let check_enough = Raw_context.check_enough_gas
let level = Raw_context.gas_level
let consumed = Raw_context.gas_consumed
let block_level = Raw_context.block_gas_level
end
module Level = struct
include Level_repr
include Level_storage
end
module Contract = struct
include Contract_repr
include Contract_storage
let originate c contract ~balance ~script ~delegate =
originate c contract ~balance ~script ~delegate
let init_origination_nonce = Raw_context.init_origination_nonce
let unset_origination_nonce = Raw_context.unset_origination_nonce
end
module Big_map = struct
type id = Z.t
let fresh = Storage.Big_map.Next.incr
let fresh_temporary = Raw_context.fresh_temporary_big_map
let mem c m k = Storage.Big_map.Contents.mem (c, m) k
let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k
let rpc_arg = Storage.Big_map.rpc_arg
let cleanup_temporary c =
Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c >>= fun c ->
Lwt.return (Raw_context.reset_temporary_big_map c)
Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c
>>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c)
let exists c id =
Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) >>=? fun c ->
Storage.Big_map.Key_type.get_option c id >>=? fun kt ->
Lwt.return
(Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
>>=? fun c ->
Storage.Big_map.Key_type.get_option c id
>>=? fun kt ->
match kt with
| None -> return (c, None)
| None ->
return (c, None)
| Some kt ->
Storage.Big_map.Value_type.get c id >>=? fun kv ->
return (c, Some (kt, kv))
Storage.Big_map.Value_type.get c id
>>=? fun kv -> return (c, Some (kt, kv))
end
module Delegate = Delegate_storage
module Roll = struct
include Roll_repr
include Roll_storage
end
module Nonce = Nonce_storage
module Seed = struct
include Seed_repr
include Seed_storage
end
module Fitness = struct
include Fitness_repr
include Fitness
type fitness = t
include Fitness_storage
type fitness = t
include Fitness_storage
end
module Bootstrap = Bootstrap_storage
@ -174,39 +223,57 @@ end
module Global = struct
let get_block_priority = Storage.Block_priority.get
let set_block_priority = Storage.Block_priority.set
end
let prepare_first_block = Init_storage.prepare_first_block
let prepare = Init_storage.prepare
let finalize ?commit_message:message c =
let fitness = Fitness.from_int64 (Fitness.current c) in
let context = Raw_context.recover c in
{ Updater.context ; fitness ; message ; max_operations_ttl = 60 ;
{
Updater.context;
fitness;
message;
max_operations_ttl = 60;
last_allowed_fork_level =
Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
}
let activate = Raw_context.activate
let fork_test_chain = Raw_context.fork_test_chain
let record_endorsement = Raw_context.record_endorsement
let allowed_endorsements = Raw_context.allowed_endorsements
let init_endorsements = Raw_context.init_endorsements
let included_endorsements = Raw_context.included_endorsements
let reset_internal_nonce = Raw_context.reset_internal_nonce
let fresh_internal_nonce = Raw_context.fresh_internal_nonce
let record_internal_nonce = Raw_context.record_internal_nonce
let internal_nonce_already_recorded = Raw_context.internal_nonce_already_recorded
let internal_nonce_already_recorded =
Raw_context.internal_nonce_already_recorded
let add_deposit = Raw_context.add_deposit
let add_fees = Raw_context.add_fees
let add_rewards = Raw_context.add_rewards
let get_deposits = Raw_context.get_deposits
let get_fees = Raw_context.get_fees
let get_rewards = Raw_context.get_rewards
let description = Raw_context.description

1308
vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli vendored
View File

File diff suppressed because it is too large Load Diff

68
vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml vendored
View File

@ -28,86 +28,76 @@ open Alpha_context
let custom_root = RPC_path.open_root
module Seed = struct
module S = struct
open Data_encoding
let seed =
RPC_service.post_service
~description: "Seed of the cycle to which the block belongs."
~query: RPC_query.empty
~input: empty
~output: Seed.seed_encoding
~description:"Seed of the cycle to which the block belongs."
~query:RPC_query.empty
~input:empty
~output:Seed.seed_encoding
RPC_path.(custom_root / "context" / "seed")
end
let () =
let open Services_registration in
register0 S.seed begin fun ctxt () () ->
register0 S.seed (fun ctxt () () ->
let l = Level.current ctxt in
Seed.for_cycle ctxt l.cycle
end
let get ctxt block =
RPC_context.make_call0 S.seed ctxt block () ()
Seed.for_cycle ctxt l.cycle)
let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()
end
module Nonce = struct
type info =
| Revealed of Nonce.t
| Missing of Nonce_hash.t
| Forgotten
type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten
let info_encoding =
let open Data_encoding in
union [
case (Tag 0)
union
[ case
(Tag 0)
~title:"Revealed"
(obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ;
case (Tag 1)
(fun nonce -> Revealed nonce);
case
(Tag 1)
~title:"Missing"
(obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce) ;
case (Tag 2)
(fun nonce -> Missing nonce);
case
(Tag 2)
~title:"Forgotten"
empty
(function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ;
]
(fun () -> Forgotten) ]
module S = struct
let get =
RPC_service.get_service
~description: "Info about the nonce of a previous block."
~query: RPC_query.empty
~output: info_encoding
~description:"Info about the nonce of a previous block."
~query:RPC_query.empty
~output:info_encoding
RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
end
let register () =
let open Services_registration in
register1 S.get begin fun ctxt raw_level () () ->
register1 S.get (fun ctxt raw_level () () ->
let level = Level.from_raw ctxt raw_level in
Nonce.get ctxt level >>= function
| Ok (Revealed nonce) -> return (Revealed nonce)
| Ok (Unrevealed { nonce_hash ; _ }) ->
Nonce.get ctxt level
>>= function
| Ok (Revealed nonce) ->
return (Revealed nonce)
| Ok (Unrevealed {nonce_hash; _}) ->
return (Missing nonce_hash)
| Error _ -> return Forgotten
end
| Error _ ->
return Forgotten)
let get ctxt block level =
RPC_context.make_call1 S.get ctxt block level () ()
end
module Contract = Contract_services

18
vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli vendored
View File

@ -26,22 +26,14 @@
open Alpha_context
module Seed : sig
val get: 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t
val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t
end
module Nonce : sig
type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten
type info =
| Revealed of Nonce.t
| Missing of Nonce_hash.t
| Forgotten
val get:
'a #RPC_context.simple ->
'a -> Raw_level.t -> info shell_tzresult Lwt.t
val get :
'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t
end
module Contract = Contract_services
@ -52,4 +44,4 @@ module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services
val register: unit -> unit
val register : unit -> unit

257
vendors/ligo-utils/tezos-protocol-alpha/amendment.ml vendored
View File

@ -29,29 +29,32 @@ open Alpha_context
Returns None in case of a tie, if proposal quorum is below required
minimum or if there are no proposals. *)
let select_winning_proposal ctxt =
Vote.get_proposals ctxt >>=? fun proposals ->
Vote.get_proposals ctxt
>>=? fun proposals ->
let merge proposal vote winners =
match winners with
| None -> Some ([proposal], vote)
| None ->
Some ([proposal], vote)
| Some (winners, winners_vote) as previous ->
if Compare.Int32.(vote = winners_vote) then
Some (proposal :: winners, winners_vote)
else if Compare.Int32.(vote > winners_vote) then
Some ([proposal], vote)
else
previous in
else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote)
else previous
in
match Protocol_hash.Map.fold merge proposals None with
| Some ([proposal], vote) ->
Vote.listing_size ctxt >>=? fun max_vote ->
Vote.listing_size ctxt
>>=? fun max_vote ->
let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
let min_vote_to_pass =
Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l in
if Compare.Int32.(vote >= min_vote_to_pass) then
return_some proposal
else
return_none
Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l
in
if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal
else return_none
| _ ->
return_none (* in case of a tie, let's do nothing. *)
return_none
(* in case of a tie, let's do nothing. *)
(** A proposal is approved if it has supermajority and the participation reaches
the current quorum.
@ -63,10 +66,14 @@ let select_winning_proposal ctxt =
The expected quorum is calculated using the last participation EMA, capped
by the min/max quorum protocol constants. *)
let check_approval_and_update_participation_ema ctxt =
Vote.get_ballots ctxt >>=? fun ballots ->
Vote.listing_size ctxt >>=? fun maximum_vote ->
Vote.get_participation_ema ctxt >>=? fun participation_ema ->
Vote.get_current_quorum ctxt >>=? fun expected_quorum ->
Vote.get_ballots ctxt
>>=? fun ballots ->
Vote.listing_size ctxt
>>=? fun maximum_vote ->
Vote.get_participation_ema ctxt
>>=? fun participation_ema ->
Vote.get_current_quorum ctxt
>>=? fun expected_quorum ->
(* Note overflows: considering a maximum of 8e8 tokens, with roll size as
small as 1e3, there is a maximum of 8e5 rolls and thus votes.
In 'participation' an Int64 is used because in the worst case 'all_votes is
@ -75,80 +82,96 @@ let check_approval_and_update_participation_ema ctxt =
let casted_votes = Int32.add ballots.yay ballots.nay in
let all_votes = Int32.add casted_votes ballots.pass in
let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
let participation = (* in centile of percentage *)
Int64.(to_int32
(div
(mul (of_int32 all_votes) 100_00L)
(of_int32 maximum_vote))) in
let outcome = Compare.Int32.(participation >= expected_quorum &&
ballots.yay >= supermajority) in
let participation =
(* in centile of percentage *)
Int64.(
to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote)))
in
let outcome =
Compare.Int32.(
participation >= expected_quorum && ballots.yay >= supermajority)
in
let new_participation_ema =
Int32.(div (add
(mul 8l participation_ema)
(mul 2l participation))
10l) in
Vote.set_participation_ema ctxt new_participation_ema >>=? fun ctxt ->
return (ctxt, outcome)
Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)
in
Vote.set_participation_ema ctxt new_participation_ema
>>=? fun ctxt -> return (ctxt, outcome)
(** Implements the state machine of the amendment procedure.
Note that [freeze_listings], that computes the vote weight of each delegate,
is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
Vote.get_current_period_kind ctxt >>=? function
| Proposal -> begin
select_winning_proposal ctxt >>=? fun proposal ->
Vote.clear_proposals ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
Vote.get_current_period_kind ctxt
>>=? function
| Proposal -> (
select_winning_proposal ctxt
>>=? fun proposal ->
Vote.clear_proposals ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
match proposal with
| None ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
return ctxt
Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt
| Some proposal ->
Vote.init_current_proposal ctxt proposal >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Testing_vote >>=? fun ctxt ->
return ctxt
end
Vote.init_current_proposal ctxt proposal
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Testing_vote
>>=? fun ctxt -> return ctxt )
| Testing_vote ->
check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) ->
Vote.clear_ballots ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
check_approval_and_update_participation_ema ctxt
>>=? fun (ctxt, approved) ->
Vote.clear_ballots ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
if approved then
let expiration = (* in two days maximum... *)
Time.add (Timestamp.current ctxt) (Constants.test_chain_duration ctxt) in
Vote.get_current_proposal ctxt >>=? fun proposal ->
fork_test_chain ctxt proposal expiration >>= fun ctxt ->
Vote.set_current_period_kind ctxt Testing >>=? fun ctxt ->
return ctxt
let expiration =
(* in two days maximum... *)
Time.add
(Timestamp.current ctxt)
(Constants.test_chain_duration ctxt)
in
Vote.get_current_proposal ctxt
>>=? fun proposal ->
fork_test_chain ctxt proposal expiration
>>= fun ctxt ->
Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt
else
Vote.clear_current_proposal ctxt >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt ->
return ctxt
Vote.clear_current_proposal ctxt
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
| Testing ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt ->
return ctxt
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Promotion_vote
>>=? fun ctxt -> return ctxt
| Promotion_vote ->
check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) ->
begin
if approved then
Vote.get_current_proposal ctxt >>=? fun proposal ->
activate ctxt proposal >>= fun ctxt ->
return ctxt
else
return ctxt
end >>=? fun ctxt ->
Vote.clear_ballots ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
Vote.clear_current_proposal ctxt >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt ->
return ctxt
check_approval_and_update_participation_ema ctxt
>>=? fun (ctxt, approved) ->
( if approved then
Vote.get_current_proposal ctxt
>>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt
else return ctxt )
>>=? fun ctxt ->
Vote.clear_ballots ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
Vote.clear_current_proposal ctxt
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
type error += (* `Branch *)
| Invalid_proposal
type error +=
| (* `Branch *)
Invalid_proposal
| Unexpected_proposal
| Unauthorized_proposal
| Too_many_proposals
@ -183,7 +206,8 @@ let () =
`Branch
~id:"unauthorized_proposal"
~title:"Unauthorized proposal"
~description:"The delegate provided for the proposal is not in the voting listings."
~description:
"The delegate provided for the proposal is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
empty
(function Unauthorized_proposal -> Some () | _ -> None)
@ -203,7 +227,8 @@ let () =
`Branch
~id:"unauthorized_ballot"
~title:"Unauthorized ballot"
~description:"The delegate provided for the ballot is not in the voting listings."
~description:
"The delegate provided for the ballot is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
empty
(function Unauthorized_ballot -> Some () | _ -> None)
@ -213,7 +238,8 @@ let () =
`Branch
~id:"too_many_proposals"
~title:"Too many proposals"
~description:"The delegate reached the maximum number of allowed proposals."
~description:
"The delegate reached the maximum number of allowed proposals."
~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
empty
(function Too_many_proposals -> Some () | _ -> None)
@ -231,60 +257,67 @@ let () =
(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
if Compare.Int.(n < 0) then assert false else
if Compare.Int.(n < 0) then assert false
else
match l with
| [] -> false
| [] ->
false
| _ :: rest ->
if Compare.Int.(n = 0) then true
else (* n > 0 *)
longer_than rest (n-1)
longer_than rest (n - 1)
let record_proposals ctxt delegate proposals =
begin match proposals with
| [] -> fail Empty_proposal
| _ :: _ -> return_unit
end >>=? fun () ->
Vote.get_current_period_kind ctxt >>=? function
(match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit)
>>=? fun () ->
Vote.get_current_period_kind ctxt
>>=? function
| Proposal ->
Vote.in_listings ctxt delegate >>= fun in_listings ->
Vote.in_listings ctxt delegate
>>= fun in_listings ->
if in_listings then
Vote.recorded_proposal_count_for_delegate ctxt delegate >>=? fun count ->
Vote.recorded_proposal_count_for_delegate ctxt delegate
>>=? fun count ->
fail_when
(longer_than proposals (Constants.max_proposals_per_delegate - count))
Too_many_proposals >>=? fun () ->
Too_many_proposals
>>=? fun () ->
fold_left_s
(fun ctxt proposal ->
Vote.record_proposal ctxt proposal delegate)
ctxt proposals >>=? fun ctxt ->
return ctxt
else
fail Unauthorized_proposal
(fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate)
ctxt
proposals
>>=? fun ctxt -> return ctxt
else fail Unauthorized_proposal
| Testing_vote | Testing | Promotion_vote ->
fail Unexpected_proposal
let record_ballot ctxt delegate proposal ballot =
Vote.get_current_period_kind ctxt >>=? function
Vote.get_current_period_kind ctxt
>>=? function
| Testing_vote | Promotion_vote ->
Vote.get_current_proposal ctxt >>=? fun current_proposal ->
fail_unless (Protocol_hash.equal proposal current_proposal)
Invalid_proposal >>=? fun () ->
Vote.has_recorded_ballot ctxt delegate >>= fun has_ballot ->
fail_when has_ballot Unauthorized_ballot >>=? fun () ->
Vote.in_listings ctxt delegate >>= fun in_listings ->
if in_listings then
Vote.record_ballot ctxt delegate ballot
else
fail Unauthorized_ballot
Vote.get_current_proposal ctxt
>>=? fun current_proposal ->
fail_unless
(Protocol_hash.equal proposal current_proposal)
Invalid_proposal
>>=? fun () ->
Vote.has_recorded_ballot ctxt delegate
>>= fun has_ballot ->
fail_when has_ballot Unauthorized_ballot
>>=? fun () ->
Vote.in_listings ctxt delegate
>>= fun in_listings ->
if in_listings then Vote.record_ballot ctxt delegate ballot
else fail Unauthorized_ballot
| Testing | Proposal ->
fail Unexpected_ballot
let last_of_a_voting_period ctxt l =
Compare.Int32.(Int32.succ l.Level.voting_period_position =
Constants.blocks_per_voting_period ctxt )
Compare.Int32.(
Int32.succ l.Level.voting_period_position
= Constants.blocks_per_voting_period ctxt)
let may_start_new_voting_period ctxt =
let level = Level.current ctxt in
if last_of_a_voting_period ctxt level then
start_new_voting_period ctxt
else
return ctxt
if last_of_a_voting_period ctxt level then start_new_voting_period ctxt
else return ctxt

20
vendors/ligo-utils/tezos-protocol-alpha/amendment.mli vendored
View File

@ -51,8 +51,7 @@ open Alpha_context
(** If at the end of a voting period, moves to the next one following
the state machine of the amendment procedure. *)
val may_start_new_voting_period:
context -> context tzresult Lwt.t
val may_start_new_voting_period : context -> context tzresult Lwt.t
type error +=
| Unexpected_proposal
@ -63,17 +62,14 @@ type error +=
(** Records a list of proposals for a delegate.
@raise Unexpected_proposal if [ctxt] is not in a proposal period.
@raise Unauthorized_proposal if [delegate] is not in the listing. *)
val record_proposals:
context ->
public_key_hash -> Protocol_hash.t list ->
context tzresult Lwt.t
val record_proposals :
context -> public_key_hash -> Protocol_hash.t list -> context tzresult Lwt.t
type error +=
| Invalid_proposal
| Unexpected_ballot
| Unauthorized_ballot
type error += Invalid_proposal | Unexpected_ballot | Unauthorized_ballot
val record_ballot:
val record_ballot :
context ->
public_key_hash -> Protocol_hash.t -> Vote.ballot ->
public_key_hash ->
Protocol_hash.t ->
Vote.ballot ->
context tzresult Lwt.t

1621
vendors/ligo-utils/tezos-protocol-alpha/apply.ml vendored
View File

File diff suppressed because it is too large Load Diff

1367
vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml vendored
View File

File diff suppressed because it is too large Load Diff

160
vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli vendored
View File

@ -31,9 +31,7 @@
open Alpha_context
(** Result of applying a {!Operation.t}. Follows the same structure. *)
type 'kind operation_metadata = {
contents: 'kind contents_result_list ;
}
type 'kind operation_metadata = {contents : 'kind contents_result_list}
and packed_operation_metadata =
| Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
@ -43,34 +41,43 @@ and packed_operation_metadata =
and 'kind contents_result_list =
| Single_result : 'kind contents_result -> 'kind contents_result_list
| Cons_result :
'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list ->
(('kind * 'rest) Kind.manager ) contents_result_list
'kind Kind.manager contents_result
* 'rest Kind.manager contents_result_list
-> ('kind * 'rest) Kind.manager contents_result_list
and packed_contents_result_list =
| Contents_result_list : 'kind contents_result_list -> packed_contents_result_list
| Contents_result_list :
'kind contents_result_list
-> packed_contents_result_list
(** Result of applying an {!Operation.contents}. Follows the same structure. *)
and 'kind contents_result =
| Endorsement_result :
{ balance_updates : Delegate.balance_updates ;
delegate : Signature.Public_key_hash.t ;
slots: int list ;
} -> Kind.endorsement contents_result
| Endorsement_result : {
balance_updates : Delegate.balance_updates;
delegate : Signature.Public_key_hash.t;
slots : int list;
}
-> Kind.endorsement contents_result
| Seed_nonce_revelation_result :
Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result
Delegate.balance_updates
-> Kind.seed_nonce_revelation contents_result
| Double_endorsement_evidence_result :
Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result
Delegate.balance_updates
-> Kind.double_endorsement_evidence contents_result
| Double_baking_evidence_result :
Delegate.balance_updates -> Kind.double_baking_evidence contents_result
Delegate.balance_updates
-> Kind.double_baking_evidence contents_result
| Activate_account_result :
Delegate.balance_updates -> Kind.activate_account contents_result
Delegate.balance_updates
-> Kind.activate_account contents_result
| Proposals_result : Kind.proposals contents_result
| Ballot_result : Kind.ballot contents_result
| Manager_operation_result :
{ balance_updates : Delegate.balance_updates ;
operation_result : 'kind manager_operation_result ;
internal_operation_results : packed_internal_operation_result list ;
} -> 'kind Kind.manager contents_result
| Manager_operation_result : {
balance_updates : Delegate.balance_updates;
operation_result : 'kind manager_operation_result;
internal_operation_results : packed_internal_operation_result list;
}
-> 'kind Kind.manager contents_result
and packed_contents_result =
| Contents_result : 'kind contents_result -> packed_contents_result
@ -79,90 +86,105 @@ and packed_contents_result =
always be at the tail, and after a single [Failed]. *)
and 'kind manager_operation_result =
| Applied of 'kind successful_manager_operation_result
| Backtracked of 'kind successful_manager_operation_result * error list option
| Backtracked of
'kind successful_manager_operation_result * error list option
| Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
| Skipped : 'kind Kind.manager -> 'kind manager_operation_result
(** Result of applying a {!manager_operation_content}, either internal
or external. *)
and _ successful_manager_operation_result =
| Reveal_result :
{ consumed_gas : Z.t
} -> Kind.reveal successful_manager_operation_result
| Transaction_result :
{ storage : Script.expr option ;
big_map_diff : Contract.big_map_diff option ;
balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
allocated_destination_contract : bool ;
} -> Kind.transaction successful_manager_operation_result
| Origination_result :
{ big_map_diff : Contract.big_map_diff option ;
balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
} -> Kind.origination successful_manager_operation_result
| Delegation_result :
{ consumed_gas : Z.t
} -> Kind.delegation successful_manager_operation_result
| Reveal_result : {
consumed_gas : Z.t;
}
-> Kind.reveal successful_manager_operation_result
| Transaction_result : {
storage : Script.expr option;
big_map_diff : Contract.big_map_diff option;
balance_updates : Delegate.balance_updates;
originated_contracts : Contract.t list;
consumed_gas : Z.t;
storage_size : Z.t;
paid_storage_size_diff : Z.t;
allocated_destination_contract : bool;
}
-> Kind.transaction successful_manager_operation_result
| Origination_result : {
big_map_diff : Contract.big_map_diff option;
balance_updates : Delegate.balance_updates;
originated_contracts : Contract.t list;
consumed_gas : Z.t;
storage_size : Z.t;
paid_storage_size_diff : Z.t;
}
-> Kind.origination successful_manager_operation_result
| Delegation_result : {
consumed_gas : Z.t;
}
-> Kind.delegation successful_manager_operation_result
and packed_successful_manager_operation_result =
| Successful_manager_result :
'kind successful_manager_operation_result -> packed_successful_manager_operation_result
'kind successful_manager_operation_result
-> packed_successful_manager_operation_result
and packed_internal_operation_result =
| Internal_operation_result :
'kind internal_operation * 'kind manager_operation_result ->
packed_internal_operation_result
'kind internal_operation * 'kind manager_operation_result
-> packed_internal_operation_result
(** Serializer for {!packed_operation_result}. *)
val operation_metadata_encoding : packed_operation_metadata Data_encoding.t
val operation_data_and_metadata_encoding
: (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t
val operation_data_and_metadata_encoding :
(Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t
type 'kind contents_and_result_list =
| Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list
| Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list
| Single_and_result :
'kind Alpha_context.contents * 'kind contents_result
-> 'kind contents_and_result_list
| Cons_and_result :
'kind Kind.manager Alpha_context.contents
* 'kind Kind.manager contents_result
* 'rest Kind.manager contents_and_result_list
-> ('kind * 'rest) Kind.manager contents_and_result_list
type packed_contents_and_result_list =
| Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list
| Contents_and_result_list :
'kind contents_and_result_list
-> packed_contents_and_result_list
val contents_and_result_list_encoding :
packed_contents_and_result_list Data_encoding.t
val pack_contents_list :
'kind contents_list -> 'kind contents_result_list ->
'kind contents_list ->
'kind contents_result_list ->
'kind contents_and_result_list
val unpack_contents_list :
'kind contents_and_result_list ->
'kind contents_list * 'kind contents_result_list
val to_list :
packed_contents_result_list -> packed_contents_result list
val to_list : packed_contents_result_list -> packed_contents_result list
val of_list :
packed_contents_result list -> packed_contents_result_list
val of_list : packed_contents_result list -> packed_contents_result_list
type ('a, 'b) eq = Eq : ('a, 'a) eq
val kind_equal_list :
'kind contents_list -> 'kind2 contents_result_list -> ('kind, 'kind2) eq option
'kind contents_list ->
'kind2 contents_result_list ->
('kind, 'kind2) eq option
type block_metadata = {
baker: Signature.Public_key_hash.t ;
level: Level.t ;
voting_period_kind: Voting_period.kind ;
nonce_hash: Nonce_hash.t option ;
consumed_gas: Z.t ;
deactivated: Signature.Public_key_hash.t list ;
balance_updates: Delegate.balance_updates ;
baker : Signature.Public_key_hash.t;
level : Level.t;
voting_period_kind : Voting_period.kind;
nonce_hash : Nonce_hash.t option;
consumed_gas : Z.t;
deactivated : Signature.Public_key_hash.t list;
balance_updates : Delegate.balance_updates;
}
val block_metadata_encoding: block_metadata Data_encoding.encoding
val block_metadata_encoding : block_metadata Data_encoding.encoding

325
vendors/ligo-utils/tezos-protocol-alpha/baking.ml vendored
View File

@ -23,15 +23,24 @@
(* *)
(*****************************************************************************)
open Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t
(* `Permanent *)
type error += Unexpected_endorsement (* `Permanent *)
type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *)
type error +=
| Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t
(* `Permanent *)
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
let () =
@ -39,14 +48,19 @@ let () =
`Permanent
~id:"baking.timestamp_too_early"
~title:"Block forged too early"
~description:"The block timestamp is before the first slot \
for this baker at this level"
~description:
"The block timestamp is before the first slot for this baker at this \
level"
~pp:(fun ppf (r, p) ->
Format.fprintf ppf "Block forged too early (%a is before %a)"
Time.pp_hum p Time.pp_hum r)
Data_encoding.(obj2
(req "minimum" Time.encoding)
(req "provided" Time.encoding))
Format.fprintf
ppf
"Block forged too early (%a is before %a)"
Time.pp_hum
p
Time.pp_hum
r)
Data_encoding.(
obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding))
(function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Timestamp_too_early (r, p)) ;
register_error_kind
@ -55,35 +69,36 @@ let () =
~title:"Invalid fitness gap"
~description:"The gap of fitness is out of bounds"
~pp:(fun ppf (m, g) ->
Format.fprintf ppf
"The gap of fitness %Ld is not between 0 and %Ld" g m)
Data_encoding.(obj2
(req "maximum" int64)
(req "provided" int64))
Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
(function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
(fun (m, g) -> Invalid_fitness_gap (m, g)) ;
register_error_kind
`Permanent
~id:"baking.invalid_block_signature"
~title:"Invalid block signature"
~description:
"A block was not signed with the expected private key."
~description:"A block was not signed with the expected private key."
~pp:(fun ppf (block, pkh) ->
Format.fprintf ppf "Invalid signature for block %a. Expected: %a."
Block_hash.pp_short block
Signature.Public_key_hash.pp_short pkh)
Data_encoding.(obj2
Format.fprintf
ppf
"Invalid signature for block %a. Expected: %a."
Block_hash.pp_short
block
Signature.Public_key_hash.pp_short
pkh)
Data_encoding.(
obj2
(req "block" Block_hash.encoding)
(req "expected" Signature.Public_key_hash.encoding))
(function Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
(fun (block, pkh) -> Invalid_block_signature (block, pkh));
(function
| Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
(fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
register_error_kind
`Permanent
~id:"baking.invalid_signature"
~title:"Invalid block signature"
~description:"The block's signature is invalid"
~pp:(fun ppf () ->
Format.fprintf ppf "Invalid block signature")
~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
Data_encoding.empty
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature) ;
@ -92,8 +107,7 @@ let () =
~id:"baking.insufficient_proof_of_work"
~title:"Insufficient block proof-of-work stamp"
~description:"The block's proof-of-work stamp is insufficient"
~pp:(fun ppf () ->
Format.fprintf ppf "Insufficient proof-of-work stamp")
~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
Data_encoding.empty
(function Invalid_stamp -> Some () | _ -> None)
(fun () -> Invalid_stamp) ;
@ -101,9 +115,11 @@ let () =
`Permanent
~id:"baking.unexpected_endorsement"
~title:"Endorsement from unexpected delegate"
~description:"The operation is signed by a delegate without endorsement rights."
~description:
"The operation is signed by a delegate without endorsement rights."
~pp:(fun ppf () ->
Format.fprintf ppf
Format.fprintf
ppf
"The endorsement is signed by a delegate without endorsement rights.")
Data_encoding.unit
(function Unexpected_endorsement -> Some () | _ -> None)
@ -112,20 +128,24 @@ let () =
let minimal_time c priority pred_timestamp =
let priority = Int32.of_int priority in
let rec cumsum_time_between_blocks acc durations p =
if Compare.Int32.(<=) p 0l then
ok acc
else match durations with
| [] -> cumsum_time_between_blocks acc [ Period.one_minute ] p
| [ last ] ->
Period.mult p last >>? fun period ->
Timestamp.(acc +? period)
if Compare.Int32.( <= ) p 0l then ok acc
else
match durations with
| [] ->
cumsum_time_between_blocks acc [Period.one_minute] p
| [last] ->
Period.mult p last >>? fun period -> Timestamp.(acc +? period)
| first :: durations ->
Timestamp.(acc +? first) >>? fun acc ->
Timestamp.(acc +? first)
>>? fun acc ->
let p = Int32.pred p in
cumsum_time_between_blocks acc durations p in
cumsum_time_between_blocks acc durations p
in
Lwt.return
(cumsum_time_between_blocks
pred_timestamp (Constants.time_between_blocks c) (Int32.succ priority))
pred_timestamp
(Constants.time_between_blocks c)
(Int32.succ priority))
let earlier_predecessor_timestamp ctxt level =
let current = Level.current ctxt in
@ -135,25 +155,29 @@ let earlier_predecessor_timestamp ctxt level =
if Compare.Int32.(gap < 1l) then
failwith "Baking.earlier_block_timestamp: past block."
else
Lwt.return (Period.mult (Int32.pred gap) step) >>=? fun delay ->
Lwt.return Timestamp.(current_timestamp +? delay) >>=? fun result ->
return result
Lwt.return (Period.mult (Int32.pred gap) step)
>>=? fun delay ->
Lwt.return Timestamp.(current_timestamp +? delay)
>>=? fun result -> return result
let check_timestamp c priority pred_timestamp =
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
minimal_time c priority pred_timestamp
>>=? fun minimal_time ->
let timestamp = Alpha_context.Timestamp.current c in
Lwt.return
(record_trace (Timestamp_too_early (minimal_time, timestamp))
(record_trace
(Timestamp_too_early (minimal_time, timestamp))
Timestamp.(timestamp -? minimal_time))
let check_baking_rights c { Block_header.priority ; _ }
pred_timestamp =
let check_baking_rights c {Block_header.priority; _} pred_timestamp =
let level = Level.current c in
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
check_timestamp c priority pred_timestamp >>=? fun block_delay ->
return (delegate, block_delay)
Roll.baking_rights_owner c level ~priority
>>=? fun delegate ->
check_timestamp c priority pred_timestamp
>>=? fun block_delay -> return (delegate, block_delay)
type error += Incorrect_priority (* `Permanent *)
type error += Incorrect_number_of_endorsements (* `Permanent *)
let () =
@ -169,8 +193,10 @@ let () =
(fun () -> Incorrect_priority)
let () =
let description = "The number of endorsements must be non-negative and \
at most the endosers_per_block constant." in
let description =
"The number of endorsements must be non-negative and at most the \
endosers_per_block constant."
in
register_error_kind
`Permanent
~id:"incorrect_number_of_endorsements"
@ -181,89 +207,109 @@ let () =
(function Incorrect_number_of_endorsements -> Some () | _ -> None)
(fun () -> Incorrect_number_of_endorsements)
let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
fail_unless Compare.Int.(prio >= 0) Incorrect_priority >>=? fun () ->
let max_endorsements = Constants.endorsers_per_block ctxt in
fail_unless Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
Incorrect_number_of_endorsements >>=? fun () ->
let prio_factor_denominator = Int64.(succ (of_int prio)) in
let endo_factor_numerator = Int64.of_int (8 + 2 * num_endo / max_endorsements) in
let endo_factor_denominator = 10L in
Lwt.return
Tez.(
Constants.block_reward ctxt *? endo_factor_numerator >>? fun val1 ->
val1 /? endo_factor_denominator >>? fun val2 ->
val2 /? prio_factor_denominator)
let rec reward_for_priority reward_per_prio prio =
match reward_per_prio with
| [] ->
(* Empty reward list in parameters means no rewards *)
Tez.zero
| [last] ->
last
| first :: rest ->
if Compare.Int.(prio <= 0) then first
else reward_for_priority rest (pred prio)
let endorsing_reward ctxt ~block_priority:prio n =
if Compare.Int.(prio >= 0)
then
Lwt.return
Tez.(Constants.endorsement_reward ctxt /? (Int64.(succ (of_int prio)))) >>=? fun tez ->
Lwt.return Tez.(tez *? Int64.of_int n)
else fail Incorrect_priority
let baking_reward ctxt ~block_priority ~included_endorsements =
fail_unless Compare.Int.(block_priority >= 0) Incorrect_priority
>>=? fun () ->
fail_unless
Compare.Int.(
included_endorsements >= 0
&& included_endorsements <= Constants.endorsers_per_block ctxt)
Incorrect_number_of_endorsements
>>=? fun () ->
let reward_per_endorsement =
reward_for_priority
(Constants.baking_reward_per_endorsement ctxt)
block_priority
in
Lwt.return Tez.(reward_per_endorsement *? Int64.of_int included_endorsements)
let endorsing_reward ctxt ~block_priority num_slots =
fail_unless Compare.Int.(block_priority >= 0) Incorrect_priority
>>=? fun () ->
let reward_per_endorsement =
reward_for_priority (Constants.endorsement_reward ctxt) block_priority
in
Lwt.return Tez.(reward_per_endorsement *? Int64.of_int num_slots)
let baking_priorities c level =
let rec f priority =
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
return (LCons (delegate, (fun () -> f (succ priority))))
Roll.baking_rights_owner c level ~priority
>>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority)))
in
f 0
let endorsement_rights c level =
let endorsement_rights ctxt level =
fold_left_s
(fun acc slot ->
Roll.endorsement_rights_owner c level ~slot >>=? fun pk ->
Roll.endorsement_rights_owner ctxt level ~slot
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
let right =
match Signature.Public_key_hash.Map.find_opt pkh acc with
| None -> (pk, [slot], false)
| Some (pk, slots, used) -> (pk, slot :: slots, used) in
| None ->
(pk, [slot], false)
| Some (pk, slots, used) ->
(pk, slot :: slots, used)
in
return (Signature.Public_key_hash.Map.add pkh right acc))
Signature.Public_key_hash.Map.empty
(0 --> (Constants.endorsers_per_block c - 1))
(0 --> (Constants.endorsers_per_block ctxt - 1))
let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) =
let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t)
=
let current_level = Level.current ctxt in
let Single (Endorsement { level ; _ }) = op.protocol_data.contents in
begin
if Raw_level.(succ level = current_level.level) then
let (Single (Endorsement {level; _})) = op.protocol_data.contents in
( if Raw_level.(succ level = current_level.level) then
return (Alpha_context.allowed_endorsements ctxt)
else
endorsement_rights ctxt (Level.from_raw ctxt level)
end >>=? fun endorsements ->
else endorsement_rights ctxt (Level.from_raw ctxt level) )
>>=? fun endorsements ->
match
Signature.Public_key_hash.Map.fold (* no find_first *)
(fun pkh (pk, slots, used) acc ->
match Operation.check_signature_sync pk chain_id op with
| Error _ -> acc
| Ok () -> Some (pkh, slots, used))
endorsements None
| Error _ ->
acc
| Ok () ->
Some (pkh, slots, used))
endorsements
None
with
| None -> fail Unexpected_endorsement
| Some v -> return v
| None ->
fail Unexpected_endorsement
| Some v ->
return v
let select_delegate delegate delegate_list max_priority =
let rec loop acc l n =
if Compare.Int.(n >= max_priority)
then return (List.rev acc)
if Compare.Int.(n >= max_priority) then return (List.rev acc)
else
let LCons (pk, t) = l in
let (LCons (pk, t)) = l in
let acc =
if Signature.Public_key_hash.equal delegate (Signature.Public_key.hash pk)
if
Signature.Public_key_hash.equal
delegate
(Signature.Public_key.hash pk)
then n :: acc
else acc in
t () >>=? fun t ->
loop acc t (succ n)
else acc
in
t () >>=? fun t -> loop acc t (succ n)
in
loop [] delegate_list 0
let first_baking_priorities
ctxt
?(max_priority = 32)
delegate level =
baking_priorities ctxt level >>=? fun delegate_list ->
select_delegate delegate delegate_list max_priority
let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
baking_priorities ctxt level
>>=? fun delegate_list -> select_delegate delegate delegate_list max_priority
let check_hash hash stamp_threshold =
let bytes = Block_hash.to_bytes hash in
@ -273,84 +319,89 @@ let check_hash hash stamp_threshold =
let check_header_proof_of_work_stamp shell contents stamp_threshold =
let hash =
Block_header.hash
{ shell ; protocol_data = { contents ; signature = Signature.zero } } in
{shell; protocol_data = {contents; signature = Signature.zero}}
in
check_hash hash stamp_threshold
let check_proof_of_work_stamp ctxt block =
let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
if check_header_proof_of_work_stamp
if
check_header_proof_of_work_stamp
block.Block_header.shell
block.protocol_data.contents
proof_of_work_threshold then
return_unit
else
fail Invalid_stamp
proof_of_work_threshold
then return_unit
else fail Invalid_stamp
let check_signature block chain_id key =
let check_signature key
{ Block_header.shell ; protocol_data = { contents ; signature } } =
{Block_header.shell; protocol_data = {contents; signature}} =
let unsigned_header =
Data_encoding.Binary.to_bytes_exn
Block_header.unsigned_encoding
(shell, contents) in
Signature.check ~watermark:(Block_header chain_id) key signature unsigned_header in
if check_signature key block then
return_unit
(shell, contents)
in
Signature.check
~watermark:(Block_header chain_id)
key
signature
unsigned_header
in
if check_signature key block then return_unit
else
fail (Invalid_block_signature (Block_header.hash block,
Signature.Public_key.hash key))
fail
(Invalid_block_signature
(Block_header.hash block, Signature.Public_key.hash key))
let max_fitness_gap _ctxt = 1L
let check_fitness_gap ctxt (block : Block_header.t) =
let current_fitness = Fitness.current ctxt in
Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness ->
Lwt.return (Fitness.to_int64 block.shell.fitness)
>>=? fun announced_fitness ->
let gap = Int64.sub announced_fitness current_fitness in
if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
else
return_unit
else return_unit
let last_of_a_cycle ctxt l =
Compare.Int32.(Int32.succ l.Level.cycle_position =
Constants.blocks_per_cycle ctxt)
Compare.Int32.(
Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt)
let dawn_of_a_new_cycle ctxt =
let level = Level.current ctxt in
if last_of_a_cycle ctxt level then
return_some level.cycle
else
return_none
if last_of_a_cycle ctxt level then return_some level.cycle else return_none
let minimum_allowed_endorsements ctxt ~block_delay =
let minimum = Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement =
Int64.to_int
(Period.to_seconds
(Constants.delay_per_missing_endorsement ctxt))
(Period.to_seconds (Constants.delay_per_missing_endorsement ctxt))
in
let reduced_time_constraint =
let delay = Int64.to_int (Period.to_seconds block_delay) in
if Compare.Int.(delay_per_missing_endorsement = 0) then
delay
else
delay / delay_per_missing_endorsement
if Compare.Int.(delay_per_missing_endorsement = 0) then delay
else delay / delay_per_missing_endorsement
in
Compare.Int.max 0 (minimum - reduced_time_constraint)
let minimal_valid_time ctxt ~priority ~endorsing_power =
let predecessor_timestamp = Timestamp.current ctxt in
minimal_time ctxt
priority predecessor_timestamp >>=? fun minimal_time ->
minimal_time ctxt priority predecessor_timestamp
>>=? fun minimal_time ->
let minimal_required_endorsements = Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement =
Constants.delay_per_missing_endorsement ctxt
in
let missing_endorsements =
Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) in
match Period.mult
Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
in
match
Period.mult
(Int32.of_int missing_endorsements)
delay_per_missing_endorsement with
delay_per_missing_endorsement
with
| Ok delay ->
return (Time.add minimal_time (Period.to_seconds delay))
| Error _ as err -> Lwt.return err
| Error _ as err ->
Lwt.return err

74
vendors/ligo-utils/tezos-protocol-alpha/baking.mli vendored
View File

@ -23,15 +23,24 @@
(* *)
(*****************************************************************************)
open Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t
(* `Permanent *)
type error +=
| Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t
(* `Permanent *)
type error += Unexpected_endorsement
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
(** [minimal_time ctxt priority pred_block_time] returns the minimal
@ -39,51 +48,56 @@ type error += Invalid_stamp (* `Permanent *)
after which a baker with priority [priority] is allowed to
bake. Fail with [Invalid_time_between_blocks_constant] if the minimal
time cannot be computed. *)
val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
val minimal_time : context -> int -> Time.t -> Time.t tzresult Lwt.t
(** [check_baking_rights ctxt block pred_timestamp] verifies that:
* the contract that owned the roll at cycle start has the block signer as delegate.
* the timestamp is coherent with the announced slot.
*)
val check_baking_rights:
context -> Block_header.contents -> Time.t ->
val check_baking_rights :
context ->
Block_header.contents ->
Time.t ->
(public_key * Period.t) tzresult Lwt.t
(** For a given level computes who has the right to
include an endorsement in the next block.
The result can be stored in Alpha_context.allowed_endorsements *)
val endorsement_rights:
val endorsement_rights :
context ->
Level.t ->
(public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t
(** Check that the operation was signed by a delegate allowed
to endorse at the level specified by the endorsement. *)
val check_endorsement_rights:
context -> Chain_id.t -> Kind.endorsement Operation.t ->
val check_endorsement_rights :
context ->
Chain_id.t ->
Kind.endorsement Operation.t ->
(public_key_hash * int list * bool) tzresult Lwt.t
(** Returns the baking reward calculated w.r.t a given priority [p] and a
number [e] of included endorsements as follows:
(block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block)
*)
val baking_reward: context ->
block_priority:int -> included_endorsements:int -> Tez.t tzresult Lwt.t
number [e] of included endorsements *)
val baking_reward :
context ->
block_priority:int ->
included_endorsements:int ->
Tez.t tzresult Lwt.t
(** Returns the endorsing reward calculated w.r.t a given priority. *)
val endorsing_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t
val endorsing_reward :
context -> block_priority:int -> int -> Tez.t tzresult Lwt.t
(** [baking_priorities ctxt level] is the lazy list of contract's
public key hashes that are allowed to bake for [level]. *)
val baking_priorities:
context -> Level.t -> public_key lazy_list
val baking_priorities : context -> Level.t -> public_key lazy_list
(** [first_baking_priorities ctxt ?max_priority contract_hash level]
is a list of priorities of max [?max_priority] elements, where the
delegate of [contract_hash] is allowed to bake for [level]. If
[?max_priority] is [None], a sensible number of priorities is
returned. *)
val first_baking_priorities:
val first_baking_priorities :
context ->
?max_priority:int ->
public_key_hash ->
@ -92,27 +106,28 @@ val first_baking_priorities:
(** [check_signature ctxt chain_id block id] check if the block is
signed with the given key, and belongs to the given [chain_id] *)
val check_signature: Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t
val check_signature :
Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t
(** Checks if the header that would be built from the given components
is valid for the given diffculty. The signature is not passed as it
is does not impact the proof-of-work stamp. The stamp is checked on
the hash of a block header whose signature has been zeroed-out. *)
val check_header_proof_of_work_stamp:
val check_header_proof_of_work_stamp :
Block_header.shell_header -> Block_header.contents -> int64 -> bool
(** verify if the proof of work stamp is valid *)
val check_proof_of_work_stamp:
val check_proof_of_work_stamp :
context -> Block_header.t -> unit tzresult Lwt.t
(** check if the gap between the fitness of the current context
and the given block is within the protocol parameters *)
val check_fitness_gap:
context -> Block_header.t -> unit tzresult Lwt.t
val check_fitness_gap : context -> Block_header.t -> unit tzresult Lwt.t
val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t
val dawn_of_a_new_cycle : context -> Cycle.t option tzresult Lwt.t
val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t
val earlier_predecessor_timestamp :
context -> Level.t -> Timestamp.t tzresult Lwt.t
(** Since Emmy+
@ -138,14 +153,11 @@ val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lw
time to bake at the block's priority (as returned by
`minimum_time`), it returns the minimum number of endorsements that
the block has to contain *)
val minimum_allowed_endorsements: context -> block_delay:Period.t -> int
val minimum_allowed_endorsements : context -> block_delay:Period.t -> int
(** This is the somehow the dual of the previous function. Given a
block priority and a number of endorsement slots (given by the
`endorsing_power` argument), it returns the minimum time at which
the next block can be baked. *)
val minimal_valid_time:
context ->
priority:int ->
endorsing_power: int ->
Time.t tzresult Lwt.t
val minimal_valid_time :
context -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t

14
vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml vendored
View File

@ -23,24 +23,30 @@
(* *)
(*****************************************************************************)
module H = Blake2B.Make(Base58)(struct
module H =
Blake2B.Make
(Base58)
(struct
let name = "Blinded public key hash"
let title = "A blinded public key hash"
let b58check_prefix = "\001\002\049\223"
let size = Some Ed25519.Public_key_hash.size
end)
include H
let () =
Base58.check_encoded_prefix b58check_encoding "btz1" 37
let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37
let of_ed25519_pkh activation_code pkh =
hash_bytes ~key:activation_code [ Ed25519.Public_key_hash.to_bytes pkh ]
hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]
type activation_code = MBytes.t
let activation_code_size = Ed25519.Public_key_hash.size
let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size
let activation_code_of_hex h =

2
vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli vendored
View File

@ -26,9 +26,11 @@
include S.HASH
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.t
type activation_code
val activation_code_encoding : activation_code Data_encoding.t
val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t

112
vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml vendored
View File

@ -25,114 +25,106 @@
(** Block header *)
type t = {
shell: Block_header.shell_header ;
protocol_data: protocol_data ;
}
type t = {shell : Block_header.shell_header; protocol_data : protocol_data}
and protocol_data = {
contents: contents ;
signature: Signature.t ;
}
and protocol_data = {contents : contents; signature : Signature.t}
and contents = {
priority: int ;
seed_nonce_hash: Nonce_hash.t option ;
proof_of_work_nonce: MBytes.t ;
priority : int;
seed_nonce_hash : Nonce_hash.t option;
proof_of_work_nonce : MBytes.t;
}
type block_header = t
type raw = Block_header.t
type shell_header = Block_header.shell_header
let raw_encoding = Block_header.encoding
let shell_header_encoding = Block_header.shell_header_encoding
let contents_encoding =
let open Data_encoding in
def "block_header.alpha.unsigned_contents" @@
conv
(fun { priority ; seed_nonce_hash ; proof_of_work_nonce } ->
def "block_header.alpha.unsigned_contents"
@@ conv
(fun {priority; seed_nonce_hash; proof_of_work_nonce} ->
(priority, proof_of_work_nonce, seed_nonce_hash))
(fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
{priority; seed_nonce_hash; proof_of_work_nonce})
(obj3
(req "priority" uint16)
(req "proof_of_work_nonce"
(req
"proof_of_work_nonce"
(Fixed.bytes Constants_repr.proof_of_work_nonce_size))
(opt "seed_nonce_hash" Nonce_hash.encoding))
let protocol_data_encoding =
let open Data_encoding in
def "block_header.alpha.signed_contents" @@
conv
(fun { contents ; signature } -> (contents, signature))
(fun (contents, signature) -> { contents ; signature })
def "block_header.alpha.signed_contents"
@@ conv
(fun {contents; signature} -> (contents, signature))
(fun (contents, signature) -> {contents; signature})
(merge_objs
contents_encoding
(obj1 (req "signature" Signature.encoding)))
let raw { shell ; protocol_data ; } =
let raw {shell; protocol_data} =
let protocol_data =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
protocol_data in
{ Block_header.shell ; protocol_data }
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
in
{Block_header.shell; protocol_data}
let unsigned_encoding =
let open Data_encoding in
merge_objs
Block_header.shell_header_encoding
contents_encoding
merge_objs Block_header.shell_header_encoding contents_encoding
let encoding =
let open Data_encoding in
def "block_header.alpha.full_header" @@
conv
(fun { shell ; protocol_data } ->
(shell, protocol_data))
(fun (shell, protocol_data) ->
{ shell ; protocol_data })
(merge_objs
Block_header.shell_header_encoding
protocol_data_encoding)
def "block_header.alpha.full_header"
@@ conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs Block_header.shell_header_encoding protocol_data_encoding)
(** Constants *)
let max_header_length =
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 ;
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 ;
{
priority = 0;
proof_of_work_nonce =
MBytes.create Constants_repr.proof_of_work_nonce_size ;
seed_nonce_hash = Some Nonce_hash.zero
} in
MBytes.create Constants_repr.proof_of_work_nonce_size;
seed_nonce_hash = Some Nonce_hash.zero;
}
in
Data_encoding.Binary.length
encoding
{ shell = fake_shell ;
protocol_data = {
contents = fake_contents ;
signature = Signature.zero ;
}
{
shell = fake_shell;
protocol_data = {contents = fake_contents; signature = Signature.zero};
}
(** Header parsing entry point *)
let hash_raw = Block_header.hash
let hash { shell ; protocol_data } =
let hash {shell; protocol_data} =
Block_header.hash
{ shell ;
{
shell;
protocol_data =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
protocol_data }
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;
}

43
vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli vendored
View File

@ -23,38 +23,39 @@
(* *)
(*****************************************************************************)
type t = {
shell: Block_header.shell_header ;
protocol_data: protocol_data ;
}
type t = {shell : Block_header.shell_header; protocol_data : protocol_data}
and protocol_data = {
contents: contents ;
signature: Signature.t ;
}
and protocol_data = {contents : contents; signature : Signature.t}
and contents = {
priority: int ;
seed_nonce_hash: Nonce_hash.t option ;
proof_of_work_nonce: MBytes.t ;
priority : int;
seed_nonce_hash : Nonce_hash.t option;
proof_of_work_nonce : MBytes.t;
}
type block_header = t
type raw = Block_header.t
type shell_header = Block_header.shell_header
val raw: block_header -> raw
val raw : block_header -> raw
val encoding: block_header Data_encoding.encoding
val raw_encoding: raw Data_encoding.t
val contents_encoding: contents Data_encoding.t
val unsigned_encoding: (Block_header.shell_header * contents) Data_encoding.t
val protocol_data_encoding: protocol_data Data_encoding.encoding
val shell_header_encoding: shell_header Data_encoding.encoding
val encoding : block_header Data_encoding.encoding
val raw_encoding : raw Data_encoding.t
val contents_encoding : contents Data_encoding.t
val unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t
val protocol_data_encoding : protocol_data Data_encoding.encoding
val shell_header_encoding : shell_header Data_encoding.encoding
val max_header_length: int
(** The maximum size of block headers in bytes *)
val max_header_length : int
val hash: block_header -> Block_hash.t
val hash_raw: raw -> Block_hash.t
val hash : block_header -> Block_hash.t
val hash_raw : raw -> Block_hash.t

152
vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml vendored
View File

@ -26,100 +26,128 @@
open Misc
let init_account ctxt
({ public_key_hash ; public_key ; amount }: Parameters_repr.bootstrap_account) =
({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account)
=
let contract = Contract_repr.implicit_contract public_key_hash in
Contract_storage.credit ctxt contract amount >>=? fun ctxt ->
Contract_storage.credit ctxt contract amount
>>=? fun ctxt ->
match public_key with
| Some public_key ->
Contract_storage.reveal_manager_key ctxt public_key_hash public_key >>=? fun ctxt ->
Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt ->
Contract_storage.reveal_manager_key ctxt public_key_hash public_key
>>=? fun ctxt ->
Delegate_storage.set ctxt contract (Some public_key_hash)
>>=? fun ctxt -> return ctxt
| None ->
return ctxt
| None -> return ctxt
let init_contract ~typecheck ctxt
({ delegate ; amount ; script }: Parameters_repr.bootstrap_contract) =
Contract_storage.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
typecheck ctxt script >>=? fun (script, ctxt) ->
Contract_storage.originate ctxt contract
({delegate; amount; script} : Parameters_repr.bootstrap_contract) =
Contract_storage.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
typecheck ctxt script
>>=? fun (script, ctxt) ->
Contract_storage.originate
ctxt
contract
~balance:amount
~prepaid_bootstrap_storage:true
~script
~delegate:(Some delegate) >>=? fun ctxt ->
return ctxt
~delegate:(Some delegate)
>>=? fun ctxt -> return ctxt
let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
let nonce =
Operation_hash.hash_bytes
[ MBytes.of_string "Un festival de GADT." ] in
Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."]
in
let ctxt = Raw_context.init_origination_nonce ctxt nonce in
fold_left_s init_account ctxt accounts >>=? fun ctxt ->
fold_left_s (init_contract ~typecheck) ctxt contracts >>=? fun ctxt ->
begin
match no_reward_cycles with
| None -> return ctxt
fold_left_s init_account ctxt accounts
>>=? fun ctxt ->
fold_left_s (init_contract ~typecheck) ctxt contracts
>>=? fun ctxt ->
( match no_reward_cycles with
| None ->
return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
(* Start without reward *)
Raw_context.patch_constants ctxt
(fun c ->
{ c with
block_reward = Tez_repr.zero ;
endorsement_reward = Tez_repr.zero }) >>= fun ctxt ->
(* Start without rewards *)
Raw_context.patch_constants ctxt (fun c ->
{
c with
baking_reward_per_endorsement = [Tez_repr.zero];
endorsement_reward = [Tez_repr.zero];
})
>>= fun ctxt ->
(* Store the final reward. *)
Storage.Ramp_up.Rewards.init ctxt
Storage.Ramp_up.Rewards.init
ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
(constants.block_reward,
constants.endorsement_reward)
end >>=? fun ctxt ->
(constants.baking_reward_per_endorsement, constants.endorsement_reward)
)
>>=? fun ctxt ->
match ramp_up_cycles with
| None -> return ctxt
| None ->
return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
Lwt.return Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) >>=? fun block_step ->
Lwt.return Tez_repr.(constants.endorsement_security_deposit /? Int64.of_int cycles) >>=? fun endorsement_step ->
Lwt.return
Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles)
>>=? fun block_step ->
Lwt.return
Tez_repr.(
constants.endorsement_security_deposit /? Int64.of_int cycles)
>>=? fun endorsement_step ->
(* Start without security_deposit *)
Raw_context.patch_constants ctxt
(fun c ->
{ c with
block_security_deposit = Tez_repr.zero ;
endorsement_security_deposit = Tez_repr.zero }) >>= fun ctxt ->
Raw_context.patch_constants ctxt (fun c ->
{
c with
block_security_deposit = Tez_repr.zero;
endorsement_security_deposit = Tez_repr.zero;
})
>>= fun ctxt ->
fold_left_s
(fun ctxt cycle ->
Lwt.return Tez_repr.(block_step *? Int64.of_int cycle) >>=? fun block_security_deposit ->
Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle) >>=? fun endorsement_security_deposit ->
Lwt.return Tez_repr.(block_step *? Int64.of_int cycle)
>>=? fun block_security_deposit ->
Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle)
>>=? fun endorsement_security_deposit ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
Storage.Ramp_up.Security_deposits.init ctxt cycle
Storage.Ramp_up.Security_deposits.init
ctxt
cycle
(block_security_deposit, endorsement_security_deposit))
ctxt
(1 --> (cycles - 1)) >>=? fun ctxt ->
(1 --> (cycles - 1))
>>=? fun ctxt ->
(* Store the final security deposits. *)
Storage.Ramp_up.Security_deposits.init ctxt
Storage.Ramp_up.Security_deposits.init
ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
(constants.block_security_deposit,
constants.endorsement_security_deposit) >>=? fun ctxt ->
return ctxt
( constants.block_security_deposit,
constants.endorsement_security_deposit )
>>=? fun ctxt -> return ctxt
let cycle_end ctxt last_cycle =
let next_cycle = Cycle_repr.succ last_cycle in
begin
Storage.Ramp_up.Rewards.get_option ctxt next_cycle >>=? function
| None -> return ctxt
| Some (block_reward, endorsement_reward) ->
Storage.Ramp_up.Rewards.delete ctxt next_cycle >>=? fun ctxt ->
Raw_context.patch_constants ctxt
(fun c ->
{ c with block_reward ;
endorsement_reward }) >>= fun ctxt ->
Storage.Ramp_up.Rewards.get_option ctxt next_cycle
>>=? (function
| None ->
return ctxt
| Some (baking_reward_per_endorsement, endorsement_reward) ->
Storage.Ramp_up.Rewards.delete ctxt next_cycle
>>=? fun ctxt ->
Raw_context.patch_constants ctxt (fun c ->
{c with baking_reward_per_endorsement; endorsement_reward})
>>= fun ctxt -> return ctxt)
>>=? fun ctxt ->
Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle
>>=? function
| None ->
return ctxt
end >>=? fun ctxt ->
Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle >>=? function
| None -> return ctxt
| Some (block_security_deposit, endorsement_security_deposit) ->
Storage.Ramp_up.Security_deposits.delete ctxt next_cycle >>=? fun ctxt ->
Raw_context.patch_constants ctxt
(fun c ->
{ c with block_security_deposit ;
endorsement_security_deposit }) >>= fun ctxt ->
return ctxt
Storage.Ramp_up.Security_deposits.delete ctxt next_cycle
>>=? fun ctxt ->
Raw_context.patch_constants ctxt (fun c ->
{c with block_security_deposit; endorsement_security_deposit})
>>= fun ctxt -> return ctxt

16
vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli vendored
View File

@ -23,18 +23,18 @@
(* *)
(*****************************************************************************)
val init:
val init :
Raw_context.t ->
typecheck:(Raw_context.t -> Script_repr.t ->
((Script_repr.t * Contract_storage.big_map_diff option) * Raw_context.t)
tzresult Lwt.t) ->
typecheck:(Raw_context.t ->
Script_repr.t ->
( (Script_repr.t * Contract_storage.big_map_diff option)
* Raw_context.t )
tzresult
Lwt.t) ->
?ramp_up_cycles:int ->
?no_reward_cycles:int ->
Parameters_repr.bootstrap_account list ->
Parameters_repr.bootstrap_contract list ->
Raw_context.t tzresult Lwt.t
val cycle_end:
Raw_context.t ->
Cycle_repr.t ->
Raw_context.t tzresult Lwt.t
val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t

16
vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml vendored
View File

@ -24,17 +24,15 @@
(*****************************************************************************)
type t = {
blinded_public_key_hash : Blinded_public_key_hash.t ;
amount : Tez_repr.t
blinded_public_key_hash : Blinded_public_key_hash.t;
amount : Tez_repr.t;
}
let encoding =
let open Data_encoding in
conv
(fun { blinded_public_key_hash ; amount } ->
( blinded_public_key_hash, amount ))
(fun ( blinded_public_key_hash, amount) ->
{ blinded_public_key_hash ; amount })
(tup2
Blinded_public_key_hash.encoding
Tez_repr.encoding)
(fun {blinded_public_key_hash; amount} ->
(blinded_public_key_hash, amount))
(fun (blinded_public_key_hash, amount) ->
{blinded_public_key_hash; amount})
(tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)

4
vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli vendored
View File

@ -24,8 +24,8 @@
(*****************************************************************************)
type t = {
blinded_public_key_hash : Blinded_public_key_hash.t ;
amount : Tez_repr.t ;
blinded_public_key_hash : Blinded_public_key_hash.t;
amount : Tez_repr.t;
}
val encoding : t Data_encoding.t

9
vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml vendored
View File

@ -24,10 +24,11 @@
(*****************************************************************************)
let get_opt = Storage.Commitments.get_option
let delete = Storage.Commitments.delete
let init ctxt commitments =
let init_commitment ctxt Commitment_repr.{ blinded_public_key_hash ; amount } =
Storage.Commitments.init ctxt blinded_public_key_hash amount in
fold_left_s init_commitment ctxt commitments >>=? fun ctxt ->
return ctxt
let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} =
Storage.Commitments.init ctxt blinded_public_key_hash amount
in
fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt

16
vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli vendored
View File

@ -23,15 +23,13 @@
(* *)
(*****************************************************************************)
val init:
Raw_context.t ->
Commitment_repr.t list ->
Raw_context.t tzresult Lwt.t
val init :
Raw_context.t -> Commitment_repr.t list -> Raw_context.t tzresult Lwt.t
val get_opt:
Raw_context.t -> Blinded_public_key_hash.t ->
val get_opt :
Raw_context.t ->
Blinded_public_key_hash.t ->
Tez_repr.t option tzresult Lwt.t
val delete:
Raw_context.t -> Blinded_public_key_hash.t ->
Raw_context.t tzresult Lwt.t
val delete :
Raw_context.t -> Blinded_public_key_hash.t -> Raw_context.t tzresult Lwt.t

357
vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml vendored
View File

@ -24,41 +24,48 @@
(*****************************************************************************)
let version_number_004 = "\000"
let version_number = "\001"
let proof_of_work_nonce_size = 8
let nonce_length = 32
let max_revelations_per_block = 32
let max_proposals_per_delegate = 20
let max_operation_data_length = 16 * 1024 (* 16kB *)
type fixed = {
proof_of_work_nonce_size : int ;
nonce_length : int ;
max_revelations_per_block : int ;
max_operation_data_length : int ;
max_proposals_per_delegate : int ;
proof_of_work_nonce_size : int;
nonce_length : int;
max_revelations_per_block : int;
max_operation_data_length : int;
max_proposals_per_delegate : int;
}
let fixed_encoding =
let open Data_encoding in
conv
(fun c ->
(c.proof_of_work_nonce_size,
( c.proof_of_work_nonce_size,
c.nonce_length,
c.max_revelations_per_block,
c.max_operation_data_length,
c.max_proposals_per_delegate))
(fun (proof_of_work_nonce_size,
c.max_proposals_per_delegate ))
(fun ( proof_of_work_nonce_size,
nonce_length,
max_revelations_per_block,
max_operation_data_length,
max_proposals_per_delegate) ->
{ proof_of_work_nonce_size ;
nonce_length ;
max_revelations_per_block ;
max_operation_data_length ;
max_proposals_per_delegate ;
} )
max_proposals_per_delegate ) ->
{
proof_of_work_nonce_size;
nonce_length;
max_revelations_per_block;
max_operation_data_length;
max_proposals_per_delegate;
})
(obj5
(req "proof_of_work_nonce_size" uint8)
(req "nonce_length" uint8)
@ -66,48 +73,50 @@ let fixed_encoding =
(req "max_operation_data_length" int31)
(req "max_proposals_per_delegate" uint8))
let fixed = {
proof_of_work_nonce_size ;
nonce_length ;
max_revelations_per_block ;
max_operation_data_length ;
max_proposals_per_delegate ;
}
let fixed =
{
proof_of_work_nonce_size;
nonce_length;
max_revelations_per_block;
max_operation_data_length;
max_proposals_per_delegate;
}
type parametric = {
preserved_cycles: int ;
blocks_per_cycle: int32 ;
blocks_per_commitment: int32 ;
blocks_per_roll_snapshot: int32 ;
blocks_per_voting_period: int32 ;
time_between_blocks: Period_repr.t list ;
endorsers_per_block: int ;
hard_gas_limit_per_operation: Z.t ;
hard_gas_limit_per_block: Z.t ;
proof_of_work_threshold: int64 ;
tokens_per_roll: Tez_repr.t ;
michelson_maximum_type_size: int;
seed_nonce_revelation_tip: Tez_repr.t ;
origination_size: int ;
block_security_deposit: Tez_repr.t ;
endorsement_security_deposit: Tez_repr.t ;
block_reward: Tez_repr.t ;
endorsement_reward: Tez_repr.t ;
cost_per_byte: Tez_repr.t ;
hard_storage_limit_per_operation: Z.t ;
test_chain_duration: int64 ; (* in seconds *)
quorum_min: int32 ;
quorum_max: int32 ;
min_proposal_quorum: int32 ;
initial_endorsers: int ;
delay_per_missing_endorsement: Period_repr.t ;
preserved_cycles : int;
blocks_per_cycle : int32;
blocks_per_commitment : int32;
blocks_per_roll_snapshot : int32;
blocks_per_voting_period : int32;
time_between_blocks : Period_repr.t list;
endorsers_per_block : int;
hard_gas_limit_per_operation : Z.t;
hard_gas_limit_per_block : Z.t;
proof_of_work_threshold : int64;
tokens_per_roll : Tez_repr.t;
michelson_maximum_type_size : int;
seed_nonce_revelation_tip : Tez_repr.t;
origination_size : int;
block_security_deposit : Tez_repr.t;
endorsement_security_deposit : Tez_repr.t;
baking_reward_per_endorsement : Tez_repr.t list;
endorsement_reward : Tez_repr.t list;
cost_per_byte : Tez_repr.t;
hard_storage_limit_per_operation : Z.t;
test_chain_duration : int64;
(* in seconds *)
quorum_min : int32;
quorum_max : int32;
min_proposal_quorum : int32;
initial_endorsers : int;
delay_per_missing_endorsement : Period_repr.t;
}
let parametric_encoding =
let open Data_encoding in
conv
(fun c ->
(( c.preserved_cycles,
( ( c.preserved_cycles,
c.blocks_per_cycle,
c.blocks_per_commitment,
c.blocks_per_roll_snapshot,
@ -115,16 +124,16 @@ let parametric_encoding =
c.time_between_blocks,
c.endorsers_per_block,
c.hard_gas_limit_per_operation,
c.hard_gas_limit_per_block),
((c.proof_of_work_threshold,
c.hard_gas_limit_per_block ),
( ( c.proof_of_work_threshold,
c.tokens_per_roll,
c.michelson_maximum_type_size,
c.seed_nonce_revelation_tip,
c.origination_size,
c.block_security_deposit,
c.endorsement_security_deposit,
c.block_reward),
(c.endorsement_reward,
c.baking_reward_per_endorsement ),
( c.endorsement_reward,
c.cost_per_byte,
c.hard_storage_limit_per_operation,
c.test_chain_duration,
@ -132,9 +141,8 @@ let parametric_encoding =
c.quorum_max,
c.min_proposal_quorum,
c.initial_endorsers,
c.delay_per_missing_endorsement
))) )
(fun (( preserved_cycles,
c.delay_per_missing_endorsement ) ) ))
(fun ( ( preserved_cycles,
blocks_per_cycle,
blocks_per_commitment,
blocks_per_roll_snapshot,
@ -142,16 +150,16 @@ let parametric_encoding =
time_between_blocks,
endorsers_per_block,
hard_gas_limit_per_operation,
hard_gas_limit_per_block),
((proof_of_work_threshold,
hard_gas_limit_per_block ),
( ( proof_of_work_threshold,
tokens_per_roll,
michelson_maximum_type_size,
seed_nonce_revelation_tip,
origination_size,
block_security_deposit,
endorsement_security_deposit,
block_reward),
(endorsement_reward,
baking_reward_per_endorsement ),
( endorsement_reward,
cost_per_byte,
hard_storage_limit_per_operation,
test_chain_duration,
@ -159,34 +167,191 @@ let parametric_encoding =
quorum_max,
min_proposal_quorum,
initial_endorsers,
delay_per_missing_endorsement))) ->
{ preserved_cycles ;
blocks_per_cycle ;
blocks_per_commitment ;
blocks_per_roll_snapshot ;
blocks_per_voting_period ;
time_between_blocks ;
endorsers_per_block ;
hard_gas_limit_per_operation ;
hard_gas_limit_per_block ;
proof_of_work_threshold ;
tokens_per_roll ;
michelson_maximum_type_size ;
seed_nonce_revelation_tip ;
origination_size ;
block_security_deposit ;
endorsement_security_deposit ;
block_reward ;
endorsement_reward ;
cost_per_byte ;
hard_storage_limit_per_operation ;
test_chain_duration ;
quorum_min ;
quorum_max ;
min_proposal_quorum ;
initial_endorsers ;
delay_per_missing_endorsement ;
} )
delay_per_missing_endorsement ) ) ) ->
{
preserved_cycles;
blocks_per_cycle;
blocks_per_commitment;
blocks_per_roll_snapshot;
blocks_per_voting_period;
time_between_blocks;
endorsers_per_block;
hard_gas_limit_per_operation;
hard_gas_limit_per_block;
proof_of_work_threshold;
tokens_per_roll;
michelson_maximum_type_size;
seed_nonce_revelation_tip;
origination_size;
block_security_deposit;
endorsement_security_deposit;
baking_reward_per_endorsement;
endorsement_reward;
cost_per_byte;
hard_storage_limit_per_operation;
test_chain_duration;
quorum_min;
quorum_max;
min_proposal_quorum;
initial_endorsers;
delay_per_missing_endorsement;
})
(merge_objs
(obj9
(req "preserved_cycles" uint8)
(req "blocks_per_cycle" int32)
(req "blocks_per_commitment" int32)
(req "blocks_per_roll_snapshot" int32)
(req "blocks_per_voting_period" int32)
(req "time_between_blocks" (list Period_repr.encoding))
(req "endorsers_per_block" uint16)
(req "hard_gas_limit_per_operation" z)
(req "hard_gas_limit_per_block" z))
(merge_objs
(obj8
(req "proof_of_work_threshold" int64)
(req "tokens_per_roll" Tez_repr.encoding)
(req "michelson_maximum_type_size" uint16)
(req "seed_nonce_revelation_tip" Tez_repr.encoding)
(req "origination_size" int31)
(req "block_security_deposit" Tez_repr.encoding)
(req "endorsement_security_deposit" Tez_repr.encoding)
(req "baking_reward_per_endorsement" (list Tez_repr.encoding)))
(obj9
(req "endorsement_reward" (list Tez_repr.encoding))
(req "cost_per_byte" Tez_repr.encoding)
(req "hard_storage_limit_per_operation" z)
(req "test_chain_duration" int64)
(req "quorum_min" int32)
(req "quorum_max" int32)
(req "min_proposal_quorum" int32)
(req "initial_endorsers" uint16)
(req "delay_per_missing_endorsement" Period_repr.encoding))))
type t = {fixed : fixed; parametric : parametric}
let encoding =
let open Data_encoding in
conv
(fun {fixed; parametric} -> (fixed, parametric))
(fun (fixed, parametric) -> {fixed; parametric})
(merge_objs fixed_encoding parametric_encoding)
module Proto_005 = struct
type parametric = {
preserved_cycles : int;
blocks_per_cycle : int32;
blocks_per_commitment : int32;
blocks_per_roll_snapshot : int32;
blocks_per_voting_period : int32;
time_between_blocks : Period_repr.t list;
endorsers_per_block : int;
hard_gas_limit_per_operation : Z.t;
hard_gas_limit_per_block : Z.t;
proof_of_work_threshold : int64;
tokens_per_roll : Tez_repr.t;
michelson_maximum_type_size : int;
seed_nonce_revelation_tip : Tez_repr.t;
origination_size : int;
block_security_deposit : Tez_repr.t;
endorsement_security_deposit : Tez_repr.t;
block_reward : Tez_repr.t;
endorsement_reward : Tez_repr.t;
cost_per_byte : Tez_repr.t;
hard_storage_limit_per_operation : Z.t;
test_chain_duration : int64;
(* in seconds *)
quorum_min : int32;
quorum_max : int32;
min_proposal_quorum : int32;
initial_endorsers : int;
delay_per_missing_endorsement : Period_repr.t;
}
let parametric_encoding =
let open Data_encoding in
conv
(fun c ->
( ( c.preserved_cycles,
c.blocks_per_cycle,
c.blocks_per_commitment,
c.blocks_per_roll_snapshot,
c.blocks_per_voting_period,
c.time_between_blocks,
c.endorsers_per_block,
c.hard_gas_limit_per_operation,
c.hard_gas_limit_per_block ),
( ( c.proof_of_work_threshold,
c.tokens_per_roll,
c.michelson_maximum_type_size,
c.seed_nonce_revelation_tip,
c.origination_size,
c.block_security_deposit,
c.endorsement_security_deposit,
c.block_reward ),
( c.endorsement_reward,
c.cost_per_byte,
c.hard_storage_limit_per_operation,
c.test_chain_duration,
c.quorum_min,
c.quorum_max,
c.min_proposal_quorum,
c.initial_endorsers,
c.delay_per_missing_endorsement ) ) ))
(fun ( ( preserved_cycles,
blocks_per_cycle,
blocks_per_commitment,
blocks_per_roll_snapshot,
blocks_per_voting_period,
time_between_blocks,
endorsers_per_block,
hard_gas_limit_per_operation,
hard_gas_limit_per_block ),
( ( proof_of_work_threshold,
tokens_per_roll,
michelson_maximum_type_size,
seed_nonce_revelation_tip,
origination_size,
block_security_deposit,
endorsement_security_deposit,
block_reward ),
( endorsement_reward,
cost_per_byte,
hard_storage_limit_per_operation,
test_chain_duration,
quorum_min,
quorum_max,
min_proposal_quorum,
initial_endorsers,
delay_per_missing_endorsement ) ) ) ->
{
preserved_cycles;
blocks_per_cycle;
blocks_per_commitment;
blocks_per_roll_snapshot;
blocks_per_voting_period;
time_between_blocks;
endorsers_per_block;
hard_gas_limit_per_operation;
hard_gas_limit_per_block;
proof_of_work_threshold;
tokens_per_roll;
michelson_maximum_type_size;
seed_nonce_revelation_tip;
origination_size;
block_security_deposit;
endorsement_security_deposit;
block_reward;
endorsement_reward;
cost_per_byte;
hard_storage_limit_per_operation;
test_chain_duration;
quorum_min;
quorum_max;
min_proposal_quorum;
initial_endorsers;
delay_per_missing_endorsement;
})
(merge_objs
(obj9
(req "preserved_cycles" uint8)
@ -217,17 +382,5 @@ let parametric_encoding =
(req "quorum_max" int32)
(req "min_proposal_quorum" int32)
(req "initial_endorsers" uint16)
(req "delay_per_missing_endorsement" Period_repr.encoding)
)))
type t = {
fixed : fixed ;
parametric : parametric ;
}
let encoding =
let open Data_encoding in
conv
(fun { fixed ; parametric } -> (fixed, parametric))
(fun (fixed , parametric) -> { fixed ; parametric })
(merge_objs fixed_encoding parametric_encoding)
(req "delay_per_missing_endorsement" Period_repr.encoding))))
end

35
vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml vendored
View File

@ -26,40 +26,35 @@
open Alpha_context
let custom_root =
(RPC_path.(open_root / "context" / "constants") : RPC_context.t RPC_path.context)
( RPC_path.(open_root / "context" / "constants")
: RPC_context.t RPC_path.context )
module S = struct
open Data_encoding
let errors =
RPC_service.get_service
~description: "Schema for all the RPC errors from this protocol version"
~query: RPC_query.empty
~output: json_schema
~description:"Schema for all the RPC errors from this protocol version"
~query:RPC_query.empty
~output:json_schema
RPC_path.(custom_root / "errors")
let all =
RPC_service.get_service
~description: "All constants"
~query: RPC_query.empty
~output: Alpha_context.Constants.encoding
~description:"All constants"
~query:RPC_query.empty
~output:Alpha_context.Constants.encoding
custom_root
end
let register () =
let open Services_registration in
register0_noctxt S.errors begin fun () () ->
return (Data_encoding.Json.(schema error_encoding))
end ;
register0 S.all begin fun ctxt () () ->
register0_noctxt S.errors (fun () () ->
return Data_encoding.Json.(schema error_encoding)) ;
register0 S.all (fun ctxt () () ->
let open Constants in
return { fixed = fixed ;
parametric = parametric ctxt }
end
return {fixed; parametric = parametric ctxt})
let errors ctxt block =
RPC_context.make_call0 S.errors ctxt block () ()
let all ctxt block =
RPC_context.make_call0 S.all ctxt block () ()
let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()
let all ctxt block = RPC_context.make_call0 S.all ctxt block () ()

11
vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli vendored
View File

@ -25,11 +25,12 @@
open Alpha_context
val errors:
'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t
val errors :
'a #RPC_context.simple ->
'a ->
Data_encoding.json_schema shell_tzresult Lwt.t
(** Returns all the constants of the protocol *)
val all:
'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t
val all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t
val register: unit -> unit
val register : unit -> unit

33
vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml vendored
View File

@ -26,80 +26,105 @@
let preserved_cycles c =
let constants = Raw_context.constants c in
constants.preserved_cycles
let blocks_per_cycle c =
let constants = Raw_context.constants c in
constants.blocks_per_cycle
let blocks_per_commitment c =
let constants = Raw_context.constants c in
constants.blocks_per_commitment
let blocks_per_roll_snapshot c =
let constants = Raw_context.constants c in
constants.blocks_per_roll_snapshot
let blocks_per_voting_period c =
let constants = Raw_context.constants c in
constants.blocks_per_voting_period
let time_between_blocks c =
let constants = Raw_context.constants c in
constants.time_between_blocks
let endorsers_per_block c =
let constants = Raw_context.constants c in
constants.endorsers_per_block
let initial_endorsers c =
let constants = Raw_context.constants c in
constants.initial_endorsers
let delay_per_missing_endorsement c =
let constants = Raw_context.constants c in
constants.delay_per_missing_endorsement
let hard_gas_limit_per_operation c =
let constants = Raw_context.constants c in
constants.hard_gas_limit_per_operation
let hard_gas_limit_per_block c =
let constants = Raw_context.constants c in
constants.hard_gas_limit_per_block
let cost_per_byte c =
let constants = Raw_context.constants c in
constants.cost_per_byte
let hard_storage_limit_per_operation c =
let constants = Raw_context.constants c in
constants.hard_storage_limit_per_operation
let proof_of_work_threshold c =
let constants = Raw_context.constants c in
constants.proof_of_work_threshold
let tokens_per_roll c =
let constants = Raw_context.constants c in
constants.tokens_per_roll
let michelson_maximum_type_size c =
let constants = Raw_context.constants c in
constants.michelson_maximum_type_size
let seed_nonce_revelation_tip c =
let constants = Raw_context.constants c in
constants.seed_nonce_revelation_tip
let origination_size c =
let constants = Raw_context.constants c in
constants.origination_size
let block_security_deposit c =
let constants = Raw_context.constants c in
constants.block_security_deposit
let endorsement_security_deposit c =
let constants = Raw_context.constants c in
constants.endorsement_security_deposit
let block_reward c =
let baking_reward_per_endorsement c =
let constants = Raw_context.constants c in
constants.block_reward
constants.baking_reward_per_endorsement
let endorsement_reward c =
let constants = Raw_context.constants c in
constants.endorsement_reward
let test_chain_duration c =
let constants = Raw_context.constants c in
constants.test_chain_duration
let quorum_min c =
let constants = Raw_context.constants c in
constants.quorum_min
let quorum_max c =
let constants = Raw_context.constants c in
constants.quorum_max
let min_proposal_quorum c =
let constants = Raw_context.constants c in
constants.min_proposal_quorum
let parametric c =
Raw_context.constants c
let parametric c = Raw_context.constants c

10
vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml vendored
View File

@ -26,12 +26,16 @@
(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)
include Blake2B.Make(Base58)(struct
include Blake2B.Make
(Base58)
(struct
let name = "Contract_hash"
let title = "A contract ID"
let b58check_prefix = contract_hash
let size = Some 20
end)
let () =
Base58.check_encoded_prefix b58check_encoding "KT1" 36
let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36

192
vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml vendored
View File

@ -27,71 +27,89 @@ type t =
| Implicit of Signature.Public_key_hash.t
| Originated of Contract_hash.t
include Compare.Make(struct
include Compare.Make (struct
type nonrec t = t
let compare l1 l2 =
match l1, l2 with
| Implicit pkh1, Implicit pkh2 ->
match (l1, l2) with
| (Implicit pkh1, Implicit pkh2) ->
Signature.Public_key_hash.compare pkh1 pkh2
| Originated h1, Originated h2 ->
| (Originated h1, Originated h2) ->
Contract_hash.compare h1 h2
| Implicit _, Originated _ -> -1
| Originated _, Implicit _ -> 1
end)
| (Implicit _, Originated _) ->
-1
| (Originated _, Implicit _) ->
1
end)
type contract = t
type error += Invalid_contract_notation of string (* `Permanent *)
let to_b58check = function
| Implicit pbk -> Signature.Public_key_hash.to_b58check pbk
| Originated h -> Contract_hash.to_b58check h
| Implicit pbk ->
Signature.Public_key_hash.to_b58check pbk
| Originated h ->
Contract_hash.to_b58check h
let of_b58check s =
match Base58.decode s with
| Some (Ed25519.Public_key_hash.Data h) -> ok (Implicit (Signature.Ed25519 h))
| Some (Secp256k1.Public_key_hash.Data h) -> ok (Implicit (Signature.Secp256k1 h))
| Some (P256.Public_key_hash.Data h) -> ok (Implicit (Signature.P256 h))
| Some (Contract_hash.Data h) -> ok (Originated h)
| _ -> error (Invalid_contract_notation s)
| Some (Ed25519.Public_key_hash.Data h) ->
ok (Implicit (Signature.Ed25519 h))
| Some (Secp256k1.Public_key_hash.Data h) ->
ok (Implicit (Signature.Secp256k1 h))
| Some (P256.Public_key_hash.Data h) ->
ok (Implicit (Signature.P256 h))
| Some (Contract_hash.Data h) ->
ok (Originated h)
| _ ->
error (Invalid_contract_notation s)
let pp ppf = function
| Implicit pbk -> Signature.Public_key_hash.pp ppf pbk
| Originated h -> Contract_hash.pp ppf h
| Implicit pbk ->
Signature.Public_key_hash.pp ppf pbk
| Originated h ->
Contract_hash.pp ppf h
let pp_short ppf = function
| Implicit pbk -> Signature.Public_key_hash.pp_short ppf pbk
| Originated h -> Contract_hash.pp_short ppf h
| Implicit pbk ->
Signature.Public_key_hash.pp_short ppf pbk
| Originated h ->
Contract_hash.pp_short ppf h
let encoding =
let open Data_encoding in
def "contract_id"
~title:
"A contract handle"
def
"contract_id"
~title:"A contract handle"
~description:
"A contract notation as given to an RPC or inside scripts. \
Can be a base58 implicit contract hash \
or a base58 originated contract hash." @@
splitted
"A contract notation as given to an RPC or inside scripts. Can be a \
base58 implicit contract hash or a base58 originated contract hash."
@@ splitted
~binary:
(union ~tag_size:`Uint8 [
case (Tag 0)
(union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Implicit"
Signature.Public_key_hash.encoding
(function Implicit k -> Some k | _ -> None)
(fun k -> Implicit k) ;
case (Tag 1) (Fixed.add_padding Contract_hash.encoding 1)
(fun k -> Implicit k);
case
(Tag 1)
(Fixed.add_padding Contract_hash.encoding 1)
~title:"Originated"
(function Originated k -> Some k | _ -> None)
(fun k -> Originated k) ;
])
(fun k -> Originated k) ])
~json:
(conv
to_b58check
(fun s ->
match of_b58check s with
| Ok s -> s
| Error _ -> Json.cannot_destruct "Invalid contract notation.")
| Ok s ->
s
| Error _ ->
Json.cannot_destruct "Invalid contract notation.")
string)
let () =
@ -99,8 +117,8 @@ let () =
register_error_kind
`Permanent
~id:"contract.invalid_contract_notation"
~title: "Invalid contract notation"
~pp: (fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
~title:"Invalid contract notation"
~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
~description:
"A malformed contract notation was given to an RPC or in a script."
(obj1 (req "notation" string))
@ -109,106 +127,104 @@ let () =
let implicit_contract id = Implicit id
let originated_contract_004 id = Originated id
let is_implicit = function Implicit m -> Some m | Originated _ -> None
let is_implicit = function
| Implicit m -> Some m
| Originated _ -> None
let is_originated = function Implicit _ -> None | Originated h -> Some h
let is_originated = function
| Implicit _ -> None
| Originated h -> Some h
type origination_nonce =
{ operation_hash: Operation_hash.t ;
origination_index: int32 }
type origination_nonce = {
operation_hash : Operation_hash.t;
origination_index : int32;
}
let origination_nonce_encoding =
let open Data_encoding in
conv
(fun { operation_hash ; origination_index } ->
(fun {operation_hash; origination_index} ->
(operation_hash, origination_index))
(fun (operation_hash, origination_index) ->
{ operation_hash ; origination_index }) @@
obj2
(req "operation" Operation_hash.encoding)
(dft "index" int32 0l)
{operation_hash; origination_index})
@@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l)
let originated_contract nonce =
let data =
Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce in
Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
in
Originated (Contract_hash.hash_bytes [data])
let originated_contracts
~since: { origination_index = first ; operation_hash = first_hash }
~until: ({ origination_index = last ; operation_hash = last_hash } as origination_nonce) =
~since:{origination_index = first; operation_hash = first_hash}
~until:( {origination_index = last; operation_hash = last_hash} as
origination_nonce ) =
assert (Operation_hash.equal first_hash last_hash) ;
let rec contracts acc origination_index =
if Compare.Int32.(origination_index < first) then
acc
if Compare.Int32.(origination_index < first) then acc
else
let origination_nonce =
{ origination_nonce with origination_index } in
let origination_nonce = {origination_nonce with origination_index} in
let acc = originated_contract origination_nonce :: acc in
contracts acc (Int32.pred origination_index) in
contracts acc (Int32.pred origination_index)
in
contracts [] (Int32.pred last)
let initial_origination_nonce operation_hash =
{ operation_hash ; origination_index = 0l }
{operation_hash; origination_index = 0l}
let incr_origination_nonce nonce =
let origination_index = Int32.succ nonce.origination_index in
{ nonce with origination_index }
{nonce with origination_index}
let rpc_arg =
let construct = to_b58check in
let destruct hash =
match of_b58check hash with
| Error _ -> Error "Cannot parse contract id"
| Ok contract -> Ok contract in
| Error _ ->
Error "Cannot parse contract id"
| Ok contract ->
Ok contract
in
RPC_arg.make
~descr: "A contract identifier encoded in b58check."
~name: "contract_id"
~descr:"A contract identifier encoded in b58check."
~name:"contract_id"
~construct
~destruct
()
module Index = struct
type t = contract
let path_length = 7
let to_path c l =
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
let `Hex key = MBytes.to_hex raw_key in
let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
String.sub index_key 0 2 ::
String.sub index_key 2 2 ::
String.sub index_key 4 2 ::
String.sub index_key 6 2 ::
String.sub index_key 8 2 ::
String.sub index_key 10 2 ::
key ::
l
let (`Hex key) = MBytes.to_hex raw_key in
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
String.sub index_key 0 2 :: String.sub index_key 2 2
:: String.sub index_key 4 2 :: String.sub index_key 6 2
:: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l
let of_path = function
| [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_]
| _::_::_::_::_::_::_::_::_ ->
| []
| [_]
| [_; _]
| [_; _; _]
| [_; _; _; _]
| [_; _; _; _; _]
| [_; _; _; _; _; _]
| _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
None
| [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] ->
| [index1; index2; index3; index4; index5; index6; key] ->
let raw_key = MBytes.of_hex (`Hex key) in
let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
assert Compare.String.(String.sub index_key 0 2 = index1) ;
assert Compare.String.(String.sub index_key 2 2 = index2) ;
assert Compare.String.(String.sub index_key 4 2 = index3) ;
assert Compare.String.(String.sub index_key 6 2 = index4) ;
assert Compare.String.(String.sub index_key 8 2 = index5) ;
assert Compare.String.(String.sub index_key 10 2 = index6) ;
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
Data_encoding.Binary.of_bytes encoding raw_key
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
let encoding = encoding
let compare = compare
end

16
vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli vendored
View File

@ -26,6 +26,7 @@
type t = private
| Implicit of Signature.Public_key_hash.t
| Originated of Contract_hash.t
type contract = t
include Compare.S with type t := contract
@ -34,9 +35,6 @@ include Compare.S with type t := contract
val implicit_contract : Signature.Public_key_hash.t -> contract
(** Only for migration from proto_004 *)
val originated_contract_004 : Contract_hash.t -> contract
val is_implicit : contract -> Signature.Public_key_hash.t option
(** {2 Originated contracts} *)
@ -50,7 +48,8 @@ type origination_nonce
val originated_contract : origination_nonce -> contract
val originated_contracts : since: origination_nonce -> until: origination_nonce -> contract list
val originated_contracts :
since:origination_nonce -> until:origination_nonce -> contract list
val initial_origination_nonce : Operation_hash.t -> origination_nonce
@ -58,18 +57,17 @@ val incr_origination_nonce : origination_nonce -> origination_nonce
val is_originated : contract -> Contract_hash.t option
(** {2 Human readable notation} *)
type error += Invalid_contract_notation of string (* `Permanent *)
val to_b58check: contract -> string
val to_b58check : contract -> string
val of_b58check: string -> contract tzresult
val of_b58check : string -> contract tzresult
val pp: Format.formatter -> contract -> unit
val pp : Format.formatter -> contract -> unit
val pp_short: Format.formatter -> contract -> unit
val pp_short : Format.formatter -> contract -> unit
(** {2 Serializers} *)

389
vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml vendored
View File

@ -26,282 +26,349 @@
open Alpha_context
let custom_root =
(RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context)
( RPC_path.(open_root / "context" / "contracts")
: RPC_context.t RPC_path.context )
let big_map_root =
(RPC_path.(open_root / "context" / "big_maps") : RPC_context.t RPC_path.context)
( RPC_path.(open_root / "context" / "big_maps")
: RPC_context.t RPC_path.context )
type info = {
balance: Tez.t ;
delegate: public_key_hash option ;
counter: counter option ;
script: Script.t option ;
balance : Tez.t;
delegate : public_key_hash option;
counter : counter option;
script : Script.t option;
}
let info_encoding =
let open Data_encoding in
conv
(fun {balance ; delegate ; script ; counter } ->
(fun {balance; delegate; script; counter} ->
(balance, delegate, script, counter))
(fun (balance, delegate, script, counter) ->
{balance ; delegate ; script ; counter}) @@
obj4
{balance; delegate; script; counter})
@@ obj4
(req "balance" Tez.encoding)
(opt "delegate" Signature.Public_key_hash.encoding)
(opt "script" Script.encoding)
(opt "counter" n)
module S = struct
open Data_encoding
let balance =
RPC_service.get_service
~description: "Access the balance of a contract."
~query: RPC_query.empty
~output: Tez.encoding
~description:"Access the balance of a contract."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "balance")
let manager_key =
RPC_service.get_service
~description: "Access the manager of a contract."
~query: RPC_query.empty
~output: (option Signature.Public_key.encoding)
~description:"Access the manager of a contract."
~query:RPC_query.empty
~output:(option Signature.Public_key.encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
let delegate =
RPC_service.get_service
~description: "Access the delegate of a contract, if any."
~query: RPC_query.empty
~output: Signature.Public_key_hash.encoding
~description:"Access the delegate of a contract, if any."
~query:RPC_query.empty
~output:Signature.Public_key_hash.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "delegate")
let counter =
RPC_service.get_service
~description: "Access the counter of a contract, if any."
~query: RPC_query.empty
~output: z
~description:"Access the counter of a contract, if any."
~query:RPC_query.empty
~output:z
RPC_path.(custom_root /: Contract.rpc_arg / "counter")
let script =
RPC_service.get_service
~description: "Access the code and data of the contract."
~query: RPC_query.empty
~output: Script.encoding
~description:"Access the code and data of the contract."
~query:RPC_query.empty
~output:Script.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "script")
let storage =
RPC_service.get_service
~description: "Access the data of the contract."
~query: RPC_query.empty
~output: Script.expr_encoding
~description:"Access the data of the contract."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
let entrypoint_type =
RPC_service.get_service
~description: "Return the type of the given entrypoint of the contract"
~query: RPC_query.empty
~output: Script.expr_encoding
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)
~description:"Return the type of the given entrypoint of the contract"
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(
custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)
let list_entrypoints =
RPC_service.get_service
~description: "Return the list of entrypoints of the contract"
~query: RPC_query.empty
~output: (obj2
(dft "unreachable"
~description:"Return the list of entrypoints of the contract"
~query:RPC_query.empty
~output:
(obj2
(dft
"unreachable"
(Data_encoding.list
(obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding))))
(obj1
(req
"path"
(Data_encoding.list
Michelson_v1_primitives.prim_encoding))))
[])
(req "entrypoints"
(assoc Script.expr_encoding)))
(req "entrypoints" (assoc Script.expr_encoding)))
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")
let contract_big_map_get_opt =
RPC_service.post_service
~description: "Access the value associated with a key in a big map of the contract (deprecated)."
~query: RPC_query.empty
~input: (obj2
~description:
"Access the value associated with a key in a big map of the contract \
(deprecated)."
~query:RPC_query.empty
~input:
(obj2
(req "key" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output: (option Script.expr_encoding)
~output:(option Script.expr_encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
let big_map_get =
RPC_service.get_service
~description: "Access the value associated with a key in a big map."
~query: RPC_query.empty
~output: Script.expr_encoding
~description:"Access the value associated with a key in a big map."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)
let info =
RPC_service.get_service
~description: "Access the complete status of a contract."
~query: RPC_query.empty
~output: info_encoding
~description:"Access the complete status of a contract."
~query:RPC_query.empty
~output:info_encoding
RPC_path.(custom_root /: Contract.rpc_arg)
let list =
RPC_service.get_service
~description:
"All existing contracts (including non-empty default contracts)."
~query: RPC_query.empty
~output: (list Contract.encoding)
~query:RPC_query.empty
~output:(list Contract.encoding)
custom_root
end
let register () =
let open Services_registration in
register0 S.list begin fun ctxt () () ->
Contract.list ctxt >>= return
end ;
register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ;
let register_field s f =
register1 s (fun ctxt contract () () ->
Contract.exists ctxt contract >>=? function
| true -> f ctxt contract
| false -> raise Not_found) in
Contract.exists ctxt contract
>>=? function true -> f ctxt contract | false -> raise Not_found)
in
let register_opt_field s f =
register_field s
(fun ctxt a1 ->
f ctxt a1 >>=? function
| None -> raise Not_found
| Some v -> return v) in
register_field s (fun ctxt a1 ->
f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v)
in
let do_big_map_get ctxt id key =
let open Script_ir_translator in
let ctxt = Gas.set_unlimited ctxt in
Big_map.exists ctxt id >>=? fun (ctxt, types) ->
Big_map.exists ctxt id
>>=? fun (ctxt, types) ->
match types with
| None -> raise Not_found
| Some (_, value_type) ->
Lwt.return (parse_ty ctxt
~legacy:true ~allow_big_map:false ~allow_operation:false ~allow_contract:true
| None ->
raise Not_found
| Some (_, value_type) -> (
Lwt.return
(parse_ty
ctxt
~legacy:true
~allow_big_map:false
~allow_operation:false
~allow_contract:true
(Micheline.root value_type))
>>=? fun (Ex_ty value_type, ctxt) ->
Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) ->
Big_map.get_opt ctxt id key
>>=? fun (_ctxt, value) ->
match value with
| None -> raise Not_found
| None ->
raise Not_found
| Some value ->
parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (value, ctxt) ->
unparse_data ctxt Readable value_type value >>=? fun (value, _ctxt) ->
return (Micheline.strip_locations value) in
parse_data ctxt ~legacy:true value_type (Micheline.root value)
>>=? fun (value, ctxt) ->
unparse_data ctxt Readable value_type value
>>=? fun (value, _ctxt) -> return (Micheline.strip_locations value)
)
in
register_field S.balance Contract.get_balance ;
register1 S.manager_key
(fun ctxt contract () () ->
register1 S.manager_key (fun ctxt contract () () ->
match Contract.is_implicit contract with
| None -> raise Not_found
| Some mgr ->
Contract.is_manager_key_revealed ctxt mgr >>=? function
| false -> return_none
| true -> Contract.get_manager_key ctxt mgr >>=? return_some) ;
| None ->
raise Not_found
| Some mgr -> (
Contract.is_manager_key_revealed ctxt mgr
>>=? function
| false ->
return_none
| true ->
Contract.get_manager_key ctxt mgr >>=? return_some )) ;
register_opt_field S.delegate Delegate.get ;
register1 S.counter
(fun ctxt contract () () ->
register1 S.counter (fun ctxt contract () () ->
match Contract.is_implicit contract with
| None -> raise Not_found
| Some mgr -> Contract.get_counter ctxt mgr) ;
register_opt_field S.script
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
| None ->
raise Not_found
| Some mgr ->
Contract.get_counter ctxt mgr) ;
register_opt_field S.script (fun c v ->
Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage (fun ctxt contract ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
match script with
| None -> return_none
| None ->
return_none
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
return_some storage) ;
register2 S.entrypoint_type
(fun ctxt v entrypoint () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) ->
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script
>>=? fun (script, ctxt) ->
Script.force_decode ctxt script.storage
>>=? fun (storage, _ctxt) -> return_some storage) ;
register2 S.entrypoint_type (fun ctxt v entrypoint () () ->
Contract.get_script_code ctxt v
>>=? fun (_, expr) ->
match expr with
| None -> raise Not_found
| Some expr ->
| None ->
raise Not_found
| Some expr -> (
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode ctxt expr >>=? fun (expr, _) ->
Script.force_decode ctxt expr
>>=? fun (expr, _) ->
Lwt.return
begin
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
parse_ty ctxt ~legacy
~allow_big_map:true ~allow_operation:false
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.find_entrypoint ~root_name arg_type
entrypoint
end >>= function
Ok (_f , Ex_ty ty)->
unparse_ty ctxt ty >>=? fun (ty_node, _) ->
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
)
>>= function
| Ok (_f, Ex_ty ty) ->
unparse_ty ctxt ty
>>=? fun (ty_node, _) ->
return (Micheline.strip_locations ty_node)
| Error _ -> raise Not_found) ;
register1 S.list_entrypoints
(fun ctxt v () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) ->
| Error _ ->
raise Not_found )) ;
register1 S.list_entrypoints (fun ctxt v () () ->
Contract.get_script_code ctxt v
>>=? fun (_, expr) ->
match expr with
| None -> raise Not_found
| None ->
raise Not_found
| Some expr ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode ctxt expr >>=? fun (expr, _) ->
Script.force_decode ctxt expr
>>=? fun (expr, _) ->
Lwt.return
begin
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
parse_ty ctxt ~legacy
~allow_big_map:true ~allow_operation:false
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt
end >>=? fun (unreachable_entrypoint,map) ->
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
>>=? fun (unreachable_entrypoint, map) ->
return
(unreachable_entrypoint,
( unreachable_entrypoint,
Entrypoints_map.fold
begin fun entry (_,ty) acc ->
(entry , Micheline.strip_locations ty) ::acc end
map [])
) ;
(fun entry (_, ty) acc ->
(entry, Micheline.strip_locations ty) :: acc)
map
[] )) ;
register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
Lwt.return (Script_ir_translator.parse_packable_ty ctxt ~legacy:true (Micheline.root key_type)) >>=? fun (Ex_ty key_type, ctxt) ->
Script_ir_translator.parse_data ctxt ~legacy:true key_type (Micheline.root key) >>=? fun (key, ctxt) ->
Script_ir_translator.hash_data ctxt key_type key >>=? fun (key, ctxt) ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
Lwt.return
(Script_ir_translator.parse_packable_ty
ctxt
~legacy:true
(Micheline.root key_type))
>>=? fun (Ex_ty key_type, ctxt) ->
Script_ir_translator.parse_data
ctxt
~legacy:true
key_type
(Micheline.root key)
>>=? fun (key, ctxt) ->
Script_ir_translator.hash_data ctxt key_type key
>>=? fun (key, ctxt) ->
match script with
| None -> raise Not_found
| None ->
raise Not_found
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
Script_ir_translator.collect_big_maps ctxt script.storage_type script.storage >>=? fun (ids, _ctxt) ->
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
Script_ir_translator.collect_big_maps
ctxt
script.storage_type
script.storage
>>=? fun (ids, _ctxt) ->
let ids = Script_ir_translator.list_of_big_map_ids ids in
let rec find = function
| [] -> return_none
| (id : Z.t) :: ids -> try do_big_map_get ctxt id key >>=? return_some with Not_found -> find ids in
| [] ->
return_none
| (id : Z.t) :: ids -> (
try do_big_map_get ctxt id key >>=? return_some
with Not_found -> find ids )
in
find ids) ;
register2 S.big_map_get (fun ctxt id key () () ->
do_big_map_get ctxt id key) ;
register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ;
register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract >>=? fun balance ->
Delegate.get ctxt contract >>=? fun delegate ->
begin match Contract.is_implicit contract with
Contract.get_balance ctxt contract
>>=? fun balance ->
Delegate.get ctxt contract
>>=? fun delegate ->
( match Contract.is_implicit contract with
| Some manager ->
Contract.get_counter ctxt manager >>=? fun counter ->
return_some counter
| None -> return None
end >>=? fun counter ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
begin match script with
| None -> return (None, ctxt)
Contract.get_counter ctxt manager
>>=? fun counter -> return_some counter
| None ->
return None )
>>=? fun counter ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
( match script with
| None ->
return (None, ctxt)
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
return (Some script, ctxt)
end >>=? fun (script, _ctxt) ->
return { balance ; delegate ; script ; counter })
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script
>>=? fun (script, ctxt) -> return (Some script, ctxt) )
>>=? fun (script, _ctxt) -> return {balance; delegate; script; counter})
let list ctxt block =
RPC_context.make_call0 S.list ctxt block () ()
let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()
let info ctxt block contract =
RPC_context.make_call1 S.info ctxt block contract () ()
@ -310,7 +377,13 @@ let balance ctxt block contract =
RPC_context.make_call1 S.balance ctxt block contract () ()
let manager_key ctxt block mgr =
RPC_context.make_call1 S.manager_key ctxt block (Contract.implicit_contract mgr) () ()
RPC_context.make_call1
S.manager_key
ctxt
block
(Contract.implicit_contract mgr)
()
()
let delegate ctxt block contract =
RPC_context.make_call1 S.delegate ctxt block contract () ()
@ -319,7 +392,13 @@ let delegate_opt ctxt block contract =
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
let counter ctxt block mgr =
RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr) () ()
RPC_context.make_call1
S.counter
ctxt
block
(Contract.implicit_contract mgr)
()
()
let script ctxt block contract =
RPC_context.make_call1 S.script ctxt block contract () ()

112
vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli vendored
View File

@ -25,61 +25,95 @@
open Alpha_context
val list:
'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t
val list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t
type info = {
balance: Tez.t ;
delegate: public_key_hash option ;
counter: counter option ;
script: Script.t option ;
balance : Tez.t;
delegate : public_key_hash option;
counter : counter option;
script : Script.t option;
}
val info_encoding: info Data_encoding.t
val info_encoding : info Data_encoding.t
val info:
val info :
'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t
val balance:
val balance :
'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t
val manager_key:
'a #RPC_context.simple -> 'a -> public_key_hash -> public_key option shell_tzresult Lwt.t
val manager_key :
'a #RPC_context.simple ->
'a ->
public_key_hash ->
public_key option shell_tzresult Lwt.t
val delegate:
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t
val delegate :
'a #RPC_context.simple ->
'a ->
Contract.t ->
public_key_hash shell_tzresult Lwt.t
val delegate_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t
val delegate_opt :
'a #RPC_context.simple ->
'a ->
Contract.t ->
public_key_hash option shell_tzresult Lwt.t
val counter:
'a #RPC_context.simple -> 'a -> public_key_hash -> counter shell_tzresult Lwt.t
val counter :
'a #RPC_context.simple ->
'a ->
public_key_hash ->
counter shell_tzresult Lwt.t
val script:
val script :
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t
val script_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t option shell_tzresult Lwt.t
val script_opt :
'a #RPC_context.simple ->
'a ->
Contract.t ->
Script.t option shell_tzresult Lwt.t
val storage:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t
val entrypoint_type:
'a #RPC_context.simple -> 'a -> Contract.t -> string -> Script.expr shell_tzresult Lwt.t
val list_entrypoints:
'a #RPC_context.simple -> 'a -> Contract.t ->
(Michelson_v1_primitives.prim list list *
(string * Script.expr) list) shell_tzresult Lwt.t
val storage_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t
val big_map_get:
'a #RPC_context.simple -> 'a -> Z.t -> Script_expr_hash.t ->
val storage :
'a #RPC_context.simple ->
'a ->
Contract.t ->
Script.expr shell_tzresult Lwt.t
val contract_big_map_get_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t
val entrypoint_type :
'a #RPC_context.simple ->
'a ->
Contract.t ->
string ->
Script.expr shell_tzresult Lwt.t
val register: unit -> unit
val list_entrypoints :
'a #RPC_context.simple ->
'a ->
Contract.t ->
(Michelson_v1_primitives.prim list list * (string * Script.expr) list)
shell_tzresult
Lwt.t
val storage_opt :
'a #RPC_context.simple ->
'a ->
Contract.t ->
Script.expr option shell_tzresult Lwt.t
val big_map_get :
'a #RPC_context.simple ->
'a ->
Z.t ->
Script_expr_hash.t ->
Script.expr shell_tzresult Lwt.t
val contract_big_map_get_opt :
'a #RPC_context.simple ->
'a ->
Contract.t ->
Script.expr * Script.expr ->
Script.expr option shell_tzresult Lwt.t
val register : unit -> unit

727
vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml vendored
View File

@ -24,28 +24,49 @@
(*****************************************************************************)
type error +=
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *)
| Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *)
| Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *)
| Unspendable_contract of Contract_repr.contract (* `Permanent *)
| Non_existing_contract of Contract_repr.contract (* `Temporary *)
| Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *)
| Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *)
| Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *)
| Failure of string (* `Permanent *)
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
| (* `Temporary *)
Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
| (* `Branch *)
Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
| (* `Temporary *)
Unspendable_contract of Contract_repr.contract
| (* `Permanent *)
Non_existing_contract of Contract_repr.contract
| (* `Temporary *)
Empty_implicit_contract of Signature.Public_key_hash.t
| (* `Temporary *)
Empty_implicit_delegated_contract of
Signature.Public_key_hash.t
| (* `Temporary *)
Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of
Signature.Public_key.t
* Signature.Public_key_hash.t
* Signature.Public_key_hash.t
| (* `Permanent *)
Inconsistent_public_key of
Signature.Public_key.t * Signature.Public_key.t
| (* `Permanent *)
Failure of string (* `Permanent *)
| Previously_revealed_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t
(* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"contract.unspendable_contract"
~title:"Unspendable contract"
~description:"An operation tried to spend tokens from an unspendable contract"
~description:
"An operation tried to spend tokens from an unspendable contract"
~pp:(fun ppf c ->
Format.fprintf ppf "The tokens of contract %a can only be spent by its script"
Contract_repr.pp c)
Format.fprintf
ppf
"The tokens of contract %a can only be spent by its script"
Contract_repr.pp
c)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unspendable_contract c -> Some c | _ -> None)
(fun c -> Unspendable_contract c) ;
@ -53,11 +74,20 @@ let () =
`Temporary
~id:"contract.balance_too_low"
~title:"Balance too low"
~description:"An operation tried to spend more tokens than the contract has"
~description:
"An operation tried to spend more tokens than the contract has"
~pp:(fun ppf (c, b, a) ->
Format.fprintf ppf "Balance of contract %a too low (%a) to spend %a"
Contract_repr.pp c Tez_repr.pp b Tez_repr.pp a)
Data_encoding.(obj3
Format.fprintf
ppf
"Balance of contract %a too low (%a) to spend %a"
Contract_repr.pp
c
Tez_repr.pp
b
Tez_repr.pp
a)
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "balance" Tez_repr.encoding)
(req "amount" Tez_repr.encoding))
@ -69,13 +99,15 @@ let () =
~title:"Invalid counter (not yet reached) in a manager operation"
~description:"An operation assumed a contract counter in the future"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf ppf
Format.fprintf
ppf
"Counter %s not yet reached for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp contract
Contract_repr.pp
contract
(Z.to_string exp))
Data_encoding.
(obj3
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
@ -87,13 +119,15 @@ let () =
~title:"Invalid counter (already used) in a manager operation"
~description:"An operation assumed a contract counter in the past"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf ppf
Format.fprintf
ppf
"Counter %s already used for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp contract
Contract_repr.pp
contract
(Z.to_string exp))
Data_encoding.
(obj3
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
@ -103,11 +137,11 @@ let () =
`Temporary
~id:"contract.non_existing_contract"
~title:"Non existing contract"
~description:"A contract handle is not present in the context \
(either it never was or it has been destroyed)"
~description:
"A contract handle is not present in the context (either it never was \
or it has been destroyed)"
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract %a does not exist"
Contract_repr.pp contract)
Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Non_existing_contract c -> Some c | _ -> None)
(fun c -> Non_existing_contract c) ;
@ -115,13 +149,19 @@ let () =
`Permanent
~id:"contract.manager.inconsistent_hash"
~title:"Inconsistent public key hash"
~description:"A revealed manager public key is inconsistent with the announced hash"
~description:
"A revealed manager public key is inconsistent with the announced hash"
~pp:(fun ppf (k, eh, ph) ->
Format.fprintf ppf "The hash of the manager public key %s is not %a as announced but %a"
Format.fprintf
ppf
"The hash of the manager public key %s is not %a as announced but %a"
(Signature.Public_key.to_b58check k)
Signature.Public_key_hash.pp ph
Signature.Public_key_hash.pp eh)
Data_encoding.(obj3
Signature.Public_key_hash.pp
ph
Signature.Public_key_hash.pp
eh)
Data_encoding.(
obj3
(req "public_key" Signature.Public_key.encoding)
(req "expected_hash" Signature.Public_key_hash.encoding)
(req "provided_hash" Signature.Public_key_hash.encoding))
@ -131,12 +171,17 @@ let () =
`Permanent
~id:"contract.manager.inconsistent_public_key"
~title:"Inconsistent public key"
~description:"A provided manager public key is different with the public key stored in the contract"
~description:
"A provided manager public key is different with the public key stored \
in the contract"
~pp:(fun ppf (eh, ph) ->
Format.fprintf ppf "Expected manager public key %s but %s was provided"
Format.fprintf
ppf
"Expected manager public key %s but %s was provided"
(Signature.Public_key.to_b58check ph)
(Signature.Public_key.to_b58check eh))
Data_encoding.(obj2
Data_encoding.(
obj2
(req "public_key" Signature.Public_key.encoding)
(req "expected_public_key" Signature.Public_key.encoding))
(function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
@ -155,11 +200,14 @@ let () =
~id:"contract.unrevealed_key"
~title:"Manager operation precedes key revelation"
~description:
"One tried to apply a manager operation \
without revealing the manager public key"
"One tried to apply a manager operation without revealing the manager \
public key"
~pp:(fun ppf s ->
Format.fprintf ppf "Unrevealed manager key for contract %a."
Contract_repr.pp s)
Format.fprintf
ppf
"Unrevealed manager key for contract %a."
Contract_repr.pp
s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unrevealed_manager_key s -> Some s | _ -> None)
(fun s -> Unrevealed_manager_key s) ;
@ -167,11 +215,13 @@ let () =
`Branch
~id:"contract.previously_revealed_key"
~title:"Manager operation already revealed"
~description:
"One tried to revealed twice a manager public key"
~description:"One tried to revealed twice a manager public key"
~pp:(fun ppf s ->
Format.fprintf ppf "Previously revealed manager key for contract %a."
Contract_repr.pp s)
Format.fprintf
ppf
"Previously revealed manager key for contract %a."
Contract_repr.pp
s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Previously_revealed_key s -> Some s | _ -> None)
(fun s -> Previously_revealed_key s) ;
@ -179,23 +229,43 @@ let () =
`Branch
~id:"implicit.empty_implicit_contract"
~title:"Empty implicit contract"
~description:"No manager operations are allowed on an empty implicit contract."
~description:
"No manager operations are allowed on an empty implicit contract."
~pp:(fun ppf implicit ->
Format.fprintf ppf
Format.fprintf
ppf
"Empty implicit contract (%a)"
Signature.Public_key_hash.pp implicit)
Signature.Public_key_hash.pp
implicit)
Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
(function Empty_implicit_contract c -> Some c | _ -> None)
(fun c -> Empty_implicit_contract c) ;
register_error_kind
`Branch
~id:"implicit.empty_implicit_delegated_contract"
~title:"Empty implicit delegated contract"
~description:"Emptying an implicit delegated account is not allowed."
~pp:(fun ppf implicit ->
Format.fprintf
ppf
"Emptying implicit delegated contract (%a)"
Signature.Public_key_hash.pp
implicit)
Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
(function Empty_implicit_delegated_contract c -> Some c | _ -> None)
(fun c -> Empty_implicit_delegated_contract c) ;
register_error_kind
`Branch
~id:"contract.empty_transaction"
~title:"Empty transaction"
~description:"Forbidden to credit 0ꜩ to a contract without code."
~pp:(fun ppf contract ->
Format.fprintf ppf
"Transaction of 0ꜩ towards a contract without code are forbidden (%a)."
Contract_repr.pp contract)
Format.fprintf
ppf
"Transaction of 0ꜩ towards a contract without code are forbidden \
(%a)."
Contract_repr.pp
contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Empty_transaction c -> Some c | _ -> None)
(fun c -> Empty_transaction c)
@ -222,7 +292,9 @@ type big_map_diff = big_map_diff_item list
let big_map_diff_item_encoding =
let open Data_encoding in
union
[ case (Tag 0) ~title:"update"
[ case
(Tag 0)
~title:"update"
(obj5
(req "action" (constant "update"))
(req "big_map" z)
@ -230,157 +302,196 @@ let big_map_diff_item_encoding =
(req "key" Script_repr.expr_encoding)
(opt "value" Script_repr.expr_encoding))
(function
| Update { big_map ; diff_key_hash ; diff_key ; diff_value } ->
| Update {big_map; diff_key_hash; diff_key; diff_value} ->
Some ((), big_map, diff_key_hash, diff_key, diff_value)
| _ -> None )
| _ ->
None)
(fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
Update { big_map ; diff_key_hash ; diff_key ; diff_value }) ;
case (Tag 1) ~title:"remove"
(obj2
(req "action" (constant "remove"))
(req "big_map" z))
(function
| Clear big_map ->
Some ((), big_map)
| _ -> None )
(fun ((), big_map) ->
Clear big_map) ;
case (Tag 2) ~title:"copy"
Update {big_map; diff_key_hash; diff_key; diff_value});
case
(Tag 1)
~title:"remove"
(obj2 (req "action" (constant "remove")) (req "big_map" z))
(function Clear big_map -> Some ((), big_map) | _ -> None)
(fun ((), big_map) -> Clear big_map);
case
(Tag 2)
~title:"copy"
(obj3
(req "action" (constant "copy"))
(req "source_big_map" z)
(req "destination_big_map" z))
(function
| Copy (src, dst) ->
Some ((), src, dst)
| _ -> None )
(fun ((), src, dst) ->
Copy (src, dst)) ;
case (Tag 3) ~title:"alloc"
(function Copy (src, dst) -> Some ((), src, dst) | _ -> None)
(fun ((), src, dst) -> Copy (src, dst));
case
(Tag 3)
~title:"alloc"
(obj4
(req "action" (constant "alloc"))
(req "big_map" z)
(req "key_type" Script_repr.expr_encoding)
(req "value_type" Script_repr.expr_encoding))
(function
| Alloc { big_map ; key_type ; value_type } ->
| Alloc {big_map; key_type; value_type} ->
Some ((), big_map, key_type, value_type)
| _ -> None )
| _ ->
None)
(fun ((), big_map, key_type, value_type) ->
Alloc { big_map ; key_type ; value_type }) ]
Alloc {big_map; key_type; value_type}) ]
let big_map_diff_encoding =
let open Data_encoding in
def "contract.big_map_diff" @@
list big_map_diff_item_encoding
def "contract.big_map_diff" @@ list big_map_diff_item_encoding
let big_map_key_cost = 65
let big_map_cost = 33
let update_script_big_map c = function
| None -> return (c, Z.zero)
| None ->
return (c, Z.zero)
| Some diff ->
fold_left_s (fun (c, total) -> function
| Clear id ->
Storage.Big_map.Total_bytes.get c id >>=? fun size ->
Storage.Big_map.remove_rec c id >>= fun c ->
if Compare.Z.(id < Z.zero) then
return (c, total)
else
return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
fold_left_s
(fun (c, total) -> function Clear id ->
Storage.Big_map.Total_bytes.get c id
>>=? fun size ->
Storage.Big_map.remove_rec c id
>>= fun c ->
if Compare.Z.(id < Z.zero) then return (c, total)
else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
| Copy (from, to_) ->
Storage.Big_map.copy c ~from ~to_ >>=? fun c ->
if Compare.Z.(to_ < Z.zero) then
return (c, total)
Storage.Big_map.copy c ~from ~to_
>>=? fun c ->
if Compare.Z.(to_ < Z.zero) then return (c, total)
else
Storage.Big_map.Total_bytes.get c from >>=? fun size ->
Storage.Big_map.Total_bytes.get c from
>>=? fun size ->
return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
| Alloc { big_map ; key_type ; value_type } ->
Storage.Big_map.Total_bytes.init c big_map Z.zero >>=? fun c ->
| Alloc {big_map; key_type; value_type} ->
Storage.Big_map.Total_bytes.init c big_map Z.zero
>>=? fun c ->
(* Annotations are erased to allow sharing on
[Copy]. The types from the contract code are used,
these ones are only used to make sure they are
compatible during transmissions between contracts,
and only need to be compatible, annotations
nonwhistanding. *)
let key_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root key_type)) in
let value_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root value_type)) in
Storage.Big_map.Key_type.init c big_map key_type >>=? fun c ->
Storage.Big_map.Value_type.init c big_map value_type >>=? fun c ->
if Compare.Z.(big_map < Z.zero) then
return (c, total)
else
return (c, Z.add total (Z.of_int big_map_cost))
| Update { big_map ; diff_key_hash ; diff_value = None } ->
let key_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type))
in
let value_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
Storage.Big_map.Key_type.init c big_map key_type
>>=? fun c ->
Storage.Big_map.Value_type.init c big_map value_type
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int big_map_cost))
| Update {big_map; diff_key_hash; diff_value = None} ->
Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
>>=? fun (c, freed, existed) ->
let freed = if existed then freed + big_map_key_cost else freed in
Storage.Big_map.Total_bytes.get c big_map >>=? fun size ->
Storage.Big_map.Total_bytes.set c big_map (Z.sub size (Z.of_int freed)) >>=? fun c ->
if Compare.Z.(big_map < Z.zero) then
return (c, total)
else
return (c, Z.sub total (Z.of_int freed))
| Update { big_map ; diff_key_hash ; diff_value = Some v } ->
let freed =
if existed then freed + big_map_key_cost else freed
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.sub size (Z.of_int freed))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.sub total (Z.of_int freed))
| Update {big_map; diff_key_hash; diff_value = Some v} ->
Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
>>=? fun (c, size_diff, existed) ->
let size_diff = if existed then size_diff else size_diff + big_map_key_cost in
Storage.Big_map.Total_bytes.get c big_map >>=? fun size ->
Storage.Big_map.Total_bytes.set c big_map (Z.add size (Z.of_int size_diff)) >>=? fun c ->
if Compare.Z.(big_map < Z.zero) then
return (c, total)
else
return (c, Z.add total (Z.of_int size_diff)))
(c, Z.zero) diff
let size_diff =
if existed then size_diff else size_diff + big_map_key_cost
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.add size (Z.of_int size_diff))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int size_diff)))
(c, Z.zero)
diff
let create_base c
?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *)
contract
~balance ~manager ~delegate ?script () =
begin match Contract_repr.is_implicit contract with
| None -> return c
let create_base c ?(prepaid_bootstrap_storage = false)
(* Free space for bootstrap contracts *)
contract ~balance ~manager ~delegate ?script () =
( match Contract_repr.is_implicit contract with
| None ->
return c
| Some _ ->
Storage.Contract.Global_counter.get c >>=? fun counter ->
Storage.Contract.Counter.init c contract counter
end >>=? fun c ->
Storage.Contract.Balance.init c contract balance >>=? fun c ->
begin match manager with
Storage.Contract.Global_counter.get c
>>=? fun counter -> Storage.Contract.Counter.init c contract counter )
>>=? fun c ->
Storage.Contract.Balance.init c contract balance
>>=? fun c ->
( match manager with
| Some manager ->
Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
| None -> return c
end >>=? fun c ->
begin
match delegate with
| None -> return c
| None ->
return c )
>>=? fun c ->
( match delegate with
| None ->
return c
| Some delegate ->
Delegate_storage.init c contract delegate
end >>=? fun c ->
Delegate_storage.init c contract delegate )
>>=? fun c ->
match script with
| Some ({ Script_repr.code ; storage }, big_map_diff) ->
Storage.Contract.Code.init c contract code >>=? fun (c, code_size) ->
Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) ->
update_script_big_map c big_map_diff >>=? fun (c, big_map_size) ->
let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in
assert Compare.Z.(total_size >= Z.zero) ;
let prepaid_bootstrap_storage =
if prepaid_bootstrap_storage then
total_size
else
Z.zero
| Some ({Script_repr.code; storage}, big_map_diff) ->
Storage.Contract.Code.init c contract code
>>=? fun (c, code_size) ->
Storage.Contract.Storage.init c contract storage
>>=? fun (c, storage_size) ->
update_script_big_map c big_map_diff
>>=? fun (c, big_map_size) ->
let total_size =
Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size
in
Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c ->
assert (Compare.Z.(total_size >= Z.zero)) ;
let prepaid_bootstrap_storage =
if prepaid_bootstrap_storage then total_size else Z.zero
in
Storage.Contract.Paid_storage_space.init
c
contract
prepaid_bootstrap_storage
>>=? fun c ->
Storage.Contract.Used_storage_space.init c contract total_size
| None ->
return c
let originate c ?prepaid_bootstrap_storage contract
~balance ~script ~delegate =
create_base c ?prepaid_bootstrap_storage contract ~balance
~manager:None ~delegate ~script ()
let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate
=
create_base
c
?prepaid_bootstrap_storage
contract
~balance
~manager:None
~delegate
~script
()
let create_implicit c manager ~balance =
create_base c (Contract_repr.implicit_contract manager)
~balance ~manager:(Some manager) ?script:None ~delegate:None ()
create_base
c
(Contract_repr.implicit_contract manager)
~balance
~manager:(Some manager)
?script:None
~delegate:None
()
let delete c contract =
match Contract_repr.is_implicit contract with
@ -388,215 +499,255 @@ let delete c contract =
(* For non implicit contract Big_map should be cleared *)
failwith "Non implicit contracts cannot be removed"
| Some _ ->
Delegate_storage.remove c contract >>=? fun c ->
Storage.Contract.Balance.delete c contract >>=? fun c ->
Storage.Contract.Manager.delete c contract >>=? fun c ->
Storage.Contract.Counter.delete c contract >>=? fun c ->
Storage.Contract.Code.remove c contract >>=? fun (c, _, _) ->
Storage.Contract.Storage.remove c contract >>=? fun (c, _, _) ->
Storage.Contract.Paid_storage_space.remove c contract >>= fun c ->
Storage.Contract.Used_storage_space.remove c contract >>= fun c ->
return c
Delegate_storage.remove c contract
>>=? fun c ->
Storage.Contract.Balance.delete c contract
>>=? fun c ->
Storage.Contract.Manager.delete c contract
>>=? fun c ->
Storage.Contract.Counter.delete c contract
>>=? fun c ->
Storage.Contract.Code.remove c contract
>>=? fun (c, _, _) ->
Storage.Contract.Storage.remove c contract
>>=? fun (c, _, _) ->
Storage.Contract.Paid_storage_space.remove c contract
>>= fun c ->
Storage.Contract.Used_storage_space.remove c contract
>>= fun c -> return c
let allocated c contract =
Storage.Contract.Balance.get_option c contract >>=? function
| None -> return_false
| Some _ -> return_true
Storage.Contract.Balance.get_option c contract
>>=? function None -> return_false | Some _ -> return_true
let exists c contract =
match Contract_repr.is_implicit contract with
| Some _ -> return_true
| None -> allocated c contract
| Some _ ->
return_true
| None ->
allocated c contract
let must_exist c contract =
exists c contract >>=? function
| true -> return_unit
| false -> fail (Non_existing_contract contract)
exists c contract
>>=? function
| true -> return_unit | false -> fail (Non_existing_contract contract)
let must_be_allocated c contract =
allocated c contract >>=? function
| true -> return_unit
| false ->
allocated c contract
>>=? function
| true ->
return_unit
| false -> (
match Contract_repr.is_implicit contract with
| Some pkh -> fail (Empty_implicit_contract pkh)
| None -> fail (Non_existing_contract contract)
| Some pkh ->
fail (Empty_implicit_contract pkh)
| None ->
fail (Non_existing_contract contract) )
let list c = Storage.Contract.list c
let fresh_contract_from_current_nonce c =
Lwt.return (Raw_context.increment_origination_nonce c) >>=? fun (c, nonce) ->
return (c, Contract_repr.originated_contract nonce)
Lwt.return (Raw_context.increment_origination_nonce c)
>>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce)
let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until =
Lwt.return (Raw_context.origination_nonce ctxt_since) >>=? fun since ->
Lwt.return (Raw_context.origination_nonce ctxt_until) >>=? fun until ->
let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =
Lwt.return (Raw_context.origination_nonce ctxt_since)
>>=? fun since ->
Lwt.return (Raw_context.origination_nonce ctxt_until)
>>=? fun until ->
filter_map_s
(fun contract -> exists ctxt_until contract >>=? function
| true -> return_some contract
| false -> return_none)
(fun contract ->
exists ctxt_until contract
>>=? function true -> return_some contract | false -> return_none)
(Contract_repr.originated_contracts ~since ~until)
let check_counter_increment c manager counter =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
Storage.Contract.Counter.get c contract
>>=? fun contract_counter ->
let expected = Z.succ contract_counter in
if Compare.Z.(expected = counter)
then return_unit
if Compare.Z.(expected = counter) then return_unit
else if Compare.Z.(expected > counter) then
fail (Counter_in_the_past (contract, expected, counter))
else
fail (Counter_in_the_future (contract, expected, counter))
else fail (Counter_in_the_future (contract, expected, counter))
let increment_counter c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Global_counter.get c >>=? fun global_counter ->
Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c ->
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
Storage.Contract.Global_counter.get c
>>=? fun global_counter ->
Storage.Contract.Global_counter.set c (Z.succ global_counter)
>>=? fun c ->
Storage.Contract.Counter.get c contract
>>=? fun contract_counter ->
Storage.Contract.Counter.set c contract (Z.succ contract_counter)
let get_script_code c contract =
Storage.Contract.Code.get_option c contract
let get_script_code c contract = Storage.Contract.Code.get_option c contract
let get_script c contract =
Storage.Contract.Code.get_option c contract >>=? fun (c, code) ->
Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) ->
match code, storage with
| None, None -> return (c, None)
| Some code, Some storage -> return (c, Some { Script_repr.code ; storage })
| None, Some _ | Some _, None -> failwith "get_script"
Storage.Contract.Code.get_option c contract
>>=? fun (c, code) ->
Storage.Contract.Storage.get_option c contract
>>=? fun (c, storage) ->
match (code, storage) with
| (None, None) ->
return (c, None)
| (Some code, Some storage) ->
return (c, Some {Script_repr.code; storage})
| (None, Some _) | (Some _, None) ->
failwith "get_script"
let get_storage ctxt contract =
Storage.Contract.Storage.get_option ctxt contract >>=? function
| (ctxt, None) -> return (ctxt, None)
Storage.Contract.Storage.get_option ctxt contract
>>=? function
| (ctxt, None) ->
return (ctxt, None)
| (ctxt, Some storage) ->
Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, cost) ->
Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt ->
return (ctxt, Some storage)
Lwt.return (Script_repr.force_decode storage)
>>=? fun (storage, cost) ->
Lwt.return (Raw_context.consume_gas ctxt cost)
>>=? fun ctxt -> return (ctxt, Some storage)
let get_counter c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Counter.get_option c contract >>=? function
| None -> begin
Storage.Contract.Counter.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| Some _ -> Storage.Contract.Global_counter.get c
| None -> failwith "get_counter"
end
| Some v -> return v
let get_manager_004 c contract =
Storage.Contract.Manager.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
| Some manager -> return manager
| None -> failwith "get_manager"
end
| Some (Manager_repr.Hash v) -> return v
| Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v)
| Some _ ->
Storage.Contract.Global_counter.get c
| None ->
failwith "get_counter" )
| Some v ->
return v
let get_manager_key c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get_option c contract >>=? function
| None -> failwith "get_manager_key"
| Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract)
| Some (Manager_repr.Public_key v) -> return v
Storage.Contract.Manager.get_option c contract
>>=? function
| None ->
failwith "get_manager_key"
| Some (Manager_repr.Hash _) ->
fail (Unrevealed_manager_key contract)
| Some (Manager_repr.Public_key v) ->
return v
let is_manager_key_revealed c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get_option c contract >>=? function
| None -> return_false
| Some (Manager_repr.Hash _) -> return_false
| Some (Manager_repr.Public_key _) -> return_true
Storage.Contract.Manager.get_option c contract
>>=? function
| None ->
return_false
| Some (Manager_repr.Hash _) ->
return_false
| Some (Manager_repr.Public_key _) ->
return_true
let reveal_manager_key c manager public_key =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get c contract >>=? function
| Public_key _ -> fail (Previously_revealed_key contract)
Storage.Contract.Manager.get c contract
>>=? function
| Public_key _ ->
fail (Previously_revealed_key contract)
| Hash v ->
let actual_hash = Signature.Public_key.hash public_key in
if (Signature.Public_key_hash.equal actual_hash v) then
let v = (Manager_repr.Public_key public_key) in
Storage.Contract.Manager.set c contract v >>=? fun c ->
return c
else fail (Inconsistent_hash (public_key,v,actual_hash))
if Signature.Public_key_hash.equal actual_hash v then
let v = Manager_repr.Public_key public_key in
Storage.Contract.Manager.set c contract v >>=? fun c -> return c
else fail (Inconsistent_hash (public_key, v, actual_hash))
let get_balance c contract =
Storage.Contract.Balance.get_option c contract >>=? function
| None -> begin
Storage.Contract.Balance.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| Some _ -> return Tez_repr.zero
| None -> failwith "get_balance"
end
| Some v -> return v
| Some _ ->
return Tez_repr.zero
| None ->
failwith "get_balance" )
| Some v ->
return v
let update_script_storage c contract storage big_map_diff =
let storage = Script_repr.lazy_expr storage in
update_script_big_map c big_map_diff >>=? fun (c, big_map_size_diff) ->
Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->
let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in
update_script_big_map c big_map_diff
>>=? fun (c, big_map_size_diff) ->
Storage.Contract.Storage.set c contract storage
>>=? fun (c, size_diff) ->
Storage.Contract.Used_storage_space.get c contract
>>=? fun previous_size ->
let new_size =
Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff))
in
Storage.Contract.Used_storage_space.set c contract new_size
let spend c contract amount =
Storage.Contract.Balance.get c contract >>=? fun balance ->
Storage.Contract.Balance.get c contract
>>=? fun balance ->
match Tez_repr.(balance -? amount) with
| Error _ ->
fail (Balance_too_low (contract, balance, amount))
| Ok new_balance ->
Storage.Contract.Balance.set c contract new_balance >>=? fun c ->
Roll_storage.Contract.remove_amount c contract amount >>=? fun c ->
if Tez_repr.(new_balance > Tez_repr.zero) then
return c
else match Contract_repr.is_implicit contract with
| None -> return c (* Never delete originated contracts *)
| Some pkh ->
Delegate_storage.get c contract >>=? function
| Ok new_balance -> (
Storage.Contract.Balance.set c contract new_balance
>>=? fun c ->
Roll_storage.Contract.remove_amount c contract amount
>>=? fun c ->
if Tez_repr.(new_balance > Tez_repr.zero) then return c
else
match Contract_repr.is_implicit contract with
| None ->
return c (* Never delete originated contracts *)
| Some pkh -> (
Delegate_storage.get c contract
>>=? function
| Some pkh' ->
(* Don't delete "delegate" contract *)
assert (Signature.Public_key_hash.equal pkh pkh') ;
return c
if Signature.Public_key_hash.equal pkh pkh' then return c
else
(* Delegated implicit accounts cannot be emptied *)
fail (Empty_implicit_delegated_contract pkh)
| None ->
(* Delete empty implicit contract *)
delete c contract
delete c contract ) )
let credit c contract amount =
begin
if Tez_repr.(amount <> Tez_repr.zero) then
return c
( if Tez_repr.(amount <> Tez_repr.zero) then return c
else
Storage.Contract.Code.mem c contract >>=? fun (c, target_has_code) ->
fail_unless target_has_code (Empty_transaction contract) >>=? fun () ->
return c
end >>=? fun c ->
Storage.Contract.Balance.get_option c contract >>=? function
| None -> begin
Storage.Contract.Code.mem c contract
>>=? fun (c, target_has_code) ->
fail_unless target_has_code (Empty_transaction contract)
>>=? fun () -> return c )
>>=? fun c ->
Storage.Contract.Balance.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| None -> fail (Non_existing_contract contract)
| None ->
fail (Non_existing_contract contract)
| Some manager ->
create_implicit c manager ~balance:amount
end
create_implicit c manager ~balance:amount )
| Some balance ->
Lwt.return Tez_repr.(amount +? balance) >>=? fun balance ->
Storage.Contract.Balance.set c contract balance >>=? fun c ->
Roll_storage.Contract.add_amount c contract amount
Lwt.return Tez_repr.(amount +? balance)
>>=? fun balance ->
Storage.Contract.Balance.set c contract balance
>>=? fun c -> Roll_storage.Contract.add_amount c contract amount
let init c =
Storage.Contract.Global_counter.init c Z.zero
>>=? fun c -> Storage.Big_map.Next.init c
let used_storage_space c contract =
Storage.Contract.Used_storage_space.get_option c contract >>=? function
| None -> return Z.zero
| Some fees -> return fees
Storage.Contract.Used_storage_space.get_option c contract
>>=? function None -> return Z.zero | Some fees -> return fees
let paid_storage_space c contract =
Storage.Contract.Paid_storage_space.get_option c contract >>=? function
| None -> return Z.zero
| Some paid_space -> return paid_space
Storage.Contract.Paid_storage_space.get_option c contract
>>=? function None -> return Z.zero | Some paid_space -> return paid_space
let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space =
Storage.Contract.Paid_storage_space.get c contract >>=? fun already_paid_space ->
if Compare.Z.(already_paid_space >= new_storage_space) then
return (Z.zero, c)
let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space
=
Storage.Contract.Paid_storage_space.get c contract
>>=? fun already_paid_space ->
if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)
else
let to_pay = Z.sub new_storage_space already_paid_space in
Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c ->
return (to_pay, c)
Storage.Contract.Paid_storage_space.set c contract new_storage_space
>>=? fun c -> return (to_pay, c)

141
vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli vendored
View File

@ -24,60 +24,89 @@
(*****************************************************************************)
type error +=
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *)
| Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *)
| Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *)
| Unspendable_contract of Contract_repr.contract (* `Permanent *)
| Non_existing_contract of Contract_repr.contract (* `Temporary *)
| Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *)
| Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *)
| Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *)
| Failure of string (* `Permanent *)
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
| (* `Temporary *)
Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
| (* `Branch *)
Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
| (* `Temporary *)
Unspendable_contract of Contract_repr.contract
| (* `Permanent *)
Non_existing_contract of Contract_repr.contract
| (* `Temporary *)
Empty_implicit_contract of Signature.Public_key_hash.t
| (* `Temporary *)
Empty_implicit_delegated_contract of
Signature.Public_key_hash.t
| (* `Temporary *)
Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of
Signature.Public_key.t
* Signature.Public_key_hash.t
* Signature.Public_key_hash.t
| (* `Permanent *)
Inconsistent_public_key of
Signature.Public_key.t * Signature.Public_key.t
| (* `Permanent *)
Failure of string (* `Permanent *)
| Previously_revealed_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t
val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
(* `Permanent *)
val allocated: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
val exists : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
val list: Raw_context.t -> Contract_repr.t list Lwt.t
val allocated : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val check_counter_increment:
val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
val list : Raw_context.t -> Contract_repr.t list Lwt.t
val check_counter_increment :
Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t
val increment_counter:
val increment_counter :
Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t
val get_manager_004:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t
val get_manager_key :
Raw_context.t ->
Signature.Public_key_hash.t ->
Signature.Public_key.t tzresult Lwt.t
val get_manager_key:
Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t
val is_manager_key_revealed:
val is_manager_key_revealed :
Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
val reveal_manager_key:
Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t ->
val reveal_manager_key :
Raw_context.t ->
Signature.Public_key_hash.t ->
Signature.Public_key.t ->
Raw_context.t tzresult Lwt.t
val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
val get_counter: Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t
val get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
val get_script_code:
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t
val get_script:
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t
val get_storage:
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
val get_counter :
Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t
val get_script_code :
Raw_context.t ->
Contract_repr.t ->
(Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t
val get_script :
Raw_context.t ->
Contract_repr.t ->
(Raw_context.t * Script_repr.t option) tzresult Lwt.t
val get_storage :
Raw_context.t ->
Contract_repr.t ->
(Raw_context.t * Script_repr.expr option) tzresult Lwt.t
type big_map_diff_item =
| Update of {
big_map : Z.t ;
big_map : Z.t;
diff_key : Script_repr.expr;
diff_key_hash : Script_expr_hash.t;
diff_value : Script_repr.expr option;
@ -94,38 +123,50 @@ type big_map_diff = big_map_diff_item list
val big_map_diff_encoding : big_map_diff Data_encoding.t
val update_script_storage:
Raw_context.t -> Contract_repr.t ->
Script_repr.expr -> big_map_diff option ->
val update_script_storage :
Raw_context.t ->
Contract_repr.t ->
Script_repr.expr ->
big_map_diff option ->
Raw_context.t tzresult Lwt.t
val credit:
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
val credit :
Raw_context.t ->
Contract_repr.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val spend:
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
val spend :
Raw_context.t ->
Contract_repr.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val originate:
val originate :
Raw_context.t ->
?prepaid_bootstrap_storage:bool ->
Contract_repr.t ->
balance:Tez_repr.t ->
script:(Script_repr.t * big_map_diff option) ->
script:Script_repr.t * big_map_diff option ->
delegate:Signature.Public_key_hash.t option ->
Raw_context.t tzresult Lwt.t
val fresh_contract_from_current_nonce :
Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t
val originated_from_current_nonce :
since: Raw_context.t ->
until: Raw_context.t ->
since:Raw_context.t ->
until:Raw_context.t ->
Contract_repr.t list tzresult Lwt.t
val init:
Raw_context.t -> Raw_context.t tzresult Lwt.t
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t
val used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
val paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
val set_paid_storage_space_and_return_fees_to_pay :
Raw_context.t ->
Contract_repr.t ->
Z.t ->
(Z.t * Raw_context.t) tzresult Lwt.t

44
vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml vendored
View File

@ -24,18 +24,23 @@
(*****************************************************************************)
type t = int32
type cycle = t
let encoding = Data_encoding.int32
let rpc_arg =
let construct = Int32.to_string in
let destruct str =
match Int32.of_string str with
| exception _ -> Error "Cannot parse cycle"
| cycle -> Ok cycle in
| exception _ ->
Error "Cannot parse cycle"
| cycle ->
Ok cycle
in
RPC_arg.make
~descr:"A cycle integer"
~name: "block_cycle"
~name:"block_cycle"
~construct
~destruct
()
@ -44,42 +49,45 @@ let pp ppf cycle = Format.fprintf ppf "%ld" cycle
include (Compare.Int32 : Compare.S with type t := t)
module Map = Map.Make(Compare.Int32)
module Map = Map.Make (Compare.Int32)
let root = 0l
let succ = Int32.succ
let pred = function
| 0l -> None
| i -> Some (Int32.pred i)
let pred = function 0l -> None | i -> Some (Int32.pred i)
let add c i =
assert Compare.Int.(i > 0) ;
assert (Compare.Int.(i > 0)) ;
Int32.add c (Int32.of_int i)
let sub c i =
assert Compare.Int.(i > 0) ;
assert (Compare.Int.(i > 0)) ;
let r = Int32.sub c (Int32.of_int i) in
if Compare.Int32.(r < 0l) then None else Some r
let to_int32 i = i
let of_int32_exn l =
if Compare.Int32.(l >= 0l)
then l
if Compare.Int32.(l >= 0l) then l
else invalid_arg "Level_repr.Cycle.of_int32"
module Index = struct
type t = cycle
let path_length = 1
let to_path c l =
Int32.to_string (to_int32 c) :: l
let to_path c l = Int32.to_string (to_int32 c) :: l
let of_path = function
| [s] -> begin
try Some (Int32.of_string s)
with _ -> None
end
| _ -> None
| [s] -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end

30
vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli vendored
View File

@ -24,20 +24,30 @@
(*****************************************************************************)
type t
type cycle = t
include Compare.S with type t := t
val encoding: cycle Data_encoding.t
val rpc_arg: cycle RPC_arg.arg
val pp: Format.formatter -> cycle -> unit
val root: cycle
val pred: cycle -> cycle option
val add: cycle -> int -> cycle
val sub: cycle -> int -> cycle option
val succ: cycle -> cycle
val encoding : cycle Data_encoding.t
val to_int32: cycle -> int32
val of_int32_exn: int32 -> cycle
val rpc_arg : cycle RPC_arg.arg
val pp : Format.formatter -> cycle -> unit
val root : cycle
val pred : cycle -> cycle option
val add : cycle -> int -> cycle
val sub : cycle -> int -> cycle option
val succ : cycle -> cycle
val to_int32 : cycle -> int32
val of_int32_exn : int32 -> cycle
module Map : S.MAP with type key = cycle

639
vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml vendored
View File

@ -26,31 +26,53 @@
open Alpha_context
type info = {
balance: Tez.t ;
frozen_balance: Tez.t ;
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
staking_balance: Tez.t ;
delegated_contracts: Contract_repr.t list ;
delegated_balance: Tez.t ;
deactivated: bool ;
grace_period: Cycle.t ;
balance : Tez.t;
frozen_balance : Tez.t;
frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
staking_balance : Tez.t;
delegated_contracts : Contract_repr.t list;
delegated_balance : Tez.t;
deactivated : bool;
grace_period : Cycle.t;
}
let info_encoding =
let open Data_encoding in
conv
(fun { balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period } ->
(balance, frozen_balance, frozen_balance_by_cycle,
staking_balance, delegated_contracts, delegated_balance,
deactivated, grace_period))
(fun (balance, frozen_balance, frozen_balance_by_cycle,
staking_balance, delegated_contracts, delegated_balance,
deactivated, grace_period) ->
{ balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period })
(fun { balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period } ->
( balance,
frozen_balance,
frozen_balance_by_cycle,
staking_balance,
delegated_contracts,
delegated_balance,
deactivated,
grace_period ))
(fun ( balance,
frozen_balance,
frozen_balance_by_cycle,
staking_balance,
delegated_contracts,
delegated_balance,
deactivated,
grace_period ) ->
{
balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period;
})
(obj8
(req "balance" Tez.encoding)
(req "frozen_balance" Tez.encoding)
@ -62,188 +84,180 @@ let info_encoding =
(req "grace_period" Cycle.encoding))
module S = struct
let path = RPC_path.(open_root / "context" / "delegates")
open Data_encoding
type list_query = {
active: bool ;
inactive: bool ;
}
let list_query :list_query RPC_query.t =
type list_query = {active : bool; inactive : bool}
let list_query : list_query RPC_query.t =
let open RPC_query in
query (fun active inactive -> { active ; inactive })
query (fun active inactive -> {active; inactive})
|+ flag "active" (fun t -> t.active)
|+ flag "inactive" (fun t -> t.inactive)
|> seal
let list_delegate =
RPC_service.get_service
~description:
"Lists all registered delegates."
~query: list_query
~output: (list Signature.Public_key_hash.encoding)
~description:"Lists all registered delegates."
~query:list_query
~output:(list Signature.Public_key_hash.encoding)
path
let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)
let info =
RPC_service.get_service
~description:
"Everything about a delegate."
~query: RPC_query.empty
~output: info_encoding
~description:"Everything about a delegate."
~query:RPC_query.empty
~output:info_encoding
path
let balance =
RPC_service.get_service
~description:
"Returns the full balance of a given delegate, \
including the frozen balances."
~query: RPC_query.empty
~output: Tez.encoding
"Returns the full balance of a given delegate, including the frozen \
balances."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "balance")
let frozen_balance =
RPC_service.get_service
~description:
"Returns the total frozen balances of a given delegate, \
this includes the frozen deposits, rewards and fees."
~query: RPC_query.empty
~output: Tez.encoding
"Returns the total frozen balances of a given delegate, this includes \
the frozen deposits, rewards and fees."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "frozen_balance")
let frozen_balance_by_cycle =
RPC_service.get_service
~description:
"Returns the frozen balances of a given delegate, \
indexed by the cycle by which it will be unfrozen"
~query: RPC_query.empty
~output: Delegate.frozen_balance_by_cycle_encoding
"Returns the frozen balances of a given delegate, indexed by the \
cycle by which it will be unfrozen"
~query:RPC_query.empty
~output:Delegate.frozen_balance_by_cycle_encoding
RPC_path.(path / "frozen_balance_by_cycle")
let staking_balance =
RPC_service.get_service
~description:
"Returns the total amount of tokens delegated to a given delegate. \
This includes the balances of all the contracts that delegate \
to it, but also the balance of the delegate itself and its frozen \
fees and deposits. The rewards do not count in the delegated balance \
until they are unfrozen."
~query: RPC_query.empty
~output: Tez.encoding
This includes the balances of all the contracts that delegate to it, \
but also the balance of the delegate itself and its frozen fees and \
deposits. The rewards do not count in the delegated balance until \
they are unfrozen."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "staking_balance")
let delegated_contracts =
RPC_service.get_service
~description:
"Returns the list of contracts that delegate to a given delegate."
~query: RPC_query.empty
~output: (list Contract_repr.encoding)
~query:RPC_query.empty
~output:(list Contract_repr.encoding)
RPC_path.(path / "delegated_contracts")
let delegated_balance =
RPC_service.get_service
~description:
"Returns the balances of all the contracts that delegate to a \
given delegate. This excludes the delegate's own balance and \
its frozen balances."
~query: RPC_query.empty
~output: Tez.encoding
"Returns the balances of all the contracts that delegate to a given \
delegate. This excludes the delegate's own balance and its frozen \
balances."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "delegated_balance")
let deactivated =
RPC_service.get_service
~description:
"Tells whether the delegate is currently tagged as deactivated or not."
~query: RPC_query.empty
~output: bool
~query:RPC_query.empty
~output:bool
RPC_path.(path / "deactivated")
let grace_period =
RPC_service.get_service
~description:
"Returns the cycle by the end of which the delegate might be \
deactivated if she fails to execute any delegate action. \
A deactivated delegate might be reactivated \
(without loosing any rolls) by simply re-registering as a delegate. \
For deactivated delegates, this value contains the cycle by which \
they were deactivated."
~query: RPC_query.empty
~output: Cycle.encoding
deactivated if she fails to execute any delegate action. A \
deactivated delegate might be reactivated (without loosing any \
rolls) by simply re-registering as a delegate. For deactivated \
delegates, this value contains the cycle by which they were \
deactivated."
~query:RPC_query.empty
~output:Cycle.encoding
RPC_path.(path / "grace_period")
end
let register () =
let open Services_registration in
register0 S.list_delegate begin fun ctxt q () ->
Delegate.list ctxt >>= fun delegates ->
if q.active && q.inactive then
return delegates
register0 S.list_delegate (fun ctxt q () ->
Delegate.list ctxt
>>= fun delegates ->
if q.active && q.inactive then return delegates
else if q.active then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh >>=? function
| true -> return_none
| false -> return_some pkh)
Delegate.deactivated ctxt pkh
>>=? function true -> return_none | false -> return_some pkh)
delegates
else if q.inactive then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh >>=? function
| false -> return_none
| true -> return_some pkh)
delegates
else
return_nil
end ;
register1 S.info begin fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh >>=? fun balance ->
Delegate.frozen_balance ctxt pkh >>=? fun frozen_balance ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= fun frozen_balance_by_cycle ->
Delegate.staking_balance ctxt pkh >>=? fun staking_balance ->
Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts ->
Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance ->
Delegate.deactivated ctxt pkh >>=? fun deactivated ->
Delegate.grace_period ctxt pkh >>=? fun grace_period ->
return {
balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period
}
end ;
register1 S.balance begin fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh
end ;
register1 S.frozen_balance begin fun ctxt pkh () () ->
Delegate.frozen_balance ctxt pkh
end ;
register1 S.frozen_balance_by_cycle begin fun ctxt pkh () () ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= return
end ;
register1 S.staking_balance begin fun ctxt pkh () () ->
Delegate.staking_balance ctxt pkh
end ;
register1 S.delegated_contracts begin fun ctxt pkh () () ->
Delegate.delegated_contracts ctxt pkh >>= return
end ;
register1 S.delegated_balance begin fun ctxt pkh () () ->
Delegate.delegated_balance ctxt pkh
end ;
register1 S.deactivated begin fun ctxt pkh () () ->
Delegate.deactivated ctxt pkh
end ;
register1 S.grace_period begin fun ctxt pkh () () ->
>>=? function false -> return_none | true -> return_some pkh)
delegates
else return_nil) ;
register1 S.info (fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh
>>=? fun balance ->
Delegate.frozen_balance ctxt pkh
>>=? fun frozen_balance ->
Delegate.frozen_balance_by_cycle ctxt pkh
>>= fun frozen_balance_by_cycle ->
Delegate.staking_balance ctxt pkh
>>=? fun staking_balance ->
Delegate.delegated_contracts ctxt pkh
>>= fun delegated_contracts ->
Delegate.delegated_balance ctxt pkh
>>=? fun delegated_balance ->
Delegate.deactivated ctxt pkh
>>=? fun deactivated ->
Delegate.grace_period ctxt pkh
end
>>=? fun grace_period ->
return
{
balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period;
}) ;
register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ;
register1 S.frozen_balance (fun ctxt pkh () () ->
Delegate.frozen_balance ctxt pkh) ;
register1 S.frozen_balance_by_cycle (fun ctxt pkh () () ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ;
register1 S.staking_balance (fun ctxt pkh () () ->
Delegate.staking_balance ctxt pkh) ;
register1 S.delegated_contracts (fun ctxt pkh () () ->
Delegate.delegated_contracts ctxt pkh >>= return) ;
register1 S.delegated_balance (fun ctxt pkh () () ->
Delegate.delegated_balance ctxt pkh) ;
register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ;
register1 S.grace_period (fun ctxt pkh () () ->
Delegate.grace_period ctxt pkh)
let list ctxt block ?(active = true) ?(inactive = false) () =
RPC_context.make_call0 S.list_delegate ctxt block { active ; inactive } ()
RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} ()
let info ctxt block pkh =
RPC_context.make_call1 S.info ctxt block pkh () ()
let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()
let balance ctxt block pkh =
RPC_context.make_call1 S.balance ctxt block pkh () ()
@ -270,44 +284,43 @@ let grace_period ctxt block pkh =
RPC_context.make_call1 S.grace_period ctxt block pkh () ()
let requested_levels ~default ctxt cycles levels =
match levels, cycles with
| [], [] ->
match (levels, cycles) with
| ([], []) ->
return [default]
| levels, cycles ->
| (levels, cycles) ->
(* explicitly fail when requested levels or cycle are in the past...
or too far in the future... *)
let levels =
List.sort_uniq
Level.compare
(List.concat (List.map (Level.from_raw ctxt) levels ::
List.map (Level.levels_in_cycle ctxt) cycles)) in
(List.concat
( List.map (Level.from_raw ctxt) levels
:: List.map (Level.levels_in_cycle ctxt) cycles ))
in
map_s
(fun level ->
let current_level = Level.current ctxt in
if Level.(level <= current_level) then
return (level, None)
if Level.(level <= current_level) then return (level, None)
else
Baking.earlier_predecessor_timestamp
ctxt level >>=? fun timestamp ->
return (level, Some timestamp))
Baking.earlier_predecessor_timestamp ctxt level
>>=? fun timestamp -> return (level, Some timestamp))
levels
module Baking_rights = struct
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
priority: int ;
timestamp: Timestamp.t option ;
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
priority : int;
timestamp : Timestamp.t option;
}
let encoding =
let open Data_encoding in
conv
(fun { level ; delegate ; priority ; timestamp } ->
(fun {level; delegate; priority; timestamp} ->
(level, delegate, priority, timestamp))
(fun (level, delegate, priority, timestamp) ->
{ level ; delegate ; priority ; timestamp })
{level; delegate; priority; timestamp})
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
@ -315,27 +328,26 @@ module Baking_rights = struct
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root =
RPC_path.(open_root / "helpers" / "baking_rights")
let custom_root = RPC_path.(open_root / "helpers" / "baking_rights")
type baking_rights_query = {
levels: Raw_level.t list ;
cycles: Cycle.t list ;
delegates: Signature.Public_key_hash.t list ;
max_priority: int option ;
all: bool ;
levels : Raw_level.t list;
cycles : Cycle.t list;
delegates : Signature.Public_key_hash.t list;
max_priority : int option;
all : bool;
}
let baking_rights_query =
let open RPC_query in
query (fun levels cycles delegates max_priority all ->
{ levels ; cycles ; delegates ; max_priority ; all })
{levels; cycles; delegates; max_priority; all})
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
t.delegates)
|+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
|+ flag "all" (fun t -> t.all)
|> seal
@ -344,112 +356,114 @@ module Baking_rights = struct
RPC_service.get_service
~description:
"Retrieves the list of delegates allowed to bake a block.\n\
By default, it gives the best baking priorities for bakers \
that have at least one opportunity below the 64th priority \
for the next block.\n\
Parameters `level` and `cycle` can be used to specify the \
(valid) level(s) in the past or future at which the baking \
rights have to be returned. Parameter `delegate` can be \
used to restrict the results to the given delegates. If \
parameter `all` is set, all the baking opportunities for \
each baker at each level are returned, instead of just the \
first one.\n\
By default, it gives the best baking priorities for bakers that \
have at least one opportunity below the 64th priority for the next \
block.\n\
Parameters `level` and `cycle` can be used to specify the (valid) \
level(s) in the past or future at which the baking rights have to \
be returned. Parameter `delegate` can be used to restrict the \
results to the given delegates. If parameter `all` is set, all the \
baking opportunities for each baker at each level are returned, \
instead of just the first one.\n\
Returns the list of baking slots. Also returns the minimal \
timestamps that correspond to these slots. The timestamps \
are omitted for levels in the past, and are only estimates \
for levels later that the next block, based on the \
hypothesis that all predecessor blocks were baked at the \
first priority."
~query: baking_rights_query
~output: (list encoding)
timestamps that correspond to these slots. The timestamps are \
omitted for levels in the past, and are only estimates for levels \
later that the next block, based on the hypothesis that all \
predecessor blocks were baked at the first priority."
~query:baking_rights_query
~output:(list encoding)
custom_root
end
let baking_priorities ctxt max_prio (level, pred_timestamp) =
Baking.baking_priorities ctxt level >>=? fun contract_list ->
Baking.baking_priorities ctxt level
>>=? fun contract_list ->
let rec loop l acc priority =
if Compare.Int.(priority >= max_prio) then
return (List.rev acc)
if Compare.Int.(priority > max_prio) then return (List.rev acc)
else
let Misc.LCons (pk, next) = l in
let (Misc.LCons (pk, next)) = l in
let delegate = Signature.Public_key.hash pk in
begin
match pred_timestamp with
| None -> return_none
( match pred_timestamp with
| None ->
return_none
| Some pred_timestamp ->
Baking.minimal_time ctxt priority pred_timestamp >>=? fun t ->
return_some t
end>>=? fun timestamp ->
Baking.minimal_time ctxt priority pred_timestamp
>>=? fun t -> return_some t )
>>=? fun timestamp ->
let acc =
{ level = level.level ; delegate ; priority ; timestamp } :: acc in
next () >>=? fun l ->
loop l acc (priority+1) in
{level = level.level; delegate; priority; timestamp} :: acc
in
next () >>=? fun l -> loop l acc (priority + 1)
in
loop contract_list [] 0
let remove_duplicated_delegates rights =
List.rev @@ fst @@
List.fold_left
List.rev @@ fst
@@ List.fold_left
(fun (acc, previous) r ->
if Signature.Public_key_hash.Set.mem r.delegate previous then
(acc, previous)
else
(r :: acc,
Signature.Public_key_hash.Set.add r.delegate previous))
(r :: acc, Signature.Public_key_hash.Set.add r.delegate previous))
([], Signature.Public_key_hash.Set.empty)
rights
let register () =
let open Services_registration in
register0 S.baking_rights begin fun ctxt q () ->
register0 S.baking_rights (fun ctxt q () ->
requested_levels
~default:
(Level.succ ctxt (Level.current ctxt), Some (Timestamp.current ctxt))
ctxt q.cycles q.levels >>=? fun levels ->
( Level.succ ctxt (Level.current ctxt),
Some (Timestamp.current ctxt) )
ctxt
q.cycles
q.levels
>>=? fun levels ->
let max_priority =
match q.max_priority with
| None -> 64
| Some max -> max in
map_s (baking_priorities ctxt max_priority) levels >>=? fun rights ->
match q.max_priority with None -> 64 | Some max -> max
in
map_s (baking_priorities ctxt max_priority) levels
>>=? fun rights ->
let rights =
if q.all then
rights
else
List.map remove_duplicated_delegates rights in
if q.all then rights else List.map remove_duplicated_delegates rights
in
let rights = List.concat rights in
match q.delegates with
| [] -> return rights
| [] ->
return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists (Signature.Public_key_hash.equal p.delegate) delegates in
return (List.filter is_requested rights)
end
List.exists
(Signature.Public_key_hash.equal p.delegate)
delegates
in
return (List.filter is_requested rights))
let get ctxt
?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
?max_priority block =
RPC_context.make_call0 S.baking_rights ctxt block
{ levels ; cycles ; delegates ; max_priority ; all }
RPC_context.make_call0
S.baking_rights
ctxt
block
{levels; cycles; delegates; max_priority; all}
()
end
module Endorsing_rights = struct
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
slots: int list ;
estimated_time: Time.t option ;
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
slots : int list;
estimated_time : Time.t option;
}
let encoding =
let open Data_encoding in
conv
(fun { level ; delegate ; slots ; estimated_time } ->
(fun {level; delegate; slots; estimated_time} ->
(level, delegate, slots, estimated_time))
(fun (level, delegate, slots, estimated_time) ->
{ level ; delegate ; slots ; estimated_time })
{level; delegate; slots; estimated_time})
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
@ -457,94 +471,97 @@ module Endorsing_rights = struct
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root =
RPC_path.(open_root / "helpers" / "endorsing_rights")
let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights")
type endorsing_rights_query = {
levels: Raw_level.t list ;
cycles: Cycle.t list ;
delegates: Signature.Public_key_hash.t list ;
levels : Raw_level.t list;
cycles : Cycle.t list;
delegates : Signature.Public_key_hash.t list;
}
let endorsing_rights_query =
let open RPC_query in
query (fun levels cycles delegates ->
{ levels ; cycles ; delegates })
query (fun levels cycles delegates -> {levels; cycles; delegates})
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
t.delegates)
|> seal
let endorsing_rights =
RPC_service.get_service
~description:
"Retrieves the delegates allowed to endorse a block.\n\
By default, it gives the endorsement slots for delegates that \
have at least one in the next block.\n\
Parameters `level` and `cycle` can be used to specify the \
(valid) level(s) in the past or future at which the \
endorsement rights have to be returned. Parameter \
`delegate` can be used to restrict the results to the given \
delegates.\n\
Returns the list of endorsement slots. Also returns the \
minimal timestamps that correspond to these slots. The \
timestamps are omitted for levels in the past, and are only \
estimates for levels later that the next block, based on \
the hypothesis that all predecessor blocks were baked at \
the first priority."
~query: endorsing_rights_query
~output: (list encoding)
By default, it gives the endorsement slots for delegates that have \
at least one in the next block.\n\
Parameters `level` and `cycle` can be used to specify the (valid) \
level(s) in the past or future at which the endorsement rights \
have to be returned. Parameter `delegate` can be used to restrict \
the results to the given delegates.\n\
Returns the list of endorsement slots. Also returns the minimal \
timestamps that correspond to these slots. The timestamps are \
omitted for levels in the past, and are only estimates for levels \
later that the next block, based on the hypothesis that all \
predecessor blocks were baked at the first priority."
~query:endorsing_rights_query
~output:(list encoding)
custom_root
end
let endorsement_slots ctxt (level, estimated_time) =
Baking.endorsement_rights ctxt level >>=? fun rights ->
Baking.endorsement_rights ctxt level
>>=? fun rights ->
return
(Signature.Public_key_hash.Map.fold
(fun delegate (_, slots, _) acc -> {
level = level.level ; delegate ; slots ; estimated_time
} :: acc)
rights [])
(fun delegate (_, slots, _) acc ->
{level = level.level; delegate; slots; estimated_time} :: acc)
rights
[])
let register () =
let open Services_registration in
register0 S.endorsing_rights begin fun ctxt q () ->
register0 S.endorsing_rights (fun ctxt q () ->
requested_levels
~default: (Level.current ctxt, Some (Timestamp.current ctxt))
ctxt q.cycles q.levels >>=? fun levels ->
map_s (endorsement_slots ctxt) levels >>=? fun rights ->
~default:(Level.current ctxt, Some (Timestamp.current ctxt))
ctxt
q.cycles
q.levels
>>=? fun levels ->
map_s (endorsement_slots ctxt) levels
>>=? fun rights ->
let rights = List.concat rights in
match q.delegates with
| [] -> return rights
| [] ->
return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists (Signature.Public_key_hash.equal p.delegate) delegates in
return (List.filter is_requested rights)
end
List.exists
(Signature.Public_key_hash.equal p.delegate)
delegates
in
return (List.filter is_requested rights))
let get ctxt
?(levels = []) ?(cycles = []) ?(delegates = []) block =
RPC_context.make_call0 S.endorsing_rights ctxt block
{ levels ; cycles ; delegates }
let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block =
RPC_context.make_call0
S.endorsing_rights
ctxt
block
{levels; cycles; delegates}
()
end
module Endorsing_power = struct
let endorsing_power ctxt (operation, chain_id) =
let Operation_data data = operation.protocol_data in
let (Operation_data data) = operation.protocol_data in
match data.contents with
| Single Endorsement _ ->
Baking.check_endorsement_rights ctxt chain_id {
shell = operation.shell ;
protocol_data = data ;
} >>=? fun (_, slots, _) ->
return (List.length slots)
| Single (Endorsement _) ->
Baking.check_endorsement_rights
ctxt
chain_id
{shell = operation.shell; protocol_data = data}
>>=? fun (_, slots, _) -> return (List.length slots)
| _ ->
failwith "Operation is not an endorsement"
@ -552,101 +569,98 @@ module Endorsing_power = struct
let endorsing_power =
let open Data_encoding in
RPC_service.post_service
~description:"Get the endorsing power of an endorsement, that is, \
the number of slots that the endorser has"
~query: RPC_query.empty
~input: (obj2
~description:
"Get the endorsing power of an endorsement, that is, the number of \
slots that the endorser has"
~query:RPC_query.empty
~input:
(obj2
(req "endorsement_operation" Operation.encoding)
(req "chain_id" Chain_id.encoding))
~output: int31
~output:int31
RPC_path.(open_root / "endorsing_power")
end
let register () =
let open Services_registration in
register0 S.endorsing_power begin fun ctxt () (op, chain_id) ->
endorsing_power ctxt (op, chain_id)
end
register0 S.endorsing_power (fun ctxt () (op, chain_id) ->
endorsing_power ctxt (op, chain_id))
let get ctxt block op chain_id =
RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
end
module Required_endorsements = struct
let required_endorsements ctxt block_delay =
return (Baking.minimum_allowed_endorsements ctxt ~block_delay)
module S = struct
type t = { block_delay : Period.t }
type t = {block_delay : Period.t}
let required_endorsements_query =
let open RPC_query in
query (fun block_delay -> { block_delay })
|+ field "block_delay" Period.rpc_arg Period.zero (fun t -> t.block_delay)
query (fun block_delay -> {block_delay})
|+ field "block_delay" Period.rpc_arg Period.zero (fun t ->
t.block_delay)
|> seal
let required_endorsements =
let open Data_encoding in
RPC_service.get_service
~description:"Minimum number of endorsements for a block to be \
valid, given a delay of the block's timestamp with \
respect to the minimum time to bake at the \
block's priority"
~query: required_endorsements_query
~output: int31
~description:
"Minimum number of endorsements for a block to be valid, given a \
delay of the block's timestamp with respect to the minimum time to \
bake at the block's priority"
~query:required_endorsements_query
~output:int31
RPC_path.(open_root / "required_endorsements")
end
let register () =
let open Services_registration in
register0 S.required_endorsements begin fun ctxt ({ block_delay }) () ->
required_endorsements ctxt block_delay
end
register0 S.required_endorsements (fun ctxt {block_delay} () ->
required_endorsements ctxt block_delay)
let get ctxt block block_delay =
RPC_context.make_call0 S.required_endorsements ctxt block { block_delay } ()
RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} ()
end
module Minimal_valid_time = struct
let minimal_valid_time ctxt ~priority ~endorsing_power =
Baking.minimal_valid_time ctxt
~priority ~endorsing_power
Baking.minimal_valid_time ctxt ~priority ~endorsing_power
module S = struct
type t = { priority : int ;
endorsing_power : int }
type t = {priority : int; endorsing_power : int}
let minimal_valid_time_query =
let open RPC_query in
query (fun priority endorsing_power ->
{ priority ; endorsing_power })
query (fun priority endorsing_power -> {priority; endorsing_power})
|+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
|+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
|> seal
let minimal_valid_time =
RPC_service.get_service
~description: "Minimal valid time for a block given a priority \
and an endorsing power."
~query: minimal_valid_time_query
~output: Time.encoding
~description:
"Minimal valid time for a block given a priority and an endorsing \
power."
~query:minimal_valid_time_query
~output:Time.encoding
RPC_path.(open_root / "minimal_valid_time")
end
let register () =
let open Services_registration in
register0 S.minimal_valid_time begin fun ctxt { priority ; endorsing_power } () ->
minimal_valid_time ctxt ~priority ~endorsing_power
end
register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () ->
minimal_valid_time ctxt ~priority ~endorsing_power)
let get ctxt block priority endorsing_power =
RPC_context.make_call0 S.minimal_valid_time ctxt block { priority ; endorsing_power } ()
RPC_context.make_call0
S.minimal_valid_time
ctxt
block
{priority; endorsing_power}
()
end
let register () =
@ -658,17 +672,20 @@ let register () =
Minimal_valid_time.register ()
let endorsement_rights ctxt level =
Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l ->
return (List.map (fun { Endorsing_rights.delegate ; _ } -> delegate) l)
Endorsing_rights.endorsement_slots ctxt (level, None)
>>=? fun l ->
return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l)
let baking_rights ctxt max_priority =
let max = match max_priority with None -> 64 | Some m -> m in
let level = Level.current ctxt in
Baking_rights.baking_priorities ctxt max (level, None) >>=? fun l ->
return (level.level,
Baking_rights.baking_priorities ctxt max (level, None)
>>=? fun l ->
return
( level.level,
List.map
(fun { Baking_rights.delegate ; timestamp ; _ } ->
(delegate, timestamp)) l)
(fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp))
l )
let endorsing_power ctxt operation =
Endorsing_power.endorsing_power ctxt operation

165
vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli vendored
View File

@ -25,78 +25,87 @@
open Alpha_context
val list:
'a #RPC_context.simple -> 'a ->
val list :
'a #RPC_context.simple ->
'a ->
?active:bool ->
?inactive:bool ->
unit -> Signature.Public_key_hash.t list shell_tzresult Lwt.t
unit ->
Signature.Public_key_hash.t list shell_tzresult Lwt.t
type info = {
balance: Tez.t ;
frozen_balance: Tez.t ;
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
staking_balance: Tez.t ;
delegated_contracts: Contract_repr.t list ;
delegated_balance: Tez.t ;
deactivated: bool ;
grace_period: Cycle.t ;
balance : Tez.t;
frozen_balance : Tez.t;
frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
staking_balance : Tez.t;
delegated_contracts : Contract_repr.t list;
delegated_balance : Tez.t;
deactivated : bool;
grace_period : Cycle.t;
}
val info_encoding: info Data_encoding.t
val info_encoding : info Data_encoding.t
val info:
'a #RPC_context.simple -> 'a ->
val info :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
info shell_tzresult Lwt.t
val balance:
'a #RPC_context.simple -> 'a ->
val balance :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val frozen_balance:
'a #RPC_context.simple -> 'a ->
val frozen_balance :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val frozen_balance_by_cycle:
'a #RPC_context.simple -> 'a ->
val frozen_balance_by_cycle :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t
val staking_balance:
'a #RPC_context.simple -> 'a ->
val staking_balance :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val delegated_contracts:
'a #RPC_context.simple -> 'a ->
val delegated_contracts :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Contract_repr.t list shell_tzresult Lwt.t
val delegated_balance:
'a #RPC_context.simple -> 'a ->
val delegated_balance :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val deactivated:
'a #RPC_context.simple -> 'a ->
val deactivated :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
bool shell_tzresult Lwt.t
val grace_period:
'a #RPC_context.simple -> 'a ->
val grace_period :
'a #RPC_context.simple ->
'a ->
Signature.Public_key_hash.t ->
Cycle.t shell_tzresult Lwt.t
module Baking_rights : sig
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
priority: int ;
timestamp: Timestamp.t option ;
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
priority : int;
timestamp : Timestamp.t option;
}
(** Retrieves the list of delegates allowed to bake a block.
@ -117,24 +126,23 @@ module Baking_rights : sig
omitted for levels in the past, and are only estimates for levels
later that the next block, based on the hypothesis that all
predecessor blocks were baked at the first priority. *)
val get:
val get :
'a #RPC_context.simple ->
?levels: Raw_level.t list ->
?cycles: Cycle.t list ->
?delegates: Signature.public_key_hash list ->
?all: bool ->
?max_priority: int ->
'a -> t list shell_tzresult Lwt.t
?levels:Raw_level.t list ->
?cycles:Cycle.t list ->
?delegates:Signature.public_key_hash list ->
?all:bool ->
?max_priority:int ->
'a ->
t list shell_tzresult Lwt.t
end
module Endorsing_rights : sig
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
slots: int list ;
estimated_time: Timestamp.t option ;
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
slots : int list;
estimated_time : Timestamp.t option;
}
(** Retrieves the delegates allowed to endorse a block.
@ -153,66 +161,51 @@ module Endorsing_rights : sig
estimates for levels later that the next block, based on the
hypothesis that all predecessor blocks were baked at the first
priority. *)
val get:
val get :
'a #RPC_context.simple ->
?levels: Raw_level.t list ->
?cycles: Cycle.t list ->
?delegates: Signature.public_key_hash list ->
'a -> t list shell_tzresult Lwt.t
?levels:Raw_level.t list ->
?cycles:Cycle.t list ->
?delegates:Signature.public_key_hash list ->
'a ->
t list shell_tzresult Lwt.t
end
module Endorsing_power : sig
val get:
'a #RPC_context.simple -> 'a ->
val get :
'a #RPC_context.simple ->
'a ->
Alpha_context.packed_operation ->
Chain_id.t ->
int shell_tzresult Lwt.t
end
module Required_endorsements : sig
val get:
'a #RPC_context.simple -> 'a ->
Period.t -> int shell_tzresult Lwt.t
val get :
'a #RPC_context.simple -> 'a -> Period.t -> int shell_tzresult Lwt.t
end
module Minimal_valid_time : sig
val get:
'a #RPC_context.simple -> 'a ->
int -> int -> Time.t shell_tzresult Lwt.t
val get :
'a #RPC_context.simple -> 'a -> int -> int -> Time.t shell_tzresult Lwt.t
end
(* temporary export for deprecated unit test *)
val endorsement_rights:
Alpha_context.t ->
Level.t ->
public_key_hash list tzresult Lwt.t
val endorsement_rights :
Alpha_context.t -> Level.t -> public_key_hash list tzresult Lwt.t
val baking_rights:
val baking_rights :
Alpha_context.t ->
int option ->
(Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t
val endorsing_power:
val endorsing_power :
Alpha_context.t ->
(Alpha_context.packed_operation * Chain_id.t) ->
Alpha_context.packed_operation * Chain_id.t ->
int tzresult Lwt.t
val required_endorsements:
Alpha_context.t ->
Alpha_context.Period.t ->
int tzresult Lwt.t
val required_endorsements :
Alpha_context.t -> Alpha_context.Period.t -> int tzresult Lwt.t
val minimal_valid_time:
Alpha_context.t ->
int ->
int ->
Time.t tzresult Lwt.t
val minimal_valid_time : Alpha_context.t -> int -> int -> Time.t tzresult Lwt.t
val register: unit -> unit
val register : unit -> unit

701
vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml vendored
View File

@ -31,16 +31,18 @@ type balance =
let balance_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance" @@
union
[ case (Tag 0)
def "operation_metadata.alpha.balance"
@@ union
[ case
(Tag 0)
~title:"Contract"
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract_repr.encoding))
(function Contract c -> Some ((), c) | _ -> None )
(fun ((), c) -> (Contract c)) ;
case (Tag 1)
(function Contract c -> Some ((), c) | _ -> None)
(fun ((), c) -> Contract c);
case
(Tag 1)
~title:"Rewards"
(obj4
(req "kind" (constant "freezer"))
@ -48,8 +50,9 @@ let balance_encoding =
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Rewards (d, l)) ;
case (Tag 2)
(fun ((), (), d, l) -> Rewards (d, l));
case
(Tag 2)
~title:"Fees"
(obj4
(req "kind" (constant "freezer"))
@ -57,8 +60,9 @@ let balance_encoding =
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Fees (d, l)) ;
case (Tag 3)
(fun ((), (), d, l) -> Fees (d, l));
case
(Tag 3)
~title:"Deposits"
(obj4
(req "kind" (constant "freezer"))
@ -68,37 +72,42 @@ let balance_encoding =
(function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Deposits (d, l)) ]
type balance_update =
| Debited of Tez_repr.t
| Credited of Tez_repr.t
type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t
let balance_update_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_update" @@
obj1
(req "change"
def "operation_metadata.alpha.balance_update"
@@ obj1
(req
"change"
(conv
(function
| Credited v -> Tez_repr.to_mutez v
| Debited v -> Int64.neg (Tez_repr.to_mutez v))
(Json.wrap_error @@
fun v ->
| Credited v ->
Tez_repr.to_mutez v
| Debited v ->
Int64.neg (Tez_repr.to_mutez v))
( Json.wrap_error
@@ fun v ->
if Compare.Int64.(v < 0L) then
match Tez_repr.of_mutez (Int64.neg v) with
| Some v -> Debited v
| None -> failwith "Qty.of_mutez"
| Some v ->
Debited v
| None ->
failwith "Qty.of_mutez"
else
match Tez_repr.of_mutez v with
| Some v -> Credited v
| None -> failwith "Qty.of_mutez")
| Some v ->
Credited v
| None ->
failwith "Qty.of_mutez" )
int64))
type balance_updates = (balance * balance_update) list
let balance_updates_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_updates" @@
list (merge_objs balance_encoding balance_update_encoding)
def "operation_metadata.alpha.balance_updates"
@@ list (merge_objs balance_encoding balance_update_encoding)
let cleanup_balance_updates balance_updates =
List.filter
@ -107,16 +116,16 @@ let cleanup_balance_updates balance_updates =
balance_updates
type frozen_balance = {
deposit : Tez_repr.t ;
fees : Tez_repr.t ;
rewards : Tez_repr.t ;
deposit : Tez_repr.t;
fees : Tez_repr.t;
rewards : Tez_repr.t;
}
let frozen_balance_encoding =
let open Data_encoding in
conv
(fun { deposit ; fees ; rewards } -> (deposit, fees, rewards))
(fun (deposit, fees, rewards) -> { deposit ; fees ; rewards })
(fun {deposit; fees; rewards} -> (deposit, fees, rewards))
(fun (deposit, fees, rewards) -> {deposit; fees; rewards})
(obj3
(req "deposit" Tez_repr.encoding)
(req "fees" Tez_repr.encoding)
@ -127,10 +136,13 @@ type error +=
| Active_delegate (* `Temporary *)
| Current_delegate (* `Temporary *)
| Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
| Balance_too_low_for_deposit of
{ delegate : Signature.Public_key_hash.t ;
deposit : Tez_repr.t ;
balance : Tez_repr.t } (* `Temporary *)
| Balance_too_low_for_deposit of {
delegate : Signature.Public_key_hash.t;
deposit : Tez_repr.t;
balance : Tez_repr.t;
}
(* `Temporary *)
let () =
register_error_kind
@ -139,8 +151,11 @@ let () =
~title:"Forbidden delegate deletion"
~description:"Tried to unregister a delegate"
~pp:(fun ppf delegate ->
Format.fprintf ppf "Delegate deletion is forbidden (%a)"
Signature.Public_key_hash.pp delegate)
Format.fprintf
ppf
"Delegate deletion is forbidden (%a)"
Signature.Public_key_hash.pp
delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function No_deletion c -> Some c | _ -> None)
(fun c -> No_deletion c) ;
@ -150,8 +165,7 @@ let () =
~title:"Delegate already active"
~description:"Useless delegate reactivation"
~pp:(fun ppf () ->
Format.fprintf ppf
"The delegate is still active, no need to refresh it")
Format.fprintf ppf "The delegate is still active, no need to refresh it")
Data_encoding.empty
(function Active_delegate -> Some () | _ -> None)
(fun () -> Active_delegate) ;
@ -161,7 +175,8 @@ let () =
~title:"Unchanged delegated"
~description:"Contract already delegated to the given delegate"
~pp:(fun ppf () ->
Format.fprintf ppf
Format.fprintf
ppf
"The contract is already delegated to the same delegate")
Data_encoding.empty
(function Current_delegate -> Some () | _ -> None)
@ -170,12 +185,15 @@ let () =
`Permanent
~id:"delegate.empty_delegate_account"
~title:"Empty delegate account"
~description:"Cannot register a delegate when its implicit account is empty"
~description:
"Cannot register a delegate when its implicit account is empty"
~pp:(fun ppf delegate ->
Format.fprintf ppf
"Delegate registration is forbidden when the delegate
implicit account is empty (%a)"
Signature.Public_key_hash.pp delegate)
Format.fprintf
ppf
"Delegate registration is forbidden when the delegate\n\
\ implicit account is empty (%a)"
Signature.Public_key_hash.pp
delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function Empty_delegate_account c -> Some c | _ -> None)
(fun c -> Empty_delegate_account c) ;
@ -185,392 +203,474 @@ let () =
~title:"Balance too low for deposit"
~description:"Cannot freeze deposit when the balance is too low"
~pp:(fun ppf (delegate, balance, deposit) ->
Format.fprintf ppf
Format.fprintf
ppf
"Delegate %a has a too low balance (%a) to deposit %a"
Signature.Public_key_hash.pp delegate
Tez_repr.pp balance
Tez_repr.pp deposit)
Data_encoding.
(obj3
Signature.Public_key_hash.pp
delegate
Tez_repr.pp
balance
Tez_repr.pp
deposit)
Data_encoding.(
obj3
(req "delegate" Signature.Public_key_hash.encoding)
(req "balance" Tez_repr.encoding)
(req "deposit" Tez_repr.encoding))
(function Balance_too_low_for_deposit { delegate ; balance ; deposit } ->
Some (delegate, balance, deposit) | _ -> None)
(fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } )
(function
| Balance_too_low_for_deposit {delegate; balance; deposit} ->
Some (delegate, balance, deposit)
| _ ->
None)
(fun (delegate, balance, deposit) ->
Balance_too_low_for_deposit {delegate; balance; deposit})
let link c contract delegate =
Storage.Contract.Balance.get c contract >>=? fun balance ->
Roll_storage.Delegate.add_amount c delegate balance >>=? fun c ->
Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) contract >>= fun c ->
return c
Storage.Contract.Balance.get c contract
>>=? fun balance ->
Roll_storage.Delegate.add_amount c delegate balance
>>=? fun c ->
Storage.Contract.Delegated.add
(c, Contract_repr.implicit_contract delegate)
contract
>>= fun c -> return c
let unlink c contract =
Storage.Contract.Balance.get c contract >>=? fun balance ->
Storage.Contract.Delegate.get_option c contract >>=? function
| None -> return c
Storage.Contract.Balance.get c contract
>>=? fun balance ->
Storage.Contract.Delegate.get_option c contract
>>=? function
| None ->
return c
| Some delegate ->
(* Removes the balance of the contract from the delegate *)
Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c ->
Storage.Contract.Delegated.del (c, Contract_repr.implicit_contract delegate) contract >>= fun c ->
return c
Roll_storage.Delegate.remove_amount c delegate balance
>>=? fun c ->
Storage.Contract.Delegated.del
(c, Contract_repr.implicit_contract delegate)
contract
>>= fun c -> return c
let known c delegate =
Storage.Contract.Manager.get_option
c (Contract_repr.implicit_contract delegate) >>=? function
| None | Some (Manager_repr.Hash _) -> return_false
| Some (Manager_repr.Public_key _) -> return_true
c
(Contract_repr.implicit_contract delegate)
>>=? function
| None | Some (Manager_repr.Hash _) ->
return_false
| Some (Manager_repr.Public_key _) ->
return_true
(* A delegate is registered if its "implicit account" delegates to itself. *)
let registered c delegate =
Storage.Contract.Delegate.get_option
c (Contract_repr.implicit_contract delegate) >>=? function
c
(Contract_repr.implicit_contract delegate)
>>=? function
| Some current_delegate ->
return @@ Signature.Public_key_hash.equal delegate current_delegate
| None ->
return_false
let init ctxt contract delegate =
known ctxt delegate >>=? fun known_delegate ->
fail_unless
known_delegate
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
registered ctxt delegate >>=? fun is_registered ->
fail_unless
is_registered
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt ->
link ctxt contract delegate
known ctxt delegate
>>=? fun known_delegate ->
fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate)
>>=? fun () ->
registered ctxt delegate
>>=? fun is_registered ->
fail_unless is_registered (Roll_storage.Unregistered_delegate delegate)
>>=? fun () ->
Storage.Contract.Delegate.init ctxt contract delegate
>>=? fun ctxt -> link ctxt contract delegate
let get = Roll_storage.get_contract_delegate
let set c contract delegate =
match delegate with
| None -> begin
| None -> (
let delete () =
unlink c contract >>=? fun c ->
Storage.Contract.Delegate.remove c contract >>= fun c ->
return c in
unlink c contract
>>=? fun c ->
Storage.Contract.Delegate.remove c contract >>= fun c -> return c
in
match Contract_repr.is_implicit contract with
| Some pkh ->
(* check if contract is a registered delegate *)
registered c pkh >>=? fun is_registered ->
if is_registered then
fail (No_deletion pkh)
else
delete ()
| None -> delete ()
end
registered c pkh
>>=? fun is_registered ->
if is_registered then fail (No_deletion pkh) else delete ()
| None ->
delete () )
| Some delegate ->
known c delegate >>=? fun known_delegate ->
registered c delegate >>=? fun registered_delegate ->
known c delegate
>>=? fun known_delegate ->
registered c delegate
>>=? fun registered_delegate ->
let self_delegation =
match Contract_repr.is_implicit contract with
| Some pkh -> Signature.Public_key_hash.equal pkh delegate
| None -> false in
if not known_delegate || not (registered_delegate || self_delegation) then
fail (Roll_storage.Unregistered_delegate delegate)
else
begin
Storage.Contract.Delegate.get_option c contract >>=? function
| Some current_delegate
when Signature.Public_key_hash.equal delegate current_delegate ->
if self_delegation then
Roll_storage.Delegate.is_inactive c delegate >>=? function
| true -> return_unit
| false -> fail Active_delegate
else
fail Current_delegate
| None | Some _ -> return_unit
end >>=? fun () ->
(* check if contract is a registered delegate *)
begin
match Contract_repr.is_implicit contract with
| Some pkh ->
registered c pkh >>=? fun is_registered ->
(* allow self-delegation to re-activate *)
if not self_delegation && is_registered then
fail (No_deletion pkh)
else
return_unit
Signature.Public_key_hash.equal pkh delegate
| None ->
return_unit
end >>=? fun () ->
Storage.Contract.Balance.mem c contract >>= fun exists ->
false
in
if (not known_delegate) || not (registered_delegate || self_delegation)
then fail (Roll_storage.Unregistered_delegate delegate)
else
Storage.Contract.Delegate.get_option c contract
>>=? (function
| Some current_delegate
when Signature.Public_key_hash.equal delegate current_delegate
->
if self_delegation then
Roll_storage.Delegate.is_inactive c delegate
>>=? function
| true -> return_unit | false -> fail Active_delegate
else fail Current_delegate
| None | Some _ ->
return_unit)
>>=? fun () ->
(* check if contract is a registered delegate *)
( match Contract_repr.is_implicit contract with
| Some pkh ->
registered c pkh
>>=? fun is_registered ->
(* allow self-delegation to re-activate *)
if (not self_delegation) && is_registered then
fail (No_deletion pkh)
else return_unit
| None ->
return_unit )
>>=? fun () ->
Storage.Contract.Balance.mem c contract
>>= fun exists ->
fail_when
(self_delegation && not exists)
(Empty_delegate_account delegate) >>=? fun () ->
unlink c contract >>=? fun c ->
Storage.Contract.Delegate.init_set c contract delegate >>= fun c ->
link c contract delegate >>=? fun c ->
begin
if self_delegation then
Storage.Delegates.add c delegate >>= fun c ->
Roll_storage.Delegate.set_active c delegate >>=? fun c ->
return c
else
return c
end >>=? fun c ->
return c
(Empty_delegate_account delegate)
>>=? fun () ->
unlink c contract
>>=? fun c ->
Storage.Contract.Delegate.init_set c contract delegate
>>= fun c ->
link c contract delegate
>>=? fun c ->
( if self_delegation then
Storage.Delegates.add c delegate
>>= fun c ->
Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c
else return c )
>>=? fun c -> return c
let remove ctxt contract =
unlink ctxt contract
let remove ctxt contract = unlink ctxt contract
let delegated_contracts ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Delegated.elements (ctxt, contract)
let get_frozen_deposit ctxt contract cycle =
Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_deposit ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_deposits.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
get_frozen_deposit ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_deposit ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
Roll_storage.Delegate.set_active ctxt delegate >>=? fun ctxt ->
let {Level_repr.cycle; _} = Level_storage.current ctxt in
Roll_storage.Delegate.set_active ctxt delegate
>>=? fun ctxt ->
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Storage.Contract.Balance.get ctxt contract
>>=? fun balance ->
Lwt.return
(record_trace (Balance_too_low_for_deposit { delegate; deposit = amount; balance })
Tez_repr.(balance -? amount)) >>=? fun new_balance ->
Storage.Contract.Balance.set ctxt contract new_balance >>=? fun ctxt ->
credit_frozen_deposit ctxt delegate cycle amount
(record_trace
(Balance_too_low_for_deposit {delegate; deposit = amount; balance})
Tez_repr.(balance -? amount))
>>=? fun new_balance ->
Storage.Contract.Balance.set ctxt contract new_balance
>>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount
let get_frozen_fees ctxt contract cycle =
Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_fees.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
get_frozen_fees ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_fees ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
Roll_storage.Delegate.add_amount ctxt delegate amount >>=? fun ctxt ->
credit_frozen_fees ctxt delegate cycle amount
let {Level_repr.cycle; _} = Level_storage.current ctxt in
Roll_storage.Delegate.add_amount ctxt delegate amount
>>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount
let burn_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle >>=? fun old_amount ->
begin
match Tez_repr.(old_amount -? amount) with
get_frozen_fees ctxt contract cycle
>>=? fun old_amount ->
( match Tez_repr.(old_amount -? amount) with
| Ok new_amount ->
Roll_storage.Delegate.remove_amount
ctxt delegate amount >>=? fun ctxt ->
return (new_amount, ctxt)
Roll_storage.Delegate.remove_amount ctxt delegate amount
>>=? fun ctxt -> return (new_amount, ctxt)
| Error _ ->
Roll_storage.Delegate.remove_amount
ctxt delegate old_amount >>=? fun ctxt ->
return (Tez_repr.zero, ctxt)
end >>=? fun (new_amount, ctxt) ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount >>= fun ctxt ->
return ctxt
Roll_storage.Delegate.remove_amount ctxt delegate old_amount
>>=? fun ctxt -> return (Tez_repr.zero, ctxt) )
>>=? fun (new_amount, ctxt) ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt -> return ctxt
let get_frozen_rewards ctxt contract cycle =
Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_rewards.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
get_frozen_rewards ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_rewards ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
let {Level_repr.cycle; _} = Level_storage.current ctxt in
credit_frozen_rewards ctxt delegate cycle amount
let burn_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle >>=? fun old_amount ->
get_frozen_rewards ctxt contract cycle
>>=? fun old_amount ->
let new_amount =
match Tez_repr.(old_amount -? amount) with
| Error _ -> Tez_repr.zero
| Ok new_amount -> new_amount in
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount >>= fun ctxt ->
return ctxt
| Error _ ->
Tez_repr.zero
| Ok new_amount ->
new_amount
in
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt -> return ctxt
let unfreeze ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
get_frozen_fees ctxt contract cycle >>=? fun fees ->
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Lwt.return Tez_repr.(deposit +? fees) >>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(unfrozen_amount +? rewards) >>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(balance +? unfrozen_amount) >>=? fun balance ->
Storage.Contract.Balance.set ctxt contract balance >>=? fun ctxt ->
Roll_storage.Delegate.add_amount ctxt delegate rewards >>=? fun ctxt ->
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt ->
return (ctxt, (cleanup_balance_updates
[(Deposits (delegate, cycle), Debited deposit) ;
(Fees (delegate, cycle), Debited fees) ;
(Rewards (delegate, cycle), Debited rewards) ;
(Contract (Contract_repr.implicit_contract delegate), Credited unfrozen_amount)]))
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
get_frozen_rewards ctxt contract cycle
>>=? fun rewards ->
Storage.Contract.Balance.get ctxt contract
>>=? fun balance ->
Lwt.return Tez_repr.(deposit +? fees)
>>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(unfrozen_amount +? rewards)
>>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(balance +? unfrozen_amount)
>>=? fun balance ->
Storage.Contract.Balance.set ctxt contract balance
>>=? fun ctxt ->
Roll_storage.Delegate.add_amount ctxt delegate rewards
>>=? fun ctxt ->
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
>>= fun ctxt ->
return
( ctxt,
cleanup_balance_updates
[ (Deposits (delegate, cycle), Debited deposit);
(Fees (delegate, cycle), Debited fees);
(Rewards (delegate, cycle), Debited rewards);
( Contract (Contract_repr.implicit_contract delegate),
Credited unfrozen_amount ) ] )
let cycle_end ctxt last_cycle unrevealed =
let preserved = Constants_storage.preserved_cycles ctxt in
begin
match Cycle_repr.pred last_cycle with
| None -> return (ctxt,[])
( match Cycle_repr.pred last_cycle with
| None ->
return (ctxt, [])
| Some revealed_cycle ->
List.fold_left
(fun acc (u : Nonce_storage.unrevealed) ->
acc >>=? fun (ctxt, balance_updates) ->
burn_fees
ctxt u.delegate revealed_cycle u.fees >>=? fun ctxt ->
burn_rewards
ctxt u.delegate revealed_cycle u.rewards >>=? fun ctxt ->
let bus = [(Fees (u.delegate, revealed_cycle), Debited u.fees);
(Rewards (u.delegate, revealed_cycle), Debited u.rewards)] in
acc
>>=? fun (ctxt, balance_updates) ->
burn_fees ctxt u.delegate revealed_cycle u.fees
>>=? fun ctxt ->
burn_rewards ctxt u.delegate revealed_cycle u.rewards
>>=? fun ctxt ->
let bus =
[ (Fees (u.delegate, revealed_cycle), Debited u.fees);
(Rewards (u.delegate, revealed_cycle), Debited u.rewards) ]
in
return (ctxt, bus @ balance_updates))
(return (ctxt,[])) unrevealed
end >>=? fun (ctxt, balance_updates) ->
(return (ctxt, []))
unrevealed )
>>=? fun (ctxt, balance_updates) ->
match Cycle_repr.sub last_cycle preserved with
| None -> return (ctxt, balance_updates, [])
| None ->
return (ctxt, balance_updates, [])
| Some unfrozen_cycle ->
Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle)
Storage.Delegates_with_frozen_balance.fold
(ctxt, unfrozen_cycle)
~init:(Ok (ctxt, balance_updates))
~f:(fun delegate acc ->
Lwt.return acc >>=? fun (ctxt, bus) ->
unfreeze ctxt
delegate unfrozen_cycle >>=? fun (ctxt, balance_updates) ->
return (ctxt, balance_updates @ bus)) >>=? fun (ctxt, balance_updates) ->
Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) >>= fun ctxt ->
Storage.Active_delegates_with_rolls.fold ctxt
Lwt.return acc
>>=? fun (ctxt, bus) ->
unfreeze ctxt delegate unfrozen_cycle
>>=? fun (ctxt, balance_updates) ->
return (ctxt, balance_updates @ bus))
>>=? fun (ctxt, balance_updates) ->
Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle)
>>= fun ctxt ->
Storage.Active_delegates_with_rolls.fold
ctxt
~init:(Ok (ctxt, []))
~f:(fun delegate acc ->
Lwt.return acc >>=? fun (ctxt, deactivated) ->
Storage.Contract.Delegate_desactivation.get ctxt
(Contract_repr.implicit_contract delegate) >>=? fun cycle ->
Lwt.return acc
>>=? fun (ctxt, deactivated) ->
Storage.Contract.Delegate_desactivation.get
ctxt
(Contract_repr.implicit_contract delegate)
>>=? fun cycle ->
if Cycle_repr.(cycle <= last_cycle) then
Roll_storage.Delegate.set_inactive ctxt delegate >>=? fun ctxt ->
return (ctxt, delegate :: deactivated)
else
return (ctxt, deactivated)) >>=? fun (ctxt, deactivated) ->
Roll_storage.Delegate.set_inactive ctxt delegate
>>=? fun ctxt -> return (ctxt, delegate :: deactivated)
else return (ctxt, deactivated))
>>=? fun (ctxt, deactivated) ->
return (ctxt, balance_updates, deactivated)
let punish ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
get_frozen_fees ctxt contract cycle >>=? fun fees ->
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
Roll_storage.Delegate.remove_amount ctxt delegate deposit >>=? fun ctxt ->
Roll_storage.Delegate.remove_amount ctxt delegate fees >>=? fun ctxt ->
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
get_frozen_rewards ctxt contract cycle
>>=? fun rewards ->
Roll_storage.Delegate.remove_amount ctxt delegate deposit
>>=? fun ctxt ->
Roll_storage.Delegate.remove_amount ctxt delegate fees
>>=? fun ctxt ->
(* Rewards are not accounted in the delegate's rolls yet... *)
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt ->
return (ctxt, { deposit ; fees ; rewards })
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
>>= fun ctxt -> return (ctxt, {deposit; fees; rewards})
let has_frozen_balance ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
if Tez_repr.(deposit <> zero) then return_true
else
get_frozen_fees ctxt contract cycle >>=? fun fees ->
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
if Tez_repr.(fees <> zero) then return_true
else
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
return Tez_repr.(rewards <> zero)
get_frozen_rewards ctxt contract cycle
>>=? fun rewards -> return Tez_repr.(rewards <> zero)
let frozen_balance_by_cycle_encoding =
let open Data_encoding in
conv
(Cycle_repr.Map.bindings)
Cycle_repr.Map.bindings
(List.fold_left
(fun m (c, b) -> Cycle_repr.Map.add c b m)
Cycle_repr.Map.empty)
(list (merge_objs
(list
(merge_objs
(obj1 (req "cycle" Cycle_repr.encoding))
frozen_balance_encoding))
let empty_frozen_balance =
{ deposit = Tez_repr.zero ;
fees = Tez_repr.zero ;
rewards = Tez_repr.zero }
{deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero}
let frozen_balance_by_cycle ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let map = Cycle_repr.Map.empty in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:map
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
Lwt.return
(Cycle_repr.Map.add cycle
{ empty_frozen_balance with deposit = amount } map)) >>= fun map ->
(Cycle_repr.Map.add
cycle
{empty_frozen_balance with deposit = amount}
map))
>>= fun map ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:map
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None -> empty_frozen_balance
| Some balance -> balance in
Lwt.return
(Cycle_repr.Map.add cycle
{ balance with fees = amount } map)) >>= fun map ->
| None ->
empty_frozen_balance
| Some balance ->
balance
in
Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map))
>>= fun map ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract) ~init:map
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None -> empty_frozen_balance
| Some balance -> balance in
Lwt.return
(Cycle_repr.Map.add cycle
{ balance with rewards = amount } map)) >>= fun map ->
Lwt.return map
| None ->
empty_frozen_balance
| Some balance ->
balance
in
Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map))
>>= fun map -> Lwt.return map
let frozen_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let balance = Ok Tez_repr.zero in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:balance
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:balance
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract) ~init:balance
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Lwt.return balance
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance -> Lwt.return balance
let full_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
frozen_balance ctxt delegate >>=? fun frozen_balance ->
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Lwt.return Tez_repr.(frozen_balance +? balance)
frozen_balance ctxt delegate
>>=? fun frozen_balance ->
Storage.Contract.Balance.get ctxt contract
>>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance)
let deactivated = Roll_storage.Delegate.is_inactive
@ -580,27 +680,34 @@ let grace_period ctxt delegate =
let staking_balance ctxt delegate =
let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
Roll_storage.get_rolls ctxt delegate >>=? fun rolls ->
Roll_storage.get_change ctxt delegate >>=? fun change ->
Roll_storage.get_rolls ctxt delegate
>>=? fun rolls ->
Roll_storage.get_change ctxt delegate
>>=? fun change ->
let rolls = Int64.of_int (List.length rolls) in
Lwt.return Tez_repr.(token_per_rolls *? rolls) >>=? fun balance ->
Lwt.return Tez_repr.(balance +? change)
Lwt.return Tez_repr.(token_per_rolls *? rolls)
>>=? fun balance -> Lwt.return Tez_repr.(balance +? change)
let delegated_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
staking_balance ctxt delegate >>=? fun staking_balance ->
Storage.Contract.Balance.get ctxt contract >>= fun self_staking_balance ->
staking_balance ctxt delegate
>>=? fun staking_balance ->
Storage.Contract.Balance.get ctxt contract
>>= fun self_staking_balance ->
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:self_staking_balance
(ctxt, contract)
~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun self_staking_balance ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun self_staking_balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:self_staking_balance
(ctxt, contract)
~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>=? fun self_staking_balance ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>=? fun self_staking_balance ->
Lwt.return Tez_repr.(staking_balance -? self_staking_balance)
let fold = Storage.Delegates.fold
let list = Storage.Delegates.elements

135
vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli vendored
View File

@ -31,9 +31,7 @@ type balance =
| Deposits of Signature.Public_key_hash.t * Cycle_repr.t
(** A credit or debit of tezzies to a balance. *)
type balance_update =
| Debited of Tez_repr.t
| Credited of Tez_repr.t
type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t
(** A list of balance updates. Duplicates may happen. *)
type balance_updates = (balance * balance_update) list
@ -44,26 +42,29 @@ val balance_updates_encoding : balance_updates Data_encoding.t
val cleanup_balance_updates : balance_updates -> balance_updates
type frozen_balance = {
deposit : Tez_repr.t ;
fees : Tez_repr.t ;
rewards : Tez_repr.t ;
deposit : Tez_repr.t;
fees : Tez_repr.t;
rewards : Tez_repr.t;
}
(** Allow to register a delegate when creating an account. *)
val init:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t ->
val init :
Raw_context.t ->
Contract_repr.t ->
Signature.Public_key_hash.t ->
Raw_context.t tzresult Lwt.t
(** Cleanup delegation when deleting a contract. *)
val remove:
Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
(** Reading the current delegate of a contract. *)
val get:
Raw_context.t -> Contract_repr.t ->
val get :
Raw_context.t ->
Contract_repr.t ->
Signature.Public_key_hash.t option tzresult Lwt.t
val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
val registered :
Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
(** Updating the delegate of a contract.
@ -71,8 +72,10 @@ val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lw
the delegate to the contract manager registers it as a delegate. One
cannot unregister a delegate for now. The associate contract is now
'undeletable'. *)
val set:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
val set :
Raw_context.t ->
Contract_repr.t ->
Signature.Public_key_hash.t option ->
Raw_context.t tzresult Lwt.t
type error +=
@ -80,34 +83,44 @@ type error +=
| Active_delegate (* `Temporary *)
| Current_delegate (* `Temporary *)
| Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
| Balance_too_low_for_deposit of
{ delegate : Signature.Public_key_hash.t ;
deposit : Tez_repr.t ;
balance : Tez_repr.t } (* `Temporary *)
| Balance_too_low_for_deposit of {
delegate : Signature.Public_key_hash.t;
deposit : Tez_repr.t;
balance : Tez_repr.t;
}
(* `Temporary *)
(** Iterate on all registered delegates. *)
val fold:
val fold :
Raw_context.t ->
init:'a ->
f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t
f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) ->
'a Lwt.t
(** List all registered delegates. *)
val list: Raw_context.t -> Signature.Public_key_hash.t list Lwt.t
val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t
(** Various functions to 'freeze' tokens. A frozen 'deposit' keeps its
associated rolls. When frozen, 'fees' may trigger new rolls
allocation. Rewards won't trigger new rolls allocation until
unfrozen. *)
val freeze_deposit:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
val freeze_deposit :
Raw_context.t ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val freeze_fees:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
val freeze_fees :
Raw_context.t ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val freeze_rewards:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
val freeze_rewards :
Raw_context.t ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
(** Trigger the context maintenance at the end of cycle 'n', i.e.:
@ -115,62 +128,64 @@ val freeze_rewards:
provided unrevealed seeds (tipically seed from cycle 'n - 1').
Returns a list of account with the amount that was unfrozen for each
and the list of deactivated delegates. *)
val cycle_end:
Raw_context.t -> Cycle_repr.t -> Nonce_storage.unrevealed list ->
(Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t
val cycle_end :
Raw_context.t ->
Cycle_repr.t ->
Nonce_storage.unrevealed list ->
(Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult
Lwt.t
(** Burn all then frozen deposit/fees/rewards for a delegate at a given
cycle. Returns the burned amounts. *)
val punish:
Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t ->
val punish :
Raw_context.t ->
Signature.Public_key_hash.t ->
Cycle_repr.t ->
(Raw_context.t * frozen_balance) tzresult Lwt.t
(** Has the given key some frozen tokens in its implicit contract? *)
val has_frozen_balance:
Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t ->
val has_frozen_balance :
Raw_context.t ->
Signature.Public_key_hash.t ->
Cycle_repr.t ->
bool tzresult Lwt.t
(** Returns the amount of frozen deposit, fees and rewards associated
to a given delegate. *)
val frozen_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val frozen_balance :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t
val frozen_balance_encoding: frozen_balance Data_encoding.t
val frozen_balance_by_cycle_encoding:
val frozen_balance_encoding : frozen_balance Data_encoding.t
val frozen_balance_by_cycle_encoding :
frozen_balance Cycle_repr.Map.t Data_encoding.t
(** Returns the amount of frozen deposit, fees and rewards associated
to a given delegate, indexed by the cycle by which at the end the
balance will be unfrozen. *)
val frozen_balance_by_cycle:
Raw_context.t -> Signature.Public_key_hash.t ->
val frozen_balance_by_cycle :
Raw_context.t ->
Signature.Public_key_hash.t ->
frozen_balance Cycle_repr.Map.t Lwt.t
(** Returns the full 'balance' of the implicit contract associated to
a given key, i.e. the sum of the spendable balance and of the
frozen balance. *)
val full_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val full_balance :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t
val staking_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val staking_balance :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t
(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *)
val delegated_contracts:
Raw_context.t -> Signature.Public_key_hash.t ->
Contract_repr.t list Lwt.t
val delegated_contracts :
Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t
val delegated_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val delegated_balance :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t
val deactivated:
Raw_context.t -> Signature.Public_key_hash.t ->
bool tzresult Lwt.t
val deactivated :
Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
val grace_period:
Raw_context.t -> Signature.Public_key_hash.t ->
Cycle_repr.t tzresult Lwt.t
val grace_period :
Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t

2
vendors/ligo-utils/tezos-protocol-alpha/dune-project vendored
View File

@ -1,2 +1,2 @@
(lang dune 1.11)
(name tezos-embedded-protocol-005-PsBabyM1)
(name tezos-embedded-protocol-006-PsCARTHA)

46
vendors/ligo-utils/tezos-protocol-alpha/dune.inc vendored
View File

@ -11,7 +11,7 @@
(targets environment.ml)
(action
(write-file %{targets}
"module Name = struct let name = \"005-PsBabyM1\" end
"module Name = struct let name = \"006-PsCARTHA\" end
include Tezos_protocol_environment.MakeV1(Name)()
module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
")))
@ -22,7 +22,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
(:src_dir TEZOS_PROTOCOL))
(action
(with-stdout-to %{targets}
(chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "005_PsBabyM1")))))
(chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "006_PsCARTHA")))))
(rule
(targets functor.ml)
@ -37,67 +37,67 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml)
(action
(write-file %{targets}
"module Environment = Tezos_protocol_environment_005_PsBabyM1.Environment
let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS\"
"module Environment = Tezos_protocol_environment_006_PsCARTHA.Environment
let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb\"
let name = Environment.Name.name
include Tezos_raw_protocol_005_PsBabyM1
include Tezos_raw_protocol_005_PsBabyM1.Main
include Tezos_raw_protocol_006_PsCARTHA
include Tezos_raw_protocol_006_PsCARTHA.Main
")))
(library
(name tezos_protocol_environment_005_PsBabyM1)
(public_name tezos-protocol-005-PsBabyM1.environment)
(name tezos_protocol_environment_006_PsCARTHA)
(public_name tezos-protocol-006-PsCARTHA.environment)
(library_flags (:standard -linkall))
(libraries tezos-protocol-environment)
(modules Environment))
(library
(name tezos_raw_protocol_005_PsBabyM1)
(public_name tezos-protocol-005-PsBabyM1.raw)
(libraries tezos_protocol_environment_005_PsBabyM1)
(name tezos_raw_protocol_006_PsCARTHA)
(public_name tezos-protocol-006-PsCARTHA.raw)
(libraries tezos_protocol_environment_006_PsCARTHA)
(library_flags (:standard -linkall))
(flags (:standard -nopervasives -nostdlib
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_protocol_environment_005_PsBabyM1__Environment
-open Tezos_protocol_environment_006_PsCARTHA__Environment
-open Pervasives
-open Error_monad))
(modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Legacy_script_support_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main))
(install
(section lib)
(package tezos-protocol-005-PsBabyM1)
(package tezos-protocol-006-PsCARTHA)
(files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL)))
(library
(name tezos_protocol_005_PsBabyM1)
(public_name tezos-protocol-005-PsBabyM1)
(name tezos_protocol_006_PsCARTHA)
(public_name tezos-protocol-006-PsCARTHA)
(libraries
tezos-protocol-environment
tezos-protocol-environment-sigs
tezos_raw_protocol_005_PsBabyM1)
tezos_raw_protocol_006_PsCARTHA)
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
-warn-error "-a+8"
-nopervasives)
(modules Protocol))
(library
(name tezos_protocol_005_PsBabyM1_functor)
(public_name tezos-protocol-005-PsBabyM1.functor)
(name tezos_protocol_006_PsCARTHA_functor)
(public_name tezos-protocol-006-PsCARTHA.functor)
(libraries
tezos-protocol-environment
tezos-protocol-environment-sigs
tezos_raw_protocol_005_PsBabyM1)
tezos_raw_protocol_006_PsCARTHA)
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
-warn-error "-a+8"
-nopervasives)
(modules Functor))
(library
(name tezos_embedded_protocol_005_PsBabyM1)
(public_name tezos-embedded-protocol-005-PsBabyM1)
(name tezos_embedded_protocol_006_PsCARTHA)
(public_name tezos-embedded-protocol-006-PsCARTHA)
(library_flags (:standard -linkall))
(libraries tezos-protocol-005-PsBabyM1
(libraries tezos-protocol-006-PsCARTHA
tezos-protocol-updater
tezos-protocol-environment)
(flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48
@ -106,4 +106,4 @@ include Tezos_raw_protocol_005_PsBabyM1.Main
(alias
(name runtest_sandbox)
(deps .tezos_protocol_005_PsBabyM1.objs/native/tezos_protocol_005_PsBabyM1.cmx))
(deps .tezos_protocol_006_PsCARTHA.objs/native/tezos_protocol_006_PsCARTHA.cmx))

74
vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml vendored
View File

@ -24,7 +24,9 @@
(*****************************************************************************)
type error += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
type error += Storage_limit_too_high (* `Permanent *)
let () =
@ -41,19 +43,18 @@ let () =
register_error_kind
`Temporary
~id:"storage_exhausted.operation"
~title: "Storage quota exceeded for the operation"
~title:"Storage quota exceeded for the operation"
~description:
"A script or one of its callee wrote more \
bytes than the operation said it would"
"A script or one of its callee wrote more bytes than the operation said \
it would"
Data_encoding.empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Permanent
~id:"storage_limit_too_high"
~title: "Storage limit out of protocol hard bounds"
~description:
"A transaction tried to exceed the hard limit on storage"
~title:"Storage limit out of protocol hard bounds"
~description:"A transaction tried to exceed the hard limit on storage"
empty
(function Storage_limit_too_high -> Some () | _ -> None)
(fun () -> Storage_limit_too_high)
@ -62,50 +63,59 @@ let origination_burn c =
let origination_size = Constants_storage.origination_size c in
let cost_per_byte = Constants_storage.cost_per_byte c in
(* the origination burn, measured in bytes *)
Lwt.return
Tez_repr.(cost_per_byte *? (Int64.of_int origination_size)) >>=? fun to_be_paid ->
return (Raw_context.update_allocated_contracts_count c,
to_be_paid)
Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size)
>>=? fun to_be_paid ->
return (Raw_context.update_allocated_contracts_count c, to_be_paid)
let record_paid_storage_space c contract =
Contract_storage.used_storage_space c contract >>=? fun size ->
Contract_storage.set_paid_storage_space_and_return_fees_to_pay c contract size >>=? fun (to_be_paid, c) ->
Contract_storage.used_storage_space c contract
>>=? fun size ->
Contract_storage.set_paid_storage_space_and_return_fees_to_pay
c
contract
size
>>=? fun (to_be_paid, c) ->
let c = Raw_context.update_storage_space_to_pay c to_be_paid in
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn ->
return (c, size, to_be_paid, to_burn)
Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid)
>>=? fun to_burn -> return (c, size, to_be_paid, to_burn)
let burn_storage_fees c ~storage_limit ~payer =
let origination_size = Constants_storage.origination_size c in
let c, storage_space_to_pay, allocated_contracts =
Raw_context.clear_storage_space_to_pay c in
let (c, storage_space_to_pay, allocated_contracts) =
Raw_context.clear_storage_space_to_pay c
in
let storage_space_for_allocated_contracts =
Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in
Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size)
in
let consumed =
Z.add storage_space_to_pay storage_space_for_allocated_contracts in
Z.add storage_space_to_pay storage_space_for_allocated_contracts
in
let remaining = Z.sub storage_limit consumed in
if Compare.Z.(remaining < Z.zero) then
fail Operation_quota_exceeded
if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded
else
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 consumed))) >>=? fun to_burn ->
Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed)
>>=? fun to_burn ->
(* Burning the fees... *)
if Tez_repr.(to_burn = Tez_repr.zero) then
(* If the payer was was deleted by transfering all its balance, and no space was used,
burning zero would fail *)
return c
else
trace Cannot_pay_storage_fee
(Contract_storage.must_exist c payer >>=? fun () ->
Contract_storage.spend c payer to_burn) >>=? fun c ->
return c
trace
Cannot_pay_storage_fee
( Contract_storage.must_exist c payer
>>=? fun () -> Contract_storage.spend c payer to_burn )
>>=? fun c -> return c
let check_storage_limit c ~storage_limit =
if Compare.Z.(storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation)
|| Compare.Z.(storage_limit < Z.zero)then
error Storage_limit_too_high
else
ok ()
if
Compare.Z.(
storage_limit
> (Raw_context.constants c).hard_storage_limit_per_operation)
|| Compare.Z.(storage_limit < Z.zero)
then error Storage_limit_too_high
else ok ()
let start_counting_storage_fees c =
Raw_context.init_storage_space_to_pay c
let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c

22
vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli vendored
View File

@ -24,23 +24,27 @@
(*****************************************************************************)
type error += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
type error += Storage_limit_too_high (* `Permanent *)
(** Does not burn, only adds the burn to storage space to be paid *)
val origination_burn:
val origination_burn :
Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t
(** The returned Tez quantity is for logging purpose only *)
val record_paid_storage_space:
Raw_context.t -> Contract_repr.t ->
val record_paid_storage_space :
Raw_context.t ->
Contract_repr.t ->
(Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t
val check_storage_limit:
Raw_context.t -> storage_limit:Z.t -> unit tzresult
val check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult
val start_counting_storage_fees :
Raw_context.t -> Raw_context.t
val start_counting_storage_fees : Raw_context.t -> Raw_context.t
val burn_storage_fees:
Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t tzresult Lwt.t
val burn_storage_fees :
Raw_context.t ->
storage_limit:Z.t ->
payer:Contract_repr.t ->
Raw_context.t tzresult Lwt.t

32
vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml vendored
View File

@ -38,29 +38,25 @@ let () =
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i;
b
MBytes.set_int64 b 0 i ; b
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then
error Invalid_fitness
else
ok (MBytes.get_int64 b 0)
if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness
else ok (MBytes.get_int64 b 0)
let from_int64 fitness =
[ MBytes.of_string Constants_repr.version_number ;
int64_to_bytes fitness ]
[MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness]
let to_int64 = function
| [ version ;
fitness ]
when Compare.String.
(MBytes.to_string version = Constants_repr.version_number) ->
| [version; fitness]
when Compare.String.(
MBytes.to_string version = Constants_repr.version_number) ->
int64_of_bytes fitness
| [ version ;
_fitness (* ignored since higher version takes priority *) ]
when Compare.String.
(MBytes.to_string version = Constants_repr.version_number_004) ->
| [version; _fitness (* ignored since higher version takes priority *)]
when Compare.String.(
MBytes.to_string version = Constants_repr.version_number_004) ->
ok 0L
| [] -> ok 0L
| _ -> error Invalid_fitness
| [] ->
ok 0L
| _ ->
error Invalid_fitness

1
vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml vendored
View File

@ -24,6 +24,7 @@
(*****************************************************************************)
let current = Raw_context.current_fitness
let increase ?(gap = 1) ctxt =
let fitness = current ctxt in
Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)

215
vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml vendored
View File

@ -23,29 +23,30 @@
(* *)
(*****************************************************************************)
type t =
| Unaccounted
| Limited of { remaining : Z.t }
type t = Unaccounted | Limited of {remaining : Z.t}
type internal_gas = Z.t
type cost =
{ allocations : Z.t ;
steps : Z.t ;
reads : Z.t ;
writes : Z.t ;
bytes_read : Z.t ;
bytes_written : Z.t }
type cost = {
allocations : Z.t;
steps : Z.t;
reads : Z.t;
writes : Z.t;
bytes_read : Z.t;
bytes_written : Z.t;
}
let encoding =
let open Data_encoding in
union
[ case (Tag 0)
[ case
(Tag 0)
~title:"Limited"
z
(function Limited { remaining } -> Some remaining | _ -> None)
(fun remaining -> Limited { remaining }) ;
case (Tag 1)
(function Limited {remaining} -> Some remaining | _ -> None)
(fun remaining -> Limited {remaining});
case
(Tag 1)
~title:"Unaccounted"
(constant "unaccounted")
(function Unaccounted -> Some () | _ -> None)
@ -54,16 +55,16 @@ let encoding =
let pp ppf = function
| Unaccounted ->
Format.fprintf ppf "unaccounted"
| Limited { remaining } ->
| Limited {remaining} ->
Format.fprintf ppf "%s units remaining" (Z.to_string remaining)
let cost_encoding =
let open Data_encoding in
conv
(fun { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } ->
(fun {allocations; steps; reads; writes; bytes_read; bytes_written} ->
(allocations, steps, reads, writes, bytes_read, bytes_written))
(fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
{ allocations ; steps ; reads ; writes ; bytes_read ; bytes_written })
{allocations; steps; reads; writes; bytes_read; bytes_written})
(obj6
(req "allocations" z)
(req "steps" z)
@ -72,8 +73,10 @@ let cost_encoding =
(req "bytes_read" z)
(req "bytes_written" z))
let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } =
Format.fprintf ppf
let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written}
=
Format.fprintf
ppf
"(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
(Z.to_string steps)
(Z.to_string allocations)
@ -83,20 +86,27 @@ let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_writ
(Z.to_string bytes_written)
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
let allocation_weight = Z.of_int 2
let step_weight = Z.of_int 1
let read_base_weight = Z.of_int 100
let write_base_weight = Z.of_int 160
let byte_read_weight = Z.of_int 10
let byte_written_weight = Z.of_int 15
let rescaling_bits = 7
let rescaling_mask =
Z.sub (Z.shift_left Z.one rescaling_bits) Z.one
let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one
let scale (z : Z.t) = Z.shift_left z rescaling_bits
let rescale (z : Z.t) = Z.shift_right z rescaling_bits
let cost_to_internal_gas (cost : cost) : internal_gas =
@ -119,24 +129,20 @@ let internal_gas_to_gas internal_gas : Z.t * internal_gas =
let consume block_gas operation_gas internal_gas cost =
match operation_gas with
| Unaccounted -> ok (block_gas, Unaccounted, internal_gas)
| Limited { remaining } ->
| Unaccounted ->
ok (block_gas, Unaccounted, internal_gas)
| Limited {remaining} ->
let cost_internal_gas = cost_to_internal_gas cost in
let total_internal_gas =
Z.add cost_internal_gas internal_gas in
let gas, rest = internal_gas_to_gas total_internal_gas in
let total_internal_gas = Z.add cost_internal_gas internal_gas in
let (gas, rest) = internal_gas_to_gas total_internal_gas in
if Compare.Z.(gas > Z.zero) then
let remaining =
Z.sub remaining gas in
let block_remaining =
Z.sub block_gas gas in
if Compare.Z.(remaining < Z.zero)
then error Operation_quota_exceeded
else if Compare.Z.(block_remaining < Z.zero)
then error Block_quota_exceeded
else ok (block_remaining, Limited { remaining }, rest)
else
ok (block_gas, operation_gas, total_internal_gas)
let remaining = Z.sub remaining gas in
let block_remaining = Z.sub block_gas gas in
if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded
else if Compare.Z.(block_remaining < Z.zero) then
error Block_quota_exceeded
else ok (block_remaining, Limited {remaining}, rest)
else ok (block_gas, operation_gas, total_internal_gas)
let check_enough block_gas operation_gas internal_gas cost =
consume block_gas operation_gas internal_gas cost
@ -145,97 +151,110 @@ let check_enough block_gas operation_gas internal_gas cost =
let internal_gas_zero : internal_gas = Z.zero
let alloc_cost n =
{ allocations = scale (Z.of_int (n + 1)) ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
{
allocations = scale (Z.of_int (n + 1));
steps = Z.zero;
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let alloc_bytes_cost n =
alloc_cost ((n + 7) / 8)
let alloc_bytes_cost n = alloc_cost ((n + 7) / 8)
let alloc_bits_cost n =
alloc_cost ((n + 63) / 64)
let alloc_bits_cost n = alloc_cost ((n + 63) / 64)
let atomic_step_cost n =
{ allocations = Z.zero ;
steps = Z.of_int (2 * n) ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
{
allocations = Z.zero;
steps = Z.of_int (2 * n);
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let step_cost n =
{ allocations = Z.zero ;
steps = scale (Z.of_int n) ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
{
allocations = Z.zero;
steps = scale (Z.of_int n);
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let free =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
{
allocations = Z.zero;
steps = Z.zero;
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let read_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = scale Z.one ;
writes = Z.zero ;
bytes_read = scale n ;
bytes_written = Z.zero }
{
allocations = Z.zero;
steps = Z.zero;
reads = scale Z.one;
writes = Z.zero;
bytes_read = scale n;
bytes_written = Z.zero;
}
let write_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.one ;
bytes_read = Z.zero ;
bytes_written = scale n }
{
allocations = Z.zero;
steps = Z.zero;
reads = Z.zero;
writes = Z.one;
bytes_read = Z.zero;
bytes_written = scale n;
}
let ( +@ ) x y =
{ allocations = Z.add x.allocations y.allocations ;
steps = Z.add x.steps y.steps ;
reads = Z.add x.reads y.reads ;
writes = Z.add x.writes y.writes ;
bytes_read = Z.add x.bytes_read y.bytes_read ;
bytes_written = Z.add x.bytes_written y.bytes_written }
{
allocations = Z.add x.allocations y.allocations;
steps = Z.add x.steps y.steps;
reads = Z.add x.reads y.reads;
writes = Z.add x.writes y.writes;
bytes_read = Z.add x.bytes_read y.bytes_read;
bytes_written = Z.add x.bytes_written y.bytes_written;
}
let ( *@ ) x y =
{ allocations = Z.mul (Z.of_int x) y.allocations ;
steps = Z.mul (Z.of_int x) y.steps ;
reads = Z.mul (Z.of_int x) y.reads ;
writes = Z.mul (Z.of_int x) y.writes ;
bytes_read = Z.mul (Z.of_int x) y.bytes_read ;
bytes_written = Z.mul (Z.of_int x) y.bytes_written }
{
allocations = Z.mul (Z.of_int x) y.allocations;
steps = Z.mul (Z.of_int x) y.steps;
reads = Z.mul (Z.of_int x) y.reads;
writes = Z.mul (Z.of_int x) y.writes;
bytes_read = Z.mul (Z.of_int x) y.bytes_read;
bytes_written = Z.mul (Z.of_int x) y.bytes_written;
}
let alloc_mbytes_cost n =
alloc_cost 12 +@ alloc_bytes_cost n
let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:"gas_exhausted.operation"
~title: "Gas quota exceeded for the operation"
~title:"Gas quota exceeded for the operation"
~description:
"A script or one of its callee took more \
time than the operation said it would"
"A script or one of its callee took more time than the operation said \
it would"
empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Temporary
~id:"gas_exhausted.block"
~title: "Gas quota exceeded for the block"
~title:"Gas quota exceeded for the block"
~description:
"The sum of gas consumed by all the operations in the block \
exceeds the hard gas limit per block"
"The sum of gas consumed by all the operations in the block exceeds the \
hard gas limit per block"
empty
(function Block_quota_exceeded -> Some () | _ -> None)
(fun () -> Block_quota_exceeded) ;
(fun () -> Block_quota_exceeded)

20
vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli vendored
View File

@ -23,37 +23,49 @@
(* *)
(*****************************************************************************)
type t =
| Unaccounted
| Limited of { remaining : Z.t }
type t = Unaccounted | Limited of {remaining : Z.t}
type internal_gas
val encoding : t Data_encoding.encoding
val pp : Format.formatter -> t -> unit
type cost
val cost_encoding : cost Data_encoding.encoding
val pp_cost : Format.formatter -> cost -> unit
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
val consume : Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult
val consume :
Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult
val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult
val internal_gas_zero : internal_gas
val free : cost
val atomic_step_cost : int -> cost
val step_cost : int -> cost
val alloc_cost : int -> cost
val alloc_bytes_cost : int -> cost
val alloc_mbytes_cost : int -> cost
val alloc_bits_cost : int -> cost
val read_bytes_cost : Z.t -> cost
val write_bytes_cost : Z.t -> cost
val ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost

953
vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml vendored
View File

File diff suppressed because it is too large Load Diff

236
vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli vendored
View File

@ -27,69 +27,99 @@ open Alpha_context
type error += Cannot_parse_operation (* `Branch *)
val current_level:
'a #RPC_context.simple ->
?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t
val current_level :
'a #RPC_context.simple -> ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t
val levels_in_current_cycle:
val levels_in_current_cycle :
'a #RPC_context.simple ->
?offset:int32 -> 'a -> (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t
?offset:int32 ->
'a ->
(Raw_level.t * Raw_level.t) shell_tzresult Lwt.t
module Scripts : sig
val run_code:
val run_code :
'a #RPC_context.simple ->
'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) ->
(Script.expr *
packed_internal_operation list *
Contract.big_map_diff option) shell_tzresult Lwt.t
'a ->
Script.expr ->
Script.expr
* Script.expr
* Tez.t
* Chain_id.t
* Contract.t option
* Contract.t option
* Z.t option
* string ->
( Script.expr
* packed_internal_operation list
* Contract.big_map_diff option )
shell_tzresult
Lwt.t
val trace_code:
val trace_code :
'a #RPC_context.simple ->
'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) ->
(Script.expr *
packed_internal_operation list *
Script_interpreter.execution_trace *
Contract.big_map_diff option) shell_tzresult Lwt.t
'a ->
Script.expr ->
Script.expr
* Script.expr
* Tez.t
* Chain_id.t
* Contract.t option
* Contract.t option
* Z.t option
* string ->
( Script.expr
* packed_internal_operation list
* Script_interpreter.execution_trace
* Contract.big_map_diff option )
shell_tzresult
Lwt.t
val typecheck_code:
val typecheck_code :
'a #RPC_context.simple ->
'a -> (Script.expr * Z.t option) ->
'a ->
Script.expr * Z.t option ->
(Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t
val typecheck_data:
val typecheck_data :
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * Z.t option -> Gas.t shell_tzresult Lwt.t
'a ->
Script.expr * Script.expr * Z.t option ->
Gas.t shell_tzresult Lwt.t
val pack_data:
val pack_data :
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * Z.t option -> (MBytes.t * Gas.t) shell_tzresult Lwt.t
'a ->
Script.expr * Script.expr * Z.t option ->
(MBytes.t * Gas.t) shell_tzresult Lwt.t
val run_operation:
val run_operation :
'a #RPC_context.simple ->
'a -> packed_operation * Chain_id.t ->
(packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t
'a ->
packed_operation * Chain_id.t ->
(packed_protocol_data * Apply_results.packed_operation_metadata)
shell_tzresult
Lwt.t
val entrypoint_type:
val entrypoint_type :
'a #RPC_context.simple ->
'a -> Script.expr * string -> Script.expr shell_tzresult Lwt.t
'a ->
Script.expr * string ->
Script.expr shell_tzresult Lwt.t
val list_entrypoints:
val list_entrypoints :
'a #RPC_context.simple ->
'a -> Script.expr ->
(Michelson_v1_primitives.prim list list *
(string * Script.expr) list) shell_tzresult Lwt.t
'a ->
Script.expr ->
(Michelson_v1_primitives.prim list list * (string * Script.expr) list)
shell_tzresult
Lwt.t
end
module Forge : sig
module Manager : sig
val operations:
'a #RPC_context.simple -> 'a ->
val operations :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
?sourcePubKey:public_key ->
@ -97,19 +127,23 @@ module Forge : sig
fee:Tez.t ->
gas_limit:Z.t ->
storage_limit:Z.t ->
packed_manager_operation list -> MBytes.t shell_tzresult Lwt.t
packed_manager_operation list ->
MBytes.t shell_tzresult Lwt.t
val reveal:
'a #RPC_context.simple -> 'a ->
val reveal :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
sourcePubKey:public_key ->
counter:counter ->
fee:Tez.t ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val transaction:
'a #RPC_context.simple -> 'a ->
val transaction :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
?sourcePubKey:public_key ->
@ -121,24 +155,28 @@ module Forge : sig
gas_limit:Z.t ->
storage_limit:Z.t ->
fee:Tez.t ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val origination:
'a #RPC_context.simple -> 'a ->
val origination :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
?sourcePubKey:public_key ->
counter:counter ->
balance:Tez.t ->
?delegatePubKey: public_key_hash ->
?delegatePubKey:public_key_hash ->
script:Script.t ->
gas_limit:Z.t ->
storage_limit:Z.t ->
fee:Tez.t->
unit -> MBytes.t shell_tzresult Lwt.t
fee:Tez.t ->
unit ->
MBytes.t shell_tzresult Lwt.t
val delegation:
'a #RPC_context.simple -> 'a ->
val delegation :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
?sourcePubKey:public_key ->
@ -146,74 +184,88 @@ module Forge : sig
fee:Tez.t ->
public_key_hash option ->
MBytes.t shell_tzresult Lwt.t
end
val endorsement:
'a #RPC_context.simple -> 'a ->
val endorsement :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
level:Raw_level.t ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val proposals:
'a #RPC_context.simple -> 'a ->
val proposals :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
period:Voting_period.t ->
proposals:Protocol_hash.t list ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val ballot:
'a #RPC_context.simple -> 'a ->
val ballot :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
source:public_key_hash ->
period:Voting_period.t ->
proposal:Protocol_hash.t ->
ballot:Vote.ballot ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val seed_nonce_revelation:
'a #RPC_context.simple -> 'a ->
val seed_nonce_revelation :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
level:Raw_level.t ->
nonce:Nonce.t ->
unit -> MBytes.t shell_tzresult Lwt.t
unit ->
MBytes.t shell_tzresult Lwt.t
val double_baking_evidence:
'a #RPC_context.simple -> 'a ->
val double_baking_evidence :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
bh1: Block_header.t ->
bh2: Block_header.t ->
unit -> MBytes.t shell_tzresult Lwt.t
bh1:Block_header.t ->
bh2:Block_header.t ->
unit ->
MBytes.t shell_tzresult Lwt.t
val double_endorsement_evidence:
'a #RPC_context.simple -> 'a ->
val double_endorsement_evidence :
'a #RPC_context.simple ->
'a ->
branch:Block_hash.t ->
op1: Kind.endorsement operation ->
op2: Kind.endorsement operation ->
unit -> MBytes.t shell_tzresult Lwt.t
val protocol_data:
'a #RPC_context.simple -> 'a ->
priority: int ->
?seed_nonce_hash: Nonce_hash.t ->
?proof_of_work_nonce: MBytes.t ->
unit -> MBytes.t shell_tzresult Lwt.t
op1:Kind.endorsement operation ->
op2:Kind.endorsement operation ->
unit ->
MBytes.t shell_tzresult Lwt.t
val protocol_data :
'a #RPC_context.simple ->
'a ->
priority:int ->
?seed_nonce_hash:Nonce_hash.t ->
?proof_of_work_nonce:MBytes.t ->
unit ->
MBytes.t shell_tzresult Lwt.t
end
module Parse : sig
val operations:
'a #RPC_context.simple -> 'a ->
?check:bool -> Operation.raw list ->
val operations :
'a #RPC_context.simple ->
'a ->
?check:bool ->
Operation.raw list ->
Operation.packed list shell_tzresult Lwt.t
val block:
'a #RPC_context.simple -> 'a ->
Block_header.shell_header -> MBytes.t ->
val block :
'a #RPC_context.simple ->
'a ->
Block_header.shell_header ->
MBytes.t ->
Block_header.protocol_data shell_tzresult Lwt.t
end
val register: unit -> unit
val register : unit -> unit

364
vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml vendored
View File

@ -2,7 +2,6 @@
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
@ -24,355 +23,36 @@
(* *)
(*****************************************************************************)
(* Delegated storage changed type of value from Contract_hash to
Contract_repr. Move all 'delegated' data into a storage with
the original type, then copy over into the new storage. *)
let migrate_delegated ctxt contract =
let path = "contracts" :: (* module Contract *)
"index" :: (* module Indexed_context *)
Contract_repr.Index.to_path contract [
"delegated" ; (* module Delegated *)
] in
let path_tmp = "contracts" :: (* module Contract *)
"index" :: (* module Indexed_context *)
Contract_repr.Index.to_path contract [
"delegated_004" ; (* module Delegated *)
] in
Raw_context.dir_mem ctxt path >>= fun exists ->
if exists then
Raw_context.copy ctxt path path_tmp >>=? fun ctxt ->
Raw_context.remove_rec ctxt path >>= fun ctxt ->
Storage.Contract.Delegated_004.fold (ctxt, contract) ~init:(Ok ctxt) ~f:(fun delegated ctxt ->
Lwt.return ctxt >>=? fun ctxt ->
let originated = Contract_repr.originated_contract_004 delegated in
Storage.Contract.Delegated.add (ctxt, contract) originated >>= fun ctxt ->
return ctxt
) >>=? fun ctxt ->
Raw_context.remove_rec ctxt path_tmp >>= fun ctxt ->
return ctxt
else
return ctxt
let transform_script:
(manager_pkh: Signature.Public_key_hash.t ->
script_code: Script_repr.lazy_expr ->
script_storage: Script_repr.lazy_expr ->
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t) ->
manager_pkh: Signature.Public_key_hash.t ->
Raw_context.t ->
Contract_repr.t ->
Script_repr.lazy_expr ->
Raw_context.t tzresult Lwt.t =
fun transformation ~manager_pkh ctxt contract code ->
Storage.Contract.Storage.get ctxt contract >>=? fun (_ctxt, storage) ->
transformation manager_pkh code storage >>=? fun (migrated_code, migrated_storage) ->
(* Set the migrated script code for free *)
Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, code_size_diff) ->
(* Set the migrated script storage for free *)
Storage.Contract.Storage.set_free ctxt contract migrated_storage >>=? fun (ctxt, storage_size_diff) ->
Storage.Contract.Used_storage_space.get ctxt contract >>=? fun used_space ->
let total_size = Z.(add (of_int code_size_diff) (add (of_int storage_size_diff) used_space)) in
(* Free storage space for migrated contracts *)
Storage.Contract.Used_storage_space.set ctxt contract total_size >>=? fun ctxt ->
Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_space ->
if Compare.Z.(paid_space < total_size) then
Storage.Contract.Paid_storage_space.set ctxt contract total_size >>=? fun ctxt ->
return ctxt
else
return ctxt
let manager_script_storage: Signature.Public_key_hash.t -> Script_repr.lazy_expr =
fun manager_pkh ->
let open Micheline in
Script_repr.lazy_expr @@ strip_locations @@
(* store in optimized binary representation - as unparsed with [Optimized]. *)
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh in
Bytes (0, bytes)
(* If the given contract is not allocated, we'll allocate it with 1 mutez,
so that the migrated contracts' managers don't have to pay origination burn *)
let allocate_contract ctxt contract =
Contract_storage.allocated ctxt contract >>=? function
| true ->
return ctxt
| false ->
Contract_storage.credit ctxt contract Tez_repr.one_mutez
(* Process an individual contract *)
let process_contract_add_manager contract ctxt =
let open Legacy_script_support_repr in
match Contract_repr.is_originated contract with
| None -> return ctxt (* Only process originated contracts *)
| Some _ -> begin
Storage.Contract.Counter.remove ctxt contract >>= fun ctxt ->
Storage.Contract.Spendable_004.mem ctxt contract >>= fun is_spendable ->
Storage.Contract.Delegatable_004.mem ctxt contract >>= fun is_delegatable ->
Storage.Contract.Spendable_004.del ctxt contract >>= fun ctxt ->
Storage.Contract.Delegatable_004.del ctxt contract >>= fun ctxt ->
(* Try to get script code (ignore ctxt update to discard the initialization) *)
Storage.Contract.Code.get_option ctxt contract >>=? fun (_ctxt, code) ->
(* Get the manager of the originated contract *)
Contract_storage.get_manager_004 ctxt contract >>=? fun manager_pkh ->
let manager = Contract_repr.implicit_contract manager_pkh in
Storage.Contract.Manager.remove ctxt contract >>= fun ctxt ->
match code with
| Some code ->
(*
| spendable | delegatable | template |
|-----------+-------------+------------------|
| true | true | add_do |
| true | false | add_do |
| false | true | add_set_delegate |
| false | false | nothing |
*)
if is_spendable then
transform_script add_do ~manager_pkh ctxt contract code >>=? fun ctxt ->
allocate_contract ctxt manager
else if is_delegatable then
transform_script add_set_delegate ~manager_pkh ctxt contract code >>=? fun ctxt ->
allocate_contract ctxt manager
else if has_default_entrypoint code then
transform_script
(fun ~manager_pkh:_ ~script_code ~script_storage ->
add_root_entrypoint script_code >>=? fun script_code ->
return (script_code, script_storage))
~manager_pkh ctxt contract code
else
return ctxt
| None -> begin
(* Initialize the script code for free *)
Storage.Contract.Code.init_free ctxt contract manager_script_code >>=? fun (ctxt, code_size) ->
let storage = manager_script_storage manager_pkh in
(* Initialize the script storage for free *)
Storage.Contract.Storage.init_free ctxt contract storage >>=? fun (ctxt, storage_size) ->
let total_size = Z.(add (of_int code_size) (of_int storage_size)) in
(* Free storage space for migrated contracts *)
Storage.Contract.Paid_storage_space.init_set ctxt contract total_size >>= fun ctxt ->
Storage.Contract.Used_storage_space.init_set ctxt contract total_size >>= fun ctxt ->
allocate_contract ctxt manager
end
end
(* The [[update_contract_script]] function returns a copy of its
argument (the Micheline AST of a contract script) with "ADDRESS"
replaced by "ADDRESS; CHAIN_ID; PAIR".
[[Micheline.strip_locations]] should be called on the resulting
Micheline AST to get meaningful locations. *)
let rec update_contract_script : ('l, 'p) Micheline.node -> ('l, 'p) Micheline.node
= function
| Micheline.Seq (_,
Micheline.Prim (_, Michelson_v1_primitives.I_ADDRESS, [], []) ::
l) ->
Micheline.Seq (0,
Micheline.Prim (0, Michelson_v1_primitives.I_ADDRESS, [], []) ::
Micheline.Prim (0, Michelson_v1_primitives.I_CHAIN_ID, [], []) ::
Micheline.Prim (0, Michelson_v1_primitives.I_PAIR, [], []) :: l)
| Micheline.Seq (_, a :: l) ->
let a' = update_contract_script a in
let b = Micheline.Seq (0, l) in
let b' = update_contract_script b in
begin match b' with
| Micheline.Seq (_, l') ->
Micheline.Seq (0, a' :: l')
| _ -> assert false
end
| Micheline.Prim (_, p, l, annot) ->
Micheline.Prim (0, p, List.map update_contract_script l, annot)
| script -> script
let migrate_multisig_script (ctxt : Raw_context.t) (contract : Contract_repr.t)
(code : Script_repr.expr) : Raw_context.t tzresult Lwt.t =
let migrated_code =
Script_repr.lazy_expr @@ Micheline.strip_locations @@
update_contract_script @@ Micheline.root code
in
Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, _code_size_diff) ->
(* Set the spendable and delegatable flags to false so that no entrypoint gets added by
the [[process_contract_add_manager]] function. *)
Storage.Contract.Spendable_004.set ctxt contract false >>= fun ctxt ->
Storage.Contract.Delegatable_004.set ctxt contract false >>= fun ctxt ->
return ctxt
(* The hash of the multisig contract; only contracts with this exact
hash are going to be updated by the [[update_contract_script]]
function. *)
let multisig_hash : Script_expr_hash.t =
Script_expr_hash.of_bytes_exn @@
MBytes.of_hex @@
`Hex "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"
let process_contract_multisig (contract : Contract_repr.t) (ctxt : Raw_context.t) =
Contract_storage.get_script ctxt contract >>=? fun (ctxt, script_opt) ->
match script_opt with
| None ->
(* Do nothing on scriptless contracts *)
return ctxt
| Some { Script_repr.code = code ; Script_repr.storage = _storage } ->
(* The contract has some script, only try to modify it if it has
the hash of the multisig contract *)
Lwt.return (Script_repr.force_decode code) >>=? fun (code, _gas_cost) ->
let bytes =
Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding code
in
let hash = Script_expr_hash.hash_bytes [ bytes ] in
if Script_expr_hash.(hash = multisig_hash) then
migrate_multisig_script ctxt contract code
else
return ctxt
(* Process an individual contract *)
let process_contract contract ctxt =
process_contract_multisig contract ctxt >>=? fun ctxt ->
process_contract_add_manager contract ctxt >>=? fun ctxt ->
return ctxt
let invoice_contract ctxt kt1_addr amount =
let amount = Tez_repr.of_mutez_exn (Int64.(mul 1_000_000L (of_int amount))) in
match Contract_repr.of_b58check kt1_addr with
| Ok recipient -> begin
Contract_storage.credit ctxt recipient amount >>= function
| Ok ctxt -> return ctxt
| Error _ -> return ctxt end
| Error _ -> return ctxt
(* Extract Big_maps from their parent contract directory,
recompute their used space, and assign them an ID. *)
let migrate_contract_big_map ctxt contract =
Storage.Contract.Code.get_option ctxt contract >>=? function
| ctxt, None -> return ctxt
| ctxt, Some code ->
Storage.Contract.Storage.get ctxt contract >>=? fun (ctxt, storage) ->
let extract_big_map_types expr =
let open Michelson_v1_primitives in
let open Micheline in
match Micheline.root expr with
| Seq (_, [ Prim (_, K_storage, [ expr ], _) ; _ ; _ ])
| Seq (_, [ _ ; Prim (_, K_storage, [ expr ], _) ; _ ])
| Seq (_, [ _ ; _ ; Prim (_, K_storage, [ expr ], _) ]) ->
begin match expr with
| Prim (_, T_pair, [ Prim (_, T_big_map, [ kt ; vt ], _ ) ; _ ], _) -> Some (kt, vt)
| _ -> None
end
| _ -> None in
let rewrite_big_map expr id =
let open Michelson_v1_primitives in
let open Micheline in
match Micheline.root expr with
| Prim (_, D_Pair, [ Seq (_, _ (* ignore_unused_origination_literal *)) ; pannot ], sannot) ->
Micheline.strip_locations (Prim (0, D_Pair, [ Int (0, id) ; pannot ], sannot))
| _ -> assert false in
Lwt.return (Script_repr.force_decode code) >>=? fun (code, _) ->
match extract_big_map_types code with
| None -> return ctxt
| Some (kt, vt) ->
Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, _) ->
Storage.Big_map.Next.incr ctxt >>=? fun (ctxt, id) ->
let contract_path suffix =
"contracts" :: (* module Contract *)
"index" :: (* module Indexed_context *)
Contract_repr.Index.to_path contract suffix in
let old_path = contract_path [ "big_map" ] in
let storage = rewrite_big_map storage id in
Storage.Contract.Storage.set ctxt contract (Script_repr.lazy_expr storage) >>=? fun (ctxt, _) ->
let kt = Micheline.strip_locations (Script_repr.strip_annotations kt) in
let vt = Micheline.strip_locations (Script_repr.strip_annotations vt) in
Storage.Big_map.Key_type.init ctxt id kt >>=? fun ctxt ->
Storage.Big_map.Value_type.init ctxt id vt >>=? fun ctxt ->
Raw_context.dir_mem ctxt old_path >>= fun exists ->
if exists then
let read_size ctxt key =
Raw_context.get ctxt key >>=? fun len ->
match Data_encoding.(Binary.of_bytes int31) len with
| None -> assert false
| Some len -> return len in
let iter_sizes f (ctxt, acc) =
let rec dig i path (ctxt, acc) =
if Compare.Int.(i <= 0) then
Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc ->
Lwt.return acc >>=? fun (ctxt, acc) ->
match k with
| `Dir _ -> return (ctxt, acc)
| `Key file ->
match List.rev file with
| last :: _ when Compare.String.(last = "data") ->
return (ctxt, acc)
| last :: _ when Compare.String.(last = "len") ->
read_size ctxt file >>=? fun len ->
return (ctxt, f len acc)
| _ -> assert false
end
else
Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc ->
Lwt.return acc >>=? fun (ctxt, acc) ->
match k with
| `Dir k -> dig (i-1) k (ctxt, acc)
| `Key _ -> return (ctxt, acc)
end in
dig Script_expr_hash.path_length old_path (ctxt, acc) in
iter_sizes
(fun s acc -> (acc |> Z.add (Z.of_int s) |> Z.add (Z.of_int 65)))
(ctxt, (Z.of_int 0)) >>=? fun (ctxt, total_bytes) ->
Storage.Big_map.Total_bytes.init ctxt id total_bytes >>=? fun ctxt ->
let new_path = "big_maps" :: (* module Big_map *)
"index" :: (* module Indexed_context *)
Storage.Big_map.Index.to_path id [
"contents" ; (* module Delegated *)
] in
Raw_context.copy ctxt old_path new_path >>=? fun ctxt ->
Raw_context.remove_rec ctxt old_path >>= fun ctxt ->
read_size ctxt (contract_path [ "len" ; "code" ]) >>=? fun code_size ->
read_size ctxt (contract_path [ "len" ; "storage" ]) >>=? fun storage_size ->
let total_bytes =
total_bytes |>
Z.add (Z.of_int 33) |>
Z.add (Z.of_int code_size) |>
Z.add (Z.of_int storage_size) in
Storage.Contract.Used_storage_space.get ctxt contract >>=? fun previous_size ->
Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_bytes ->
let change = Z.sub paid_bytes previous_size in
Storage.Contract.Used_storage_space.set ctxt contract total_bytes >>=? fun ctxt ->
Storage.Contract.Paid_storage_space.set ctxt contract (Z.add total_bytes change)
else
Storage.Big_map.Total_bytes.init ctxt id Z.zero >>=? fun ctxt ->
return ctxt
(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
Raw_context.prepare_first_block
~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) ->
Storage.Big_map.Next.init ctxt >>=? fun ctxt ->
Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt
>>=? fun (previous_protocol, ctxt) ->
match previous_protocol with
| Genesis param ->
Commitment_storage.init ctxt param.commitments >>=? fun ctxt ->
Roll_storage.init ctxt >>=? fun ctxt ->
Seed_storage.init ctxt >>=? fun ctxt ->
Contract_storage.init ctxt >>=? fun ctxt ->
Bootstrap_storage.init ctxt
Commitment_storage.init ctxt param.commitments
>>=? fun ctxt ->
Roll_storage.init ctxt
>>=? fun ctxt ->
Seed_storage.init ctxt
>>=? fun ctxt ->
Contract_storage.init ctxt
>>=? fun ctxt ->
Bootstrap_storage.init
ctxt
~typecheck
?ramp_up_cycles:param.security_deposit_ramp_up_cycles
?no_reward_cycles:param.no_reward_cycles
param.bootstrap_accounts
param.bootstrap_contracts >>=? fun ctxt ->
Roll_storage.init_first_cycles ctxt >>=? fun ctxt ->
Vote_storage.init ctxt >>=? fun ctxt ->
Storage.Block_priority.init ctxt 0 >>=? fun ctxt ->
Vote_storage.freeze_listings ctxt >>=? fun ctxt ->
return ctxt
| Athens_004 ->
Storage.Vote.Current_quorum_004.get ctxt >>=? fun quorum ->
Storage.Vote.Participation_ema.init ctxt quorum >>=? fun ctxt ->
Storage.Vote.Current_quorum_004.delete ctxt >>=? fun ctxt ->
Storage.Block_priority.init ctxt 0 >>=? fun ctxt ->
Storage.Last_block_priority.delete ctxt >>=? fun ctxt ->
Storage.Contract.fold ctxt ~init:(Ok ctxt)
~f:(fun contract ctxt ->
Lwt.return ctxt >>=? fun ctxt ->
migrate_delegated ctxt contract >>=? fun ctxt ->
migrate_contract_big_map ctxt contract >>=? fun ctxt ->
process_contract contract ctxt)
param.bootstrap_contracts
>>=? fun ctxt ->
invoice_contract ctxt "KT1DUfaMfTRZZkvZAYQT5b3byXnvqoAykc43" 500 >>=? fun ctxt ->
Roll_storage.init_first_cycles ctxt
>>=? fun ctxt ->
Vote_storage.init ctxt
>>=? fun ctxt ->
Storage.Block_priority.init ctxt 0
>>=? fun ctxt ->
Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt
| Babylon_005 ->
return ctxt
let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =

1086
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml vendored
View File

File diff suppressed because it is too large Load Diff

26
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli vendored
View File

@ -31,7 +31,7 @@
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz
The formal proof is at:
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *)
val manager_script_code: Script_repr.lazy_expr
val manager_script_code : Script_repr.lazy_expr
(** This code mimics the now defunct "spendable" flags of KT1s by
adding a [do] entrypoint, preserving the original script's at
@ -39,10 +39,10 @@ val manager_script_code: Script_repr.lazy_expr
The pseudo-code for the applied transformations is from:
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *)
val add_do:
manager_pkh: Signature.Public_key_hash.t ->
script_code: Script_repr.lazy_expr ->
script_storage: Script_repr.lazy_expr ->
val add_do :
manager_pkh:Signature.Public_key_hash.t ->
script_code:Script_repr.lazy_expr ->
script_storage:Script_repr.lazy_expr ->
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t
(** This code mimics the now defunct "spendable" flags of KT1s by
@ -51,19 +51,17 @@ val add_do:
The pseudo-code for the applied transformations is from:
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *)
val add_set_delegate:
manager_pkh: Signature.Public_key_hash.t ->
script_code: Script_repr.lazy_expr ->
script_storage: Script_repr.lazy_expr ->
val add_set_delegate :
manager_pkh:Signature.Public_key_hash.t ->
script_code:Script_repr.lazy_expr ->
script_storage:Script_repr.lazy_expr ->
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t
(** Checks if a contract was declaring a default entrypoint somewhere
else than at the root, in which case its type changes when
entrypoints are activated. *)
val has_default_entrypoint:
Script_repr.lazy_expr -> bool
val has_default_entrypoint : Script_repr.lazy_expr -> bool
(** Adds a [%root] annotation on the toplevel parameter construct. *)
val add_root_entrypoint:
script_code: Script_repr.lazy_expr ->
Script_repr.lazy_expr tzresult Lwt.t
val add_root_entrypoint :
script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t

187
vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml vendored
View File

@ -24,125 +24,162 @@
(*****************************************************************************)
type t = {
level: Raw_level_repr.t ;
level_position: int32 ;
cycle: Cycle_repr.t ;
cycle_position: int32 ;
voting_period: Voting_period_repr.t ;
voting_period_position: int32 ;
expected_commitment: bool ;
level : Raw_level_repr.t;
level_position : int32;
cycle : Cycle_repr.t;
cycle_position : int32;
voting_period : Voting_period_repr.t;
voting_period_position : int32;
expected_commitment : bool;
}
include Compare.Make(struct
include Compare.Make (struct
type nonrec t = t
let compare { level = l1 } { level = l2 } = Raw_level_repr.compare l1 l2
end)
let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2
end)
type level = t
let pp ppf { level } = Raw_level_repr.pp ppf level
let pp ppf {level} = Raw_level_repr.pp ppf level
let pp_full ppf l =
Format.fprintf ppf
Format.fprintf
ppf
"%a.%ld (cycle %a.%ld) (vote %a.%ld)"
Raw_level_repr.pp l.level l.level_position
Cycle_repr.pp l.cycle l.cycle_position
Voting_period_repr.pp l.voting_period l.voting_period_position
Raw_level_repr.pp
l.level
l.level_position
Cycle_repr.pp
l.cycle
l.cycle_position
Voting_period_repr.pp
l.voting_period
l.voting_period_position
let encoding =
let open Data_encoding in
conv
(fun { level ; level_position ;
cycle ; cycle_position ;
voting_period; voting_period_position ;
(fun { level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment } ->
(level, level_position,
cycle, cycle_position,
voting_period, voting_period_position,
expected_commitment))
(fun (level, level_position,
cycle, cycle_position,
voting_period, voting_period_position,
expected_commitment) ->
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position ;
expected_commitment })
( level,
level_position,
cycle,
cycle_position,
voting_period,
voting_period_position,
expected_commitment ))
(fun ( level,
level_position,
cycle,
cycle_position,
voting_period,
voting_period_position,
expected_commitment ) ->
{
level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment;
})
(obj7
(req "level"
(req
"level"
~description:
"The level of the block relative to genesis. This is also \
the Shell's notion of level"
"The level of the block relative to genesis. This is also the \
Shell's notion of level"
Raw_level_repr.encoding)
(req "level_position"
(req
"level_position"
~description:
"The level of the block relative to the block that starts \
protocol alpha. This is specific to the protocol \
alpha. Other protocols might or might not include a \
similar notion."
protocol alpha. This is specific to the protocol alpha. Other \
protocols might or might not include a similar notion."
int32)
(req "cycle"
(req
"cycle"
~description:
"The current cycle's number. Note that cycles are a \
protocol-specific notion. As a result, the cycle number starts at 0 \
with the first block of protocol alpha."
protocol-specific notion. As a result, the cycle number starts \
at 0 with the first block of protocol alpha."
Cycle_repr.encoding)
(req "cycle_position"
(req
"cycle_position"
~description:
"The current level of the block relative to the first \
block of the current cycle."
"The current level of the block relative to the first block of \
the current cycle."
int32)
(req "voting_period"
(req
"voting_period"
~description:
"The current voting period's index. Note that cycles are a \
protocol-specific notion. As a result, the voting period \
index starts at 0 with the first block of protocol alpha."
protocol-specific notion. As a result, the voting period index \
starts at 0 with the first block of protocol alpha."
Voting_period_repr.encoding)
(req "voting_period_position"
(req
"voting_period_position"
~description:
"The current level of the block relative to the first \
block of the current voting period."
"The current level of the block relative to the first block of \
the current voting period."
int32)
(req "expected_commitment"
(req
"expected_commitment"
~description:
"Tells wether the baker of this block has to commit a seed \
nonce hash."
"Tells wether the baker of this block has to commit a seed nonce \
hash."
bool))
let root first_level =
{ level = first_level ;
level_position = 0l ;
cycle = Cycle_repr.root ;
cycle_position = 0l ;
voting_period = Voting_period_repr.root ;
voting_period_position = 0l ;
expected_commitment = false ;
{
level = first_level;
level_position = 0l;
cycle = Cycle_repr.root;
cycle_position = 0l;
voting_period = Voting_period_repr.root;
voting_period_position = 0l;
expected_commitment = false;
}
let from_raw
~first_level ~blocks_per_cycle ~blocks_per_voting_period
~blocks_per_commitment
level =
let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period
~blocks_per_commitment level =
let raw_level = Raw_level_repr.to_int32 level in
let first_level = Raw_level_repr.to_int32 first_level in
let level_position =
Compare.Int32.max 0l (Int32.sub raw_level first_level) in
Compare.Int32.max 0l (Int32.sub raw_level first_level)
in
let cycle =
Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in
Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle)
in
let cycle_position = Int32.rem level_position blocks_per_cycle in
let voting_period =
Voting_period_repr.of_int32_exn
(Int32.div level_position blocks_per_voting_period) in
(Int32.div level_position blocks_per_voting_period)
in
let voting_period_position =
Int32.rem level_position blocks_per_voting_period in
Int32.rem level_position blocks_per_voting_period
in
let expected_commitment =
Compare.Int32.(Int32.rem cycle_position blocks_per_commitment =
Int32.pred blocks_per_commitment) in
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position ;
expected_commitment }
Compare.Int32.(
Int32.rem cycle_position blocks_per_commitment
= Int32.pred blocks_per_commitment)
in
{
level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment;
}
let diff { level = l1 ; _ } { level = l2 ; _ } =
let diff {level = l1; _} {level = l2; _} =
Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)

45
vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli vendored
View File

@ -24,21 +24,25 @@
(*****************************************************************************)
type t = private {
level: Raw_level_repr.t (** The level of the block relative to genesis. This
is also the Shell's notion of level. *);
level_position: int32 (** The level of the block relative to the block that
level : Raw_level_repr.t;
(** The level of the block relative to genesis. This
is also the Shell's notion of level. *)
level_position : int32;
(** The level of the block relative to the block that
starts protocol alpha. This is specific to the
protocol alpha. Other protocols might or might not
include a similar notion. *);
cycle: Cycle_repr.t (** The current cycle's number. Note that cycles are a
include a similar notion. *)
cycle : Cycle_repr.t;
(** The current cycle's number. Note that cycles are a
protocol-specific notion. As a result, the cycle
number starts at 0 with the first block of protocol
alpha. *);
cycle_position: int32 (** The current level of the block relative to the first
block of the current cycle. *);
voting_period: Voting_period_repr.t ;
voting_period_position: int32 ;
expected_commitment: bool ;
alpha. *)
cycle_position : int32;
(** The current level of the block relative to the first
block of the current cycle. *)
voting_period : Voting_period_repr.t;
voting_period_position : int32;
expected_commitment : bool;
}
(* Note that, the type `t` above must respect some invariants (hence the
@ -47,23 +51,24 @@ type t = private {
level_position = cycle * blocks_per_cycle + cycle_position
*)
type level = t
include Compare.S with type t := level
val encoding: level Data_encoding.t
val pp: Format.formatter -> level -> unit
val pp_full: Format.formatter -> level -> unit
val encoding : level Data_encoding.t
val root: Raw_level_repr.t -> level
val pp : Format.formatter -> level -> unit
val from_raw:
val pp_full : Format.formatter -> level -> unit
val root : Raw_level_repr.t -> level
val from_raw :
first_level:Raw_level_repr.t ->
blocks_per_cycle:int32 ->
blocks_per_voting_period:int32 ->
blocks_per_commitment:int32 ->
Raw_level_repr.t -> level
Raw_level_repr.t ->
level
val diff: level -> level -> int32
val diff : level -> level -> int32

54
vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml vendored
View File

@ -28,8 +28,11 @@ open Level_repr
let from_raw c ?offset l =
let l =
match offset with
| None -> l
| Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in
| None ->
l
| Some o ->
Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o))
in
let constants = Raw_context.constants c in
let first_level = Raw_context.first_level c in
Level_repr.from_raw
@ -39,27 +42,32 @@ let from_raw c ?offset l =
~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
l
let root c =
Level_repr.root (Raw_context.first_level c)
let root c = Level_repr.root (Raw_context.first_level c)
let succ c l = from_raw c (Raw_level_repr.succ l.level)
let pred c l =
match Raw_level_repr.pred l.Level_repr.level with
| None -> None
| Some l -> Some (from_raw c l)
| None ->
None
| Some l ->
Some (from_raw c l)
let current ctxt = Raw_context.current_level ctxt
let previous ctxt =
let l = current ctxt in
match pred ctxt l with
| None -> assert false (* We never validate the Genesis... *)
| Some p -> p
| None ->
assert false (* We never validate the Genesis... *)
| Some p ->
p
let first_level_in_cycle ctxt c =
let constants = Raw_context.constants ctxt in
let first_level = Raw_context.first_level ctxt in
from_raw ctxt
from_raw
ctxt
(Raw_level_repr.of_int32_exn
(Int32.add
(Raw_level_repr.to_int32 first_level)
@ -69,14 +77,15 @@ let first_level_in_cycle ctxt c =
let last_level_in_cycle ctxt c =
match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
| None -> assert false
| Some x -> x
| None ->
assert false
| Some x ->
x
let levels_in_cycle ctxt cycle =
let first = first_level_in_cycle ctxt cycle in
let rec loop n acc =
if Cycle_repr.(n.cycle = first.cycle)
then loop (succ ctxt n) (n :: acc)
if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
else acc
in
loop first []
@ -84,8 +93,7 @@ let levels_in_cycle ctxt cycle =
let levels_in_current_cycle ctxt ?(offset = 0l) () =
let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in
let cycle = Int32.add current_cycle offset in
if Compare.Int32.(cycle < 0l) then
[]
if Compare.Int32.(cycle < 0l) then []
else
let cycle = Cycle_repr.of_int32_exn cycle in
levels_in_cycle ctxt cycle
@ -93,20 +101,18 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () =
let levels_with_commitments_in_cycle ctxt c =
let first = first_level_in_cycle ctxt c in
let rec loop n acc =
if Cycle_repr.(n.cycle = first.cycle)
then
if n.expected_commitment then
loop (succ ctxt n) (n :: acc)
else
loop (succ ctxt n) acc
if Cycle_repr.(n.cycle = first.cycle) then
if n.expected_commitment then loop (succ ctxt n) (n :: acc)
else loop (succ ctxt n) acc
else acc
in
loop first []
let last_allowed_fork_level c =
let level = Raw_context.current_level c in
let preserved_cycles = Constants_storage.preserved_cycles c in
match Cycle_repr.sub level.cycle preserved_cycles with
| None -> Raw_level_repr.root
| Some cycle -> (first_level_in_cycle c cycle).level
| None ->
Raw_level_repr.root
| Some cycle ->
(first_level_in_cycle c cycle).level

31
vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli vendored
View File

@ -23,22 +23,29 @@
(* *)
(*****************************************************************************)
val current: Raw_context.t -> Level_repr.t
val previous: Raw_context.t -> Level_repr.t
val current : Raw_context.t -> Level_repr.t
val root: Raw_context.t -> Level_repr.t
val previous : Raw_context.t -> Level_repr.t
val from_raw: Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
val pred: Raw_context.t -> Level_repr.t -> Level_repr.t option
val succ: Raw_context.t -> Level_repr.t -> Level_repr.t
val root : Raw_context.t -> Level_repr.t
val first_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t
val last_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t
val levels_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t list
val levels_in_current_cycle:
val from_raw :
Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option
val succ : Raw_context.t -> Level_repr.t -> Level_repr.t
val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t
val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t
val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list
val levels_in_current_cycle :
Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list
val levels_with_commitments_in_cycle:
val levels_with_commitments_in_cycle :
Raw_context.t -> Cycle_repr.t -> Level_repr.t list
val last_allowed_fork_level: Raw_context.t -> Raw_level_repr.t
val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t

409
vendors/ligo-utils/tezos-protocol-alpha/main.ml vendored
View File

@ -26,51 +26,66 @@
(* Tezos Protocol Implementation - Protocol Signature Instance *)
type block_header_data = Alpha_context.Block_header.protocol_data
type block_header = Alpha_context.Block_header.t = {
shell: Block_header.shell_header ;
protocol_data: block_header_data ;
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
let block_header_data_encoding = Alpha_context.Block_header.protocol_data_encoding
let block_header_data_encoding =
Alpha_context.Block_header.protocol_data_encoding
type block_header_metadata = Apply_results.block_metadata
let block_header_metadata_encoding = Apply_results.block_metadata_encoding
type operation_data = Alpha_context.packed_protocol_data =
| Operation_data : 'kind Alpha_context.Operation.protocol_data -> operation_data
| Operation_data :
'kind Alpha_context.Operation.protocol_data
-> operation_data
let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding
type operation_receipt = Apply_results.packed_operation_metadata =
| Operation_metadata : 'kind Apply_results.operation_metadata -> operation_receipt
| No_operation_metadata: operation_receipt
let operation_receipt_encoding =
Apply_results.operation_metadata_encoding
| Operation_metadata :
'kind Apply_results.operation_metadata
-> operation_receipt
| No_operation_metadata : operation_receipt
let operation_receipt_encoding = Apply_results.operation_metadata_encoding
let operation_data_and_receipt_encoding =
Apply_results.operation_data_and_metadata_encoding
type operation = Alpha_context.packed_operation = {
shell: Operation.shell_header ;
protocol_data: operation_data ;
shell : Operation.shell_header;
protocol_data : operation_data;
}
let acceptable_passes = Alpha_context.Operation.acceptable_passes
let max_block_length =
Alpha_context.Block_header.max_header_length
let max_block_length = Alpha_context.Block_header.max_header_length
let max_operation_data_length =
Alpha_context.Constants.max_operation_data_length
let validation_passes =
let max_anonymous_operations =
Alpha_context.Constants.max_revelations_per_block +
(* allow 100 wallet activations or denunciations per block *) 100 in
Updater.[ { max_size = 32 * 1024 ; max_op = Some 32 } ; (* 32 endorsements *)
{ max_size = 32 * 1024 ; max_op = None } ; (* 32k of voting operations *)
{ max_size = max_anonymous_operations * 1024 ;
max_op = Some max_anonymous_operations } ;
{ max_size = 512 * 1024 ; max_op = None } ] (* 512kB *)
Alpha_context.Constants.max_revelations_per_block
+ (* allow 100 wallet activations or denunciations per block *) 100
in
Updater.
[ {max_size = 32 * 1024; max_op = Some 32};
(* 32 endorsements *)
{max_size = 32 * 1024; max_op = None};
(* 32k of voting operations *)
{
max_size = max_anonymous_operations * 1024;
max_op = Some max_anonymous_operations;
};
{max_size = 512 * 1024; max_op = None} ]
(* 512kB *)
let rpc_services =
Alpha_services.register () ;
@ -78,168 +93,186 @@ let rpc_services =
type validation_mode =
| Application of {
block_header : Alpha_context.Block_header.t ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_application of {
block_header : Alpha_context.Block_header.t ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
}
| Partial_construction of {
predecessor : Block_hash.t ;
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_construction of {predecessor : Block_hash.t}
| Full_construction of {
predecessor : Block_hash.t ;
protocol_data : Alpha_context.Block_header.contents ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
predecessor : Block_hash.t;
protocol_data : Alpha_context.Block_header.contents;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
type validation_state =
{ mode : validation_mode ;
chain_id : Chain_id.t ;
ctxt : Alpha_context.t ;
op_count : int ;
}
type validation_state = {
mode : validation_mode;
chain_id : Chain_id.t;
ctxt : Alpha_context.t;
op_count : int;
}
let current_context { ctxt ; _ } =
return (Alpha_context.finalize ctxt).context
let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context
let begin_partial_application
~chain_id
~ancestor_context:ctxt
~predecessor_timestamp
~predecessor_fitness
let begin_partial_application ~chain_id ~ancestor_context:ctxt
~predecessor_timestamp ~predecessor_fitness
(block_header : Alpha_context.Block_header.t) =
let level = block_header.shell.level in
let fitness = predecessor_fitness in
let timestamp = block_header.shell.timestamp in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
Apply.begin_application
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) ->
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
Apply.begin_application ctxt chain_id block_header predecessor_timestamp
>>=? fun (ctxt, baker, block_delay) ->
let mode =
Partial_application
{ block_header ; baker = Signature.Public_key.hash baker ; block_delay } in
return { mode ; chain_id ; ctxt ; op_count = 0 }
{block_header; baker = Signature.Public_key.hash baker; block_delay}
in
return {mode; chain_id; ctxt; op_count = 0}
let begin_application
~chain_id
~predecessor_context:ctxt
~predecessor_timestamp
~predecessor_fitness
let begin_application ~chain_id ~predecessor_context:ctxt
~predecessor_timestamp ~predecessor_fitness
(block_header : Alpha_context.Block_header.t) =
let level = block_header.shell.level in
let fitness = predecessor_fitness in
let timestamp = block_header.shell.timestamp in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
Apply.begin_application
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) ->
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
Apply.begin_application ctxt chain_id block_header predecessor_timestamp
>>=? fun (ctxt, baker, block_delay) ->
let mode =
Application { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in
return { mode ; chain_id ; ctxt ; op_count = 0 }
Application
{block_header; baker = Signature.Public_key.hash baker; block_delay}
in
return {mode; chain_id; ctxt; op_count = 0}
let begin_construction
~chain_id
~predecessor_context:ctxt
~predecessor_timestamp
~predecessor_level:pred_level
~predecessor_fitness:pred_fitness
~predecessor
~timestamp
?(protocol_data : block_header_data option)
() =
let begin_construction ~chain_id ~predecessor_context:ctxt
~predecessor_timestamp ~predecessor_level:pred_level
~predecessor_fitness:pred_fitness ~predecessor ~timestamp
?(protocol_data : block_header_data option) () =
let level = Int32.succ pred_level in
let fitness = pred_fitness in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
begin
match protocol_data with
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
( match protocol_data with
| None ->
Apply.begin_partial_construction ctxt >>=? fun ctxt ->
let mode = Partial_construction { predecessor } in
Apply.begin_partial_construction ctxt
>>=? fun ctxt ->
let mode = Partial_construction {predecessor} in
return (mode, ctxt)
| Some proto_header ->
Apply.begin_full_construction
ctxt predecessor_timestamp
proto_header.contents >>=? fun (ctxt, protocol_data, baker, block_delay) ->
ctxt
predecessor_timestamp
proto_header.contents
>>=? fun (ctxt, protocol_data, baker, block_delay) ->
let mode =
let baker = Signature.Public_key.hash baker in
Full_construction { predecessor ; baker ; protocol_data ; block_delay } in
return (mode, ctxt)
end >>=? fun (mode, ctxt) ->
return { mode ; chain_id ; ctxt ; op_count = 0 }
Full_construction {predecessor; baker; protocol_data; block_delay}
in
return (mode, ctxt) )
>>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0}
let apply_operation
({ mode ; chain_id ; ctxt ; op_count ; _ } as data)
let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
(operation : Alpha_context.packed_operation) =
match mode with
| Partial_application _ when
not (List.exists
| Partial_application _
when not
(List.exists
(Compare.Int.equal 0)
(Alpha_context.Operation.acceptable_passes operation)) ->
(* Multipass validation only considers operations in pass 0. *)
let op_count = op_count + 1 in
return ({ data with ctxt ; op_count }, No_operation_metadata)
return ({data with ctxt; op_count}, No_operation_metadata)
| _ ->
let { shell ; protocol_data = Operation_data protocol_data } = operation in
let operation : _ Alpha_context.operation = { shell ; protocol_data } in
let predecessor, baker =
let {shell; protocol_data = Operation_data protocol_data} = operation in
let operation : _ Alpha_context.operation = {shell; protocol_data} in
let (predecessor, baker) =
match mode with
| Partial_application
{ block_header = { shell = { predecessor ; _ } ; _ } ; baker }
| Application
{ block_header = { shell = { predecessor ; _ } ; _ } ; baker }
| Full_construction { predecessor ; baker ; _ }
-> predecessor, baker
| Partial_construction { predecessor }
-> predecessor, Signature.Public_key_hash.zero
{block_header = {shell = {predecessor; _}; _}; baker}
| Application {block_header = {shell = {predecessor; _}; _}; baker}
| Full_construction {predecessor; baker; _} ->
(predecessor, baker)
| Partial_construction {predecessor} ->
(predecessor, Signature.Public_key_hash.zero)
in
Apply.apply_operation ctxt chain_id Optimized predecessor baker
Apply.apply_operation
ctxt
chain_id
Optimized
predecessor
baker
(Alpha_context.Operation.hash operation)
operation >>=? fun (ctxt, result) ->
operation
>>=? fun (ctxt, result) ->
let op_count = op_count + 1 in
return ({ data with ctxt ; op_count }, Operation_metadata result)
return ({data with ctxt; op_count}, Operation_metadata result)
let finalize_block { mode ; ctxt ; op_count } =
let finalize_block {mode; ctxt; op_count} =
match mode with
| Partial_construction _ ->
let level = Alpha_context.Level.current ctxt in
Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind ->
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let baker = Signature.Public_key_hash.zero in
Signature.Public_key_hash.Map.fold
(fun delegate deposit ctxt ->
ctxt >>=? fun ctxt ->
ctxt
>>=? fun ctxt ->
Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
(Alpha_context.get_deposits ctxt)
(return ctxt) >>=? fun ctxt ->
(return ctxt)
>>=? fun ctxt ->
let ctxt = Alpha_context.finalize ctxt in
return (ctxt, Apply_results.{ baker ;
level ;
voting_period_kind ;
nonce_hash = None ;
consumed_gas = Z.zero ;
return
( ctxt,
Apply_results.
{
baker;
level;
voting_period_kind;
nonce_hash = None;
consumed_gas = Z.zero;
deactivated = [];
balance_updates = []})
| Partial_application { block_header ; baker ; block_delay } ->
balance_updates = [];
} )
| Partial_application {block_header; baker; block_delay} ->
let level = Alpha_context.Level.current ctxt in
let included_endorsements = Alpha_context.included_endorsements ctxt in
Apply.check_minimum_endorsements ctxt
Apply.check_minimum_endorsements
ctxt
block_header.protocol_data.contents
block_delay included_endorsements >>=? fun () ->
Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind ->
block_delay
included_endorsements
>>=? fun () ->
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let ctxt = Alpha_context.finalize ctxt in
return (ctxt, Apply_results.{ baker ;
level ;
voting_period_kind ;
nonce_hash = None ;
consumed_gas = Z.zero ;
return
( ctxt,
Apply_results.
{
baker;
level;
voting_period_kind;
nonce_hash = None;
consumed_gas = Z.zero;
deactivated = [];
balance_updates = []})
balance_updates = [];
} )
| Application
{ baker ; block_delay ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } }
| Full_construction { protocol_data ; baker ; block_delay ; _ } ->
Apply.finalize_application ctxt protocol_data baker ~block_delay >>=? fun (ctxt, receipt) ->
{ baker;
block_delay;
block_header = {protocol_data = {contents = protocol_data; _}; _} }
| Full_construction {protocol_data; baker; block_delay; _} ->
Apply.finalize_application ctxt protocol_data baker ~block_delay
>>=? fun (ctxt, receipt) ->
let level = Alpha_context.Level.current ctxt in
let priority = protocol_data.priority in
let raw_level = Alpha_context.Raw_level.to_int32 level.level in
@ -247,69 +280,101 @@ let finalize_block { mode ; ctxt ; op_count } =
let commit_message =
Format.asprintf
"lvl %ld, fit 1:%Ld, prio %d, %d ops"
raw_level fitness priority op_count in
raw_level
fitness
priority
op_count
in
let ctxt = Alpha_context.finalize ~commit_message ctxt in
return (ctxt, receipt)
let compare_operations op1 op2 =
let open Alpha_context in
let Operation_data op1 = op1.protocol_data in
let Operation_data op2 = op2.protocol_data in
match op1.contents, op2.contents with
| Single (Endorsement _), Single (Endorsement _) -> 0
| _, Single (Endorsement _) -> 1
| Single (Endorsement _), _ -> -1
| Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _) -> 0
| _, Single (Seed_nonce_revelation _) -> 1
| Single (Seed_nonce_revelation _), _ -> -1
| Single (Double_endorsement_evidence _), Single (Double_endorsement_evidence _) -> 0
| _, Single (Double_endorsement_evidence _) -> 1
| Single (Double_endorsement_evidence _), _ -> -1
| Single (Double_baking_evidence _), Single (Double_baking_evidence _) -> 0
| _, Single (Double_baking_evidence _) -> 1
| Single (Double_baking_evidence _), _ -> -1
| Single (Activate_account _), Single (Activate_account _) -> 0
| _, Single (Activate_account _) -> 1
| Single (Activate_account _), _ -> -1
| Single (Proposals _), Single (Proposals _) -> 0
| _, Single (Proposals _) -> 1
| Single (Proposals _), _ -> -1
| Single (Ballot _), Single (Ballot _) -> 0
| _, Single (Ballot _) -> 1
| Single (Ballot _), _ -> -1
let (Operation_data op1) = op1.protocol_data in
let (Operation_data op2) = op2.protocol_data in
match (op1.contents, op2.contents) with
| (Single (Endorsement _), Single (Endorsement _)) ->
0
| (_, Single (Endorsement _)) ->
1
| (Single (Endorsement _), _) ->
-1
| (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
0
| (_, Single (Seed_nonce_revelation _)) ->
1
| (Single (Seed_nonce_revelation _), _) ->
-1
| ( Single (Double_endorsement_evidence _),
Single (Double_endorsement_evidence _) ) ->
0
| (_, Single (Double_endorsement_evidence _)) ->
1
| (Single (Double_endorsement_evidence _), _) ->
-1
| (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
0
| (_, Single (Double_baking_evidence _)) ->
1
| (Single (Double_baking_evidence _), _) ->
-1
| (Single (Activate_account _), Single (Activate_account _)) ->
0
| (_, Single (Activate_account _)) ->
1
| (Single (Activate_account _), _) ->
-1
| (Single (Proposals _), Single (Proposals _)) ->
0
| (_, Single (Proposals _)) ->
1
| (Single (Proposals _), _) ->
-1
| (Single (Ballot _), Single (Ballot _)) ->
0
| (_, Single (Ballot _)) ->
1
| (Single (Ballot _), _) ->
-1
(* Manager operations with smaller counter are pre-validated first. *)
| Single (Manager_operation op1), Single (Manager_operation op2) ->
| (Single (Manager_operation op1), Single (Manager_operation op2)) ->
Z.compare op1.counter op2.counter
| Cons (Manager_operation op1, _), Single (Manager_operation op2) ->
| (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
Z.compare op1.counter op2.counter
| Single (Manager_operation op1), Cons (Manager_operation op2, _) ->
| (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
Z.compare op1.counter op2.counter
| Cons (Manager_operation op1, _), Cons (Manager_operation op2, _) ->
| (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
Z.compare op1.counter op2.counter
let init ctxt block_header =
let level = block_header.Block_header.level in
let fitness = block_header.fitness in
let timestamp = block_header.timestamp in
let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) =
Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage
~to_duplicate: Script_ir_translator.no_big_map_id
~to_update: Script_ir_translator.no_big_map_id
~temporary:false >>=? fun (storage, big_map_diff, ctxt) ->
Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) ->
let storage = Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) in
return (({ script with storage }, big_map_diff), ctxt)
let typecheck (ctxt : Alpha_context.context)
(script : Alpha_context.Script.t) =
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.extract_big_map_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate:Script_ir_translator.no_big_map_id
~to_update:Script_ir_translator.no_big_map_id
~temporary:false
>>=? fun (storage, big_map_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
parsed_script.storage_type
storage
>>=? fun (storage, ctxt) ->
let storage =
Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
in
Alpha_context.prepare_first_block
~typecheck
~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
return (Alpha_context.finalize ctxt)
(* Vanity nonce: 415767323 *)
return (({script with storage}, big_map_diff), ctxt)
in
Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
>>=? fun ctxt -> return (Alpha_context.finalize ctxt)
(* Vanity nonce: 0050006865723388 *)

43
vendors/ligo-utils/tezos-protocol-alpha/main.mli vendored
View File

@ -27,40 +27,39 @@
type validation_mode =
| Application of {
block_header : Alpha_context.Block_header.t ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_application of {
block_header : Alpha_context.Block_header.t ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
}
| Partial_construction of {
predecessor : Block_hash.t ;
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_construction of {predecessor : Block_hash.t}
| Full_construction of {
predecessor : Block_hash.t ;
protocol_data : Alpha_context.Block_header.contents ;
baker : Alpha_context.public_key_hash ;
block_delay : Alpha_context.Period.t ;
predecessor : Block_hash.t;
protocol_data : Alpha_context.Block_header.contents;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
type validation_state =
{ mode : validation_mode ;
chain_id : Chain_id.t ;
ctxt : Alpha_context.t ;
op_count : int ;
}
type validation_state = {
mode : validation_mode;
chain_id : Chain_id.t;
ctxt : Alpha_context.t;
op_count : int;
}
type operation_data = Alpha_context.packed_protocol_data
type operation = Alpha_context.packed_operation = {
shell: Operation.shell_header ;
protocol_data: operation_data ;
shell : Operation.shell_header;
protocol_data : operation_data;
}
include Updater.PROTOCOL
include
Updater.PROTOCOL
with type block_header_data = Alpha_context.Block_header.protocol_data
and type block_header_metadata = Apply_results.block_metadata
and type block_header = Alpha_context.Block_header.t

22
vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml vendored
View File

@ -34,27 +34,19 @@ type t = manager_key
open Data_encoding
let hash_case tag =
case tag
case
tag
~title:"Public_key_hash"
Signature.Public_key_hash.encoding
(function
| Hash hash -> Some hash
| _ -> None)
(function Hash hash -> Some hash | _ -> None)
(fun hash -> Hash hash)
let pubkey_case tag =
case tag
case
tag
~title:"Public_key"
Signature.Public_key.encoding
(function
| Public_key hash -> Some hash
| _ -> None)
(function Public_key hash -> Some hash | _ -> None)
(fun hash -> Public_key hash)
let encoding =
union [
hash_case (Tag 0) ;
pubkey_case (Tag 1) ;
]
let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]

679
vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml vendored
View File

@ -27,93 +27,108 @@ open Alpha_context
open Gas
module Cost_of = struct
let log2 =
let rec help acc = function
| 0 -> acc
| n -> help (acc + 1) (n / 2)
in help 1
let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in
help 1
let z_bytes (z : Z.t) =
let bits = Z.numbits z in
(7 + bits) / 8
let int_bytes (z : 'a Script_int.num) =
z_bytes (Script_int.to_zint z)
let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)
let timestamp_bytes (t : Script_timestamp.t) =
let z = Script_timestamp.to_zint t in
z_bytes z
(* For now, returns size in bytes, but this could get more complicated... *)
let rec size_of_comparable : type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
let rec size_of_comparable :
type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
fun wit v ->
match wit with
| Int_key _ -> int_bytes v
| Nat_key _ -> int_bytes v
| String_key _ -> String.length v
| Bytes_key _ -> MBytes.length v
| Bool_key _ -> 8
| Key_hash_key _ -> Signature.Public_key_hash.size
| Timestamp_key _ -> timestamp_bytes v
| Address_key _ -> Signature.Public_key_hash.size
| Mutez_key _ -> 8
| Int_key _ ->
int_bytes v
| Nat_key _ ->
int_bytes v
| String_key _ ->
String.length v
| Bytes_key _ ->
MBytes.length v
| Bool_key _ ->
8
| Key_hash_key _ ->
Signature.Public_key_hash.size
| Timestamp_key _ ->
timestamp_bytes v
| Address_key _ ->
Signature.Public_key_hash.size
| Mutez_key _ ->
8
| Pair_key ((l, _), (r, _), _) ->
let (lval, rval) = v in
size_of_comparable l lval + size_of_comparable r rval
let string length =
alloc_bytes_cost length
let string length = alloc_bytes_cost length
let bytes length =
alloc_mbytes_cost length
let bytes length = alloc_mbytes_cost length
let manager_operation = step_cost 10_000
module Legacy = struct
let zint z =
alloc_bits_cost (Z.numbits z)
let zint z = alloc_bits_cost (Z.numbits z)
let set_to_list : type item. item Script_typed_ir.set -> cost
= fun (module Box) ->
alloc_cost @@ Pervasives.(Box.size * 2)
let set_to_list : type item. item Script_typed_ir.set -> cost =
fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2)
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
= fun (module Box) ->
=
fun (module Box) ->
let size = snd Box.boxed in
3 *@ alloc_cost size
let z_to_int64 = step_cost 2 +@ alloc_cost 1
let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len
let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
= fun _key (module Box) ->
log2 @@ Box.size
let set_access : type elt. elt -> elt Script_typed_ir.set -> int =
fun _key (module Box) -> log2 @@ Box.size
let set_update key _presence set =
set_access key set *@ alloc_cost 3
let set_update key _presence set = set_access key set *@ alloc_cost 3
end
module Interpreter = struct
let cycle = atomic_step_cost 10
let nop = free
let stack_op = atomic_step_cost 10
let push = atomic_step_cost 10
let wrap = atomic_step_cost 10
let variant_no_data = atomic_step_cost 10
let branch = atomic_step_cost 10
let pair = atomic_step_cost 10
let pair_access = atomic_step_cost 10
let cons = atomic_step_cost 10
let loop_size = atomic_step_cost 5
let loop_cycle = atomic_step_cost 10
let loop_iter = atomic_step_cost 20
let loop_map = atomic_step_cost 30
let empty_set = atomic_step_cost 10
let set_to_list : type elt. elt Script_typed_ir.set -> cost =
fun (module Box) ->
atomic_step_cost (Box.size * 20)
fun (module Box) -> atomic_step_cost (Box.size * 20)
let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
fun elt (module Box) ->
@ -126,23 +141,30 @@ module Cost_of = struct
atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)
let set_size = atomic_step_cost 10
let empty_map = atomic_step_cost 10
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost =
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
=
fun (module Box) ->
let size = snd Box.boxed in
atomic_step_cost (size * 20)
let map_access : type key value. key -> (key, value) Script_typed_ir.map -> cost
= fun key (module Box) ->
let map_access :
type key value. key -> (key, value) Script_typed_ir.map -> cost =
fun key (module Box) ->
let map_card = snd Box.boxed in
let key_bytes = size_of_comparable Box.key_ty key in
atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)
let map_mem = map_access
let map_get = map_access
let map_update : type key value. key -> value option -> (key, value) Script_typed_ir.map -> cost
= fun key _value (module Box) ->
let map_update :
type key value.
key -> value option -> (key, value) Script_typed_ir.map -> cost =
fun key _value (module Box) ->
let map_card = snd Box.boxed in
let key_bytes = size_of_comparable Box.key_ty key in
atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)
@ -153,16 +175,16 @@ module Cost_of = struct
let bytes1 = timestamp_bytes t1 in
let bytes2 = int_bytes t2 in
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
let sub_timestamp = add_timestamp
let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
let bytes1 = timestamp_bytes t1 in
let bytes2 = timestamp_bytes t2 in
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
let rec concat_loop l acc =
match l with
| [] -> 30
| _ :: tl -> concat_loop tl (acc + 30)
match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30)
let concat_string string_list =
atomic_step_cost (concat_loop string_list 0)
@ -170,19 +192,28 @@ module Cost_of = struct
let slice_string string_length =
atomic_step_cost (40 + (string_length / 70))
let concat_bytes bytes_list =
atomic_step_cost (concat_loop bytes_list 0)
let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0)
let int64_op = atomic_step_cost 61
let z_to_int64 = atomic_step_cost 20
let int64_to_z = atomic_step_cost 20
let bool_binop _ _ = atomic_step_cost 10
let bool_unop _ = atomic_step_cost 10
let abs int = atomic_step_cost (61 + ((int_bytes int) / 70))
let abs int = atomic_step_cost (61 + (int_bytes int / 70))
let int _int = free
let neg = abs
let add i1 i2 = atomic_step_cost (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))
let add i1 i2 =
atomic_step_cost
(51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))
let sub = add
let mul i1 i2 =
@ -198,303 +229,537 @@ module Cost_of = struct
atomic_step_cost (51 + (cost / 3151))
let shift_left _i _shift_bits = atomic_step_cost 30
let shift_right _i _shift_bits = atomic_step_cost 30
let logor i1 i2 =
let bytes1 = int_bytes i1 in
let bytes2 = int_bytes i2 in
atomic_step_cost (51 + ((Compare.Int.max bytes1 bytes2) / 70))
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70))
let logand i1 i2 =
let bytes1 = int_bytes i1 in
let bytes2 = int_bytes i2 in
atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 70))
atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70))
let logxor = logor
let lognot i = atomic_step_cost (51 + ((int_bytes i) / 20))
let lognot i = atomic_step_cost (51 + (int_bytes i / 20))
let exec = atomic_step_cost 10
let compare_bool _ _ = atomic_step_cost 30
let compare_string s1 s2 =
let bytes1 = String.length s1 in
let bytes2 = String.length s2 in
atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123))
atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))
let compare_bytes b1 b2 =
let bytes1 = MBytes.length b1 in
let bytes2 = MBytes.length b2 in
atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123))
atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))
let compare_tez _ _ = atomic_step_cost 30
let compare_zint i1 i2 =
atomic_step_cost (51 + ((Compare.Int.min (int_bytes i1) (int_bytes i2)) / 82))
atomic_step_cost
(51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82))
let compare_key_hash _ _ = atomic_step_cost 92
let compare_timestamp t1 t2 =
let bytes1 = timestamp_bytes t1 in
let bytes2 = timestamp_bytes t2 in
atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 82))
atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82))
let compare_address _ _ = atomic_step_cost 92
let compare_res = atomic_step_cost 30
let unpack_failed bytes =
(* We cannot instrument failed deserialization,
so we take worst case fees: a set of size 1 bytes values. *)
let len = MBytes.length bytes in
(len *@ alloc_mbytes_cost 1) +@
(len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))
(len *@ alloc_mbytes_cost 1)
+@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))
let address = atomic_step_cost 10
let contract = step_cost 10000
let transfer = step_cost 10
let create_account = step_cost 10
let create_contract = step_cost 10
let implicit_account = step_cost 10
let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)
let balance = atomic_step_cost 10
let now = atomic_step_cost 10
let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))
let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))
let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))
let check_signature (pkey : Signature.public_key) bytes =
match pkey with
| Ed25519 _ -> check_signature_ed25519 (MBytes.length bytes)
| Secp256k1 _ -> check_signature_secp256k1 (MBytes.length bytes)
| P256 _ -> check_signature_p256 (MBytes.length bytes)
| Ed25519 _ ->
check_signature_ed25519 (MBytes.length bytes)
| Secp256k1 _ ->
check_signature_secp256k1 (MBytes.length bytes)
| P256 _ ->
check_signature_p256 (MBytes.length bytes)
let hash_key = atomic_step_cost 30
let hash_blake2b b = atomic_step_cost (102 + ((MBytes.length b) / 5))
let hash_sha256 b = atomic_step_cost (409 + (MBytes.length b))
let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5))
let hash_sha256 b = atomic_step_cost (409 + MBytes.length b)
let hash_sha512 b =
let bytes = MBytes.length b in atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))
let bytes = MBytes.length b in
atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))
let steps_to_quota = atomic_step_cost 10
let source = atomic_step_cost 10
let self = atomic_step_cost 10
let amount = atomic_step_cost 10
let chain_id = step_cost 1
let stack_n_op n = atomic_step_cost (20 + (((n lsr 1) + (n lsr 2)) + (n lsr 4)))
let stack_n_op n =
atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4)))
let apply = alloc_cost 8 +@ step_cost 1
let rec compare : type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = fun ty x y ->
let rec compare :
type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost =
fun ty x y ->
match ty with
| Bool_key _ -> compare_bool x y
| String_key _ -> compare_string x y
| Bytes_key _ -> compare_bytes x y
| Mutez_key _ -> compare_tez x y
| Int_key _ -> compare_zint x y
| Nat_key _ -> compare_zint x y
| Key_hash_key _ -> compare_key_hash x y
| Timestamp_key _ -> compare_timestamp x y
| Address_key _ -> compare_address x y
| Bool_key _ ->
compare_bool x y
| String_key _ ->
compare_string x y
| Bytes_key _ ->
compare_bytes x y
| Mutez_key _ ->
compare_tez x y
| Int_key _ ->
compare_zint x y
| Nat_key _ ->
compare_zint x y
| Key_hash_key _ ->
compare_key_hash x y
| Timestamp_key _ ->
compare_timestamp x y
| Address_key _ ->
compare_address x y
| Pair_key ((tl, _), (tr, _), _) ->
(* Reasonable over-approximation of the cost of lexicographic comparison. *)
let (xl, xr) = x and (yl, yr) = y in
compare tl xl yl +@ compare tr xr yr
end
module Typechecking = struct
let cycle = step_cost 1
let bool = free
let unit = free
let string = string
let bytes = bytes
let z = Legacy.zint
let int_of_string str =
alloc_cost @@ (Pervasives.(/) (String.length str) 5)
alloc_cost @@ Pervasives.( / ) (String.length str) 5
let tez = step_cost 1 +@ alloc_cost 1
let string_timestamp = step_cost 3 +@ alloc_cost 3
let key = step_cost 3 +@ alloc_cost 3
let key_hash = step_cost 1 +@ alloc_cost 1
let signature = step_cost 1 +@ alloc_cost 1
let chain_id = step_cost 1 +@ alloc_cost 1
let contract = step_cost 5
let get_script = step_cost 20 +@ alloc_cost 5
let contract_exists = step_cost 15 +@ alloc_cost 5
let pair = alloc_cost 2
let union = alloc_cost 1
let lambda = alloc_cost 5 +@ step_cost 3
let some = alloc_cost 1
let none = alloc_cost 0
let list_element = alloc_cost 2 +@ step_cost 1
let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2)
let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2)
let primitive_type = alloc_cost 1
let one_arg_type = alloc_cost 2
let two_arg_type = alloc_cost 3
let operation b = bytes b
let type_ nb_args = alloc_cost (nb_args + 1)
(* Cost of parsing instruction, is cost of allocation of
constructor + cost of contructor parameters + cost of
allocation on the stack type *)
let instr
: type b a. (b, a) Script_typed_ir.instr -> cost
= fun i ->
let instr : type b a. (b, a) Script_typed_ir.instr -> cost =
fun i ->
let open Script_typed_ir in
alloc_cost 1 +@ (* cost of allocation of constructor *)
alloc_cost 1
+@
(* cost of allocation of constructor *)
match i with
| Drop -> alloc_cost 0
| Dup -> alloc_cost 1
| Swap -> alloc_cost 0
| Const _ -> alloc_cost 1
| Cons_pair -> alloc_cost 2
| Car -> alloc_cost 1
| Cdr -> alloc_cost 1
| Cons_some -> alloc_cost 2
| Cons_none _ -> alloc_cost 3
| If_none _ -> alloc_cost 2
| Left -> alloc_cost 3
| Right -> alloc_cost 3
| If_left _ -> alloc_cost 2
| Cons_list -> alloc_cost 1
| Nil -> alloc_cost 1
| If_cons _ -> alloc_cost 2
| List_map _ -> alloc_cost 5
| List_iter _ -> alloc_cost 4
| List_size -> alloc_cost 1
| Empty_set _ -> alloc_cost 1
| Set_iter _ -> alloc_cost 4
| Set_mem -> alloc_cost 1
| Set_update -> alloc_cost 1
| Set_size -> alloc_cost 1
| Empty_map _ -> alloc_cost 2
| Map_map _ -> alloc_cost 5
| Map_iter _ -> alloc_cost 4
| Map_mem -> alloc_cost 1
| Map_get -> alloc_cost 1
| Map_update -> alloc_cost 1
| Map_size -> alloc_cost 1
| Empty_big_map _ -> alloc_cost 2
| Big_map_mem -> alloc_cost 1
| Big_map_get -> alloc_cost 1
| Big_map_update -> alloc_cost 1
| Concat_string -> alloc_cost 1
| Concat_string_pair -> alloc_cost 1
| Concat_bytes -> alloc_cost 1
| Concat_bytes_pair -> alloc_cost 1
| Slice_string -> alloc_cost 1
| Slice_bytes -> alloc_cost 1
| String_size -> alloc_cost 1
| Bytes_size -> alloc_cost 1
| Add_seconds_to_timestamp -> alloc_cost 1
| Add_timestamp_to_seconds -> alloc_cost 1
| Sub_timestamp_seconds -> alloc_cost 1
| Diff_timestamps -> alloc_cost 1
| Add_tez -> alloc_cost 1
| Sub_tez -> alloc_cost 1
| Mul_teznat -> alloc_cost 1
| Mul_nattez -> alloc_cost 1
| Ediv_teznat -> alloc_cost 1
| Ediv_tez -> alloc_cost 1
| Or -> alloc_cost 1
| And -> alloc_cost 1
| Xor -> alloc_cost 1
| Not -> alloc_cost 1
| Is_nat -> alloc_cost 1
| Neg_nat -> alloc_cost 1
| Neg_int -> alloc_cost 1
| Abs_int -> alloc_cost 1
| Int_nat -> alloc_cost 1
| Add_intint -> alloc_cost 1
| Add_intnat -> alloc_cost 1
| Add_natint -> alloc_cost 1
| Add_natnat -> alloc_cost 1
| Sub_int -> alloc_cost 1
| Mul_intint -> alloc_cost 1
| Mul_intnat -> alloc_cost 1
| Mul_natint -> alloc_cost 1
| Mul_natnat -> alloc_cost 1
| Ediv_intint -> alloc_cost 1
| Ediv_intnat -> alloc_cost 1
| Ediv_natint -> alloc_cost 1
| Ediv_natnat -> alloc_cost 1
| Lsl_nat -> alloc_cost 1
| Lsr_nat -> alloc_cost 1
| Or_nat -> alloc_cost 1
| And_nat -> alloc_cost 1
| And_int_nat -> alloc_cost 1
| Xor_nat -> alloc_cost 1
| Not_nat -> alloc_cost 1
| Not_int -> alloc_cost 1
| Seq _ -> alloc_cost 8
| If _ -> alloc_cost 8
| Loop _ -> alloc_cost 4
| Loop_left _ -> alloc_cost 5
| Dip _ -> alloc_cost 4
| Exec -> alloc_cost 1
| Apply _ -> alloc_cost 1
| Lambda _ -> alloc_cost 2
| Failwith _ -> alloc_cost 1
| Nop -> alloc_cost 0
| Compare _ -> alloc_cost 1
| Eq -> alloc_cost 1
| Neq -> alloc_cost 1
| Lt -> alloc_cost 1
| Gt -> alloc_cost 1
| Le -> alloc_cost 1
| Ge -> alloc_cost 1
| Address -> alloc_cost 1
| Contract _ -> alloc_cost 2
| Transfer_tokens -> alloc_cost 1
| Create_account -> alloc_cost 2
| Implicit_account -> alloc_cost 1
| Create_contract _ -> alloc_cost 8
| Drop ->
alloc_cost 0
| Dup ->
alloc_cost 1
| Swap ->
alloc_cost 0
| Const _ ->
alloc_cost 1
| Cons_pair ->
alloc_cost 2
| Car ->
alloc_cost 1
| Cdr ->
alloc_cost 1
| Cons_some ->
alloc_cost 2
| Cons_none _ ->
alloc_cost 3
| If_none _ ->
alloc_cost 2
| Left ->
alloc_cost 3
| Right ->
alloc_cost 3
| If_left _ ->
alloc_cost 2
| Cons_list ->
alloc_cost 1
| Nil ->
alloc_cost 1
| If_cons _ ->
alloc_cost 2
| List_map _ ->
alloc_cost 5
| List_iter _ ->
alloc_cost 4
| List_size ->
alloc_cost 1
| Empty_set _ ->
alloc_cost 1
| Set_iter _ ->
alloc_cost 4
| Set_mem ->
alloc_cost 1
| Set_update ->
alloc_cost 1
| Set_size ->
alloc_cost 1
| Empty_map _ ->
alloc_cost 2
| Map_map _ ->
alloc_cost 5
| Map_iter _ ->
alloc_cost 4
| Map_mem ->
alloc_cost 1
| Map_get ->
alloc_cost 1
| Map_update ->
alloc_cost 1
| Map_size ->
alloc_cost 1
| Empty_big_map _ ->
alloc_cost 2
| Big_map_mem ->
alloc_cost 1
| Big_map_get ->
alloc_cost 1
| Big_map_update ->
alloc_cost 1
| Concat_string ->
alloc_cost 1
| Concat_string_pair ->
alloc_cost 1
| Concat_bytes ->
alloc_cost 1
| Concat_bytes_pair ->
alloc_cost 1
| Slice_string ->
alloc_cost 1
| Slice_bytes ->
alloc_cost 1
| String_size ->
alloc_cost 1
| Bytes_size ->
alloc_cost 1
| Add_seconds_to_timestamp ->
alloc_cost 1
| Add_timestamp_to_seconds ->
alloc_cost 1
| Sub_timestamp_seconds ->
alloc_cost 1
| Diff_timestamps ->
alloc_cost 1
| Add_tez ->
alloc_cost 1
| Sub_tez ->
alloc_cost 1
| Mul_teznat ->
alloc_cost 1
| Mul_nattez ->
alloc_cost 1
| Ediv_teznat ->
alloc_cost 1
| Ediv_tez ->
alloc_cost 1
| Or ->
alloc_cost 1
| And ->
alloc_cost 1
| Xor ->
alloc_cost 1
| Not ->
alloc_cost 1
| Is_nat ->
alloc_cost 1
| Neg_nat ->
alloc_cost 1
| Neg_int ->
alloc_cost 1
| Abs_int ->
alloc_cost 1
| Int_nat ->
alloc_cost 1
| Add_intint ->
alloc_cost 1
| Add_intnat ->
alloc_cost 1
| Add_natint ->
alloc_cost 1
| Add_natnat ->
alloc_cost 1
| Sub_int ->
alloc_cost 1
| Mul_intint ->
alloc_cost 1
| Mul_intnat ->
alloc_cost 1
| Mul_natint ->
alloc_cost 1
| Mul_natnat ->
alloc_cost 1
| Ediv_intint ->
alloc_cost 1
| Ediv_intnat ->
alloc_cost 1
| Ediv_natint ->
alloc_cost 1
| Ediv_natnat ->
alloc_cost 1
| Lsl_nat ->
alloc_cost 1
| Lsr_nat ->
alloc_cost 1
| Or_nat ->
alloc_cost 1
| And_nat ->
alloc_cost 1
| And_int_nat ->
alloc_cost 1
| Xor_nat ->
alloc_cost 1
| Not_nat ->
alloc_cost 1
| Not_int ->
alloc_cost 1
| Seq _ ->
alloc_cost 8
| If _ ->
alloc_cost 8
| Loop _ ->
alloc_cost 4
| Loop_left _ ->
alloc_cost 5
| Dip _ ->
alloc_cost 4
| Exec ->
alloc_cost 1
| Apply _ ->
alloc_cost 1
| Lambda _ ->
alloc_cost 2
| Failwith _ ->
alloc_cost 1
| Nop ->
alloc_cost 0
| Compare _ ->
alloc_cost 1
| Eq ->
alloc_cost 1
| Neq ->
alloc_cost 1
| Lt ->
alloc_cost 1
| Gt ->
alloc_cost 1
| Le ->
alloc_cost 1
| Ge ->
alloc_cost 1
| Address ->
alloc_cost 1
| Contract _ ->
alloc_cost 2
| Transfer_tokens ->
alloc_cost 1
| Create_account ->
alloc_cost 2
| Implicit_account ->
alloc_cost 1
| Create_contract _ ->
alloc_cost 8
(* Deducted the cost of removed arguments manager, spendable and delegatable:
- manager: key_hash = 1
- spendable: bool = 0
- delegatable: bool = 0
*)
| Create_contract_2 _ -> alloc_cost 7
| Set_delegate -> alloc_cost 1
| Now -> alloc_cost 1
| Balance -> alloc_cost 1
| Check_signature -> alloc_cost 1
| Hash_key -> alloc_cost 1
| Pack _ -> alloc_cost 2
| Unpack _ -> alloc_cost 2
| Blake2b -> alloc_cost 1
| Sha256 -> alloc_cost 1
| Sha512 -> alloc_cost 1
| Steps_to_quota -> alloc_cost 1
| Source -> alloc_cost 1
| Sender -> alloc_cost 1
| Self _ -> alloc_cost 2
| Amount -> alloc_cost 1
| Dig (n,_) -> n *@ alloc_cost 1 (* _ is a unary development of n *)
| Dug (n,_) -> n *@ alloc_cost 1
| Dipn (n,_,_) -> n *@ alloc_cost 1
| Dropn (n,_) -> n *@ alloc_cost 1
| ChainId -> alloc_cost 1
| Create_contract_2 _ ->
alloc_cost 7
| Set_delegate ->
alloc_cost 1
| Now ->
alloc_cost 1
| Balance ->
alloc_cost 1
| Check_signature ->
alloc_cost 1
| Hash_key ->
alloc_cost 1
| Pack _ ->
alloc_cost 2
| Unpack _ ->
alloc_cost 2
| Blake2b ->
alloc_cost 1
| Sha256 ->
alloc_cost 1
| Sha512 ->
alloc_cost 1
| Steps_to_quota ->
alloc_cost 1
| Source ->
alloc_cost 1
| Sender ->
alloc_cost 1
| Self _ ->
alloc_cost 2
| Amount ->
alloc_cost 1
| Dig (n, _) ->
n *@ alloc_cost 1 (* _ is a unary development of n *)
| Dug (n, _) ->
n *@ alloc_cost 1
| Dipn (n, _, _) ->
n *@ alloc_cost 1
| Dropn (n, _) ->
n *@ alloc_cost 1
| ChainId ->
alloc_cost 1
end
module Unparse = struct
let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot
let seq_cost = Script.seq_node_cost_nonrec_of_length
let string_cost length = Script.string_node_cost_of_length length
let cycle = step_cost 1
let bool = prim_cost 0 []
let unit = prim_cost 0 []
(* We count the length of strings and bytes to prevent hidden
miscalculations due to non detectable expansion of sharing. *)
let string s = Script.string_node_cost s
let bytes s = Script.bytes_node_cost s
let z i = Script.int_node_cost i
let int i = Script.int_node_cost (Script_int.to_zint i)
let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)
let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int
let operation bytes = Script.bytes_node_cost bytes
let chain_id bytes = Script.bytes_node_cost bytes
let key = string_cost 54
let key_hash = string_cost 36
let signature = string_cost 128
let contract = string_cost 36
let pair = prim_cost 2 []
let union = prim_cost 1 []
let some = prim_cost 1 []
let none = prim_cost 0 []
let list_element = alloc_cost 2
let set_element = alloc_cost 2
let map_element = alloc_cost 2
let one_arg_type = prim_cost 1
let two_arg_type = prim_cost 2
let set_to_list = Legacy.set_to_list
let map_to_list = Legacy.map_to_list
end
end

121
vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli vendored
View File

@ -26,107 +26,194 @@
open Alpha_context
module Cost_of : sig
val manager_operation : Gas.cost
module Legacy : sig
val z_to_int64 : Gas.cost
val hash : MBytes.t -> int -> Gas.cost
val map_to_list :
('b, 'c) Script_typed_ir.map -> Gas.cost
val map_to_list : ('b, 'c) Script_typed_ir.map -> Gas.cost
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
end
module Interpreter : sig
val cycle : Gas.cost
val loop_cycle : Gas.cost
val loop_size : Gas.cost
val loop_iter : Gas.cost
val loop_map : Gas.cost
val nop : Gas.cost
val stack_op : Gas.cost
val stack_n_op : int -> Gas.cost
val bool_binop : 'a -> 'b -> Gas.cost
val bool_unop : 'a -> Gas.cost
val pair : Gas.cost
val pair_access : Gas.cost
val cons : Gas.cost
val variant_no_data : Gas.cost
val branch : Gas.cost
val concat_string : string list -> Gas.cost
val concat_bytes : MBytes.t list -> Gas.cost
val slice_string : int -> Gas.cost
val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost
val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost
val map_update : 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost
val map_update :
'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost
val map_size : Gas.cost
val set_to_list : 'a Script_typed_ir.set -> Gas.cost
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost
val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val abs : 'a Script_int.num -> Gas.cost
val neg : 'a Script_int.num -> Gas.cost
val int : 'a -> Gas.cost
val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost
val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost
val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost
val empty_set : Gas.cost
val set_size : Gas.cost
val empty_map : Gas.cost
val int64_op : Gas.cost
val z_to_int64 : Gas.cost
val int64_to_z : Gas.cost
val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val lognot : 'a Script_int.num -> Gas.cost
val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val exec : Gas.cost
val push : Gas.cost
val compare_res : Gas.cost
val unpack_failed : MBytes.t -> Gas.cost
val address : Gas.cost
val contract : Gas.cost
val transfer : Gas.cost
val create_account : Gas.cost
val create_contract : Gas.cost
val implicit_account : Gas.cost
val set_delegate : Gas.cost
val balance : Gas.cost
val now : Gas.cost
val check_signature : public_key -> MBytes.t -> Gas.cost
val hash_key : Gas.cost
val hash_blake2b : MBytes.t -> Gas.cost
val hash_sha256 : MBytes.t -> Gas.cost
val hash_sha512 : MBytes.t -> Gas.cost
val steps_to_quota : Gas.cost
val source : Gas.cost
val self : Gas.cost
val amount : Gas.cost
val chain_id : Gas.cost
val wrap : Gas.cost
val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost
val apply : Gas.cost
end
module Typechecking : sig
val cycle : Gas.cost
val unit : Gas.cost
val bool : Gas.cost
val tez : Gas.cost
val z : Z.t -> Gas.cost
val string : int -> Gas.cost
val bytes : int -> Gas.cost
val int_of_string : string -> Gas.cost
val string_timestamp : Gas.cost
val key : Gas.cost
val key_hash : Gas.cost
val signature : Gas.cost
val chain_id : Gas.cost
val contract : Gas.cost
@ -144,14 +231,19 @@ module Cost_of : sig
val lambda : Gas.cost
val some : Gas.cost
val none : Gas.cost
val list_element : Gas.cost
val set_element : int -> Gas.cost
val map_element : int -> Gas.cost
val primitive_type : Gas.cost
val one_arg_type : Gas.cost
val two_arg_type : Gas.cost
val operation : int -> Gas.cost
@ -165,20 +257,35 @@ module Cost_of : sig
module Unparse : sig
val prim_cost : int -> Script.annot -> Gas.cost
val seq_cost : int -> Gas.cost
val cycle : Gas.cost
val unit : Gas.cost
val bool : Gas.cost
val z : Z.t -> Gas.cost
val int : 'a Script_int.num -> Gas.cost
val tez : Gas.cost
val string : string -> Gas.cost
val bytes : MBytes.t -> Gas.cost
val timestamp : Script_timestamp.t -> Gas.cost
val key : Gas.cost
val key_hash : Gas.cost
val signature : Gas.cost
val operation : MBytes.t -> Gas.cost
val chain_id : MBytes.t -> Gas.cost
val contract : Gas.cost
@ -189,15 +296,21 @@ module Cost_of : sig
val union : Gas.cost
val some : Gas.cost
val none : Gas.cost
val list_element : Gas.cost
val set_element : Gas.cost
val map_element : Gas.cost
val one_arg_type : Script.annot -> Gas.cost
val two_arg_type : Script.annot -> Gas.cost
val set_to_list : 'a Script_typed_ir.set -> Gas.cost
val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
end
end

1061
vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml vendored
View File

File diff suppressed because it is too large Load Diff

11
vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli vendored
View File

@ -24,8 +24,14 @@
(*****************************************************************************)
type error += Unknown_primitive_name of string (* `Permanent *)
type error += Invalid_case of string (* `Permanent *)
type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *)
type error +=
| Invalid_primitive_name of
string Micheline.canonical * Micheline.canonical_location
(* `Permanent *)
type prim =
| K_parameter
@ -153,6 +159,7 @@ val string_of_prim : prim -> string
val prim_of_string : string -> prim tzresult
val prims_of_strings : string Micheline.canonical -> prim Micheline.canonical tzresult
val prims_of_strings :
string Micheline.canonical -> prim Micheline.canonical tzresult
val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical

79
vendors/ligo-utils/tezos-protocol-alpha/misc.ml vendored
View File

@ -24,61 +24,56 @@
(*****************************************************************************)
type 'a lazyt = unit -> 'a
type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt)
type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt
type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t
let rec (-->) i j = (* [i; i+1; ...; j] *)
if Compare.Int.(i > j)
then []
else i :: (succ i --> j)
let rec ( --> ) i j =
(* [i; i+1; ...; j] *)
if Compare.Int.(i > j) then [] else i :: (succ i --> j)
let rec (--->) i j = (* [i; i+1; ...; j] *)
if Compare.Int32.(i > j)
then []
else i :: (Int32.succ i ---> j)
let rec ( ---> ) i j =
(* [i; i+1; ...; j] *)
if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)
let split delim ?(limit = max_int) path =
let l = String.length path in
let rec do_slashes acc limit i =
if Compare.Int.(i >= l) then
List.rev acc
else if Compare.Char.(String.get path i = delim) then
do_slashes acc limit (i + 1)
else
do_split acc limit i
if Compare.Int.(i >= l) then List.rev acc
else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1)
else do_split acc limit i
and do_split acc limit i =
if Compare.Int.(limit <= 0) then
if Compare.Int.(i = l) then
List.rev acc
else
List.rev (String.sub path i (l - i) :: acc)
else
do_component acc (pred limit) i i
if Compare.Int.(i = l) then List.rev acc
else List.rev (String.sub path i (l - i) :: acc)
else do_component acc (pred limit) i i
and do_component acc limit i j =
if Compare.Int.(j >= l) then
if Compare.Int.(i = j) then
List.rev acc
else
List.rev (String.sub path i (j - i) :: acc)
else if Compare.Char.(String.get path j = delim) then
if Compare.Int.(i = j) then List.rev acc
else List.rev (String.sub path i (j - i) :: acc)
else if Compare.Char.(path.[j] = delim) then
do_slashes (String.sub path i (j - i) :: acc) limit j
else
do_component acc limit i (j + 1) in
if Compare.Int.(limit > 0) then
do_slashes [] limit 0
else
[ path ]
else do_component acc limit i (j + 1)
in
if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path]
let pp_print_paragraph ppf description =
Format.fprintf ppf "@[%a@]"
Format.fprintf
ppf
"@[%a@]"
Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
(split ' ' description)
let take n l =
let rec loop acc n = function
| xs when Compare.Int.(n <= 0) -> Some (List.rev acc, xs)
| [] -> None
| x :: xs -> loop (x :: acc) (n-1) xs in
| xs when Compare.Int.(n <= 0) ->
Some (List.rev acc, xs)
| [] ->
None
| x :: xs ->
loop (x :: acc) (n - 1) xs
in
loop [] n l
let remove_prefix ~prefix s =
@ -86,10 +81,12 @@ let remove_prefix ~prefix s =
let n = String.length s in
if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then
Some (String.sub s x (n - x))
else
None
else None
let rec remove_elem_from_list nb = function
| [] -> []
| l when Compare.Int.(nb <= 0) -> l
| _ :: tl -> remove_elem_from_list (nb - 1) tl
| [] ->
[]
| l when Compare.Int.(nb <= 0) ->
l
| _ :: tl ->
remove_elem_from_list (nb - 1) tl

17
vendors/ligo-utils/tezos-protocol-alpha/misc.mli vendored
View File

@ -26,19 +26,22 @@
(** {2 Helper functions} *)
type 'a lazyt = unit -> 'a
type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt)
type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt
type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t
(** Include bounds *)
val (-->) : int -> int -> int list
val (--->) : Int32.t -> Int32.t -> Int32.t list
val ( --> ) : int -> int -> int list
val ( ---> ) : Int32.t -> Int32.t -> Int32.t list
val pp_print_paragraph : Format.formatter -> string -> unit
val take: int -> 'a list -> ('a list * 'a list) option
val take : int -> 'a list -> ('a list * 'a list) option
(** Some (input with [prefix] removed), if string has [prefix], else [None] **)
val remove_prefix: prefix:string -> string -> string option
(** Some (input with [prefix] removed), if string has [prefix], else [None] *)
val remove_prefix : prefix:string -> string -> string option
(** [remove nb list] remove the first [nb] elements from the list [list]. *)
val remove_elem_from_list: int -> 'a list -> 'a list
val remove_elem_from_list : int -> 'a list -> 'a list

10
vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml vendored
View File

@ -26,12 +26,16 @@
(* 32 *)
let nonce_hash = "\069\220\169" (* nce(53) *)
include Blake2B.Make(Base58)(struct
include Blake2B.Make
(Base58)
(struct
let name = "cycle_nonce"
let title = "A nonce hash"
let b58check_prefix = nonce_hash
let size = None
end)
let () =
Base58.check_encoded_prefix b58check_encoding "nce" 53
let () = Base58.check_encoded_prefix b58check_encoding "nce" 53

53
vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml vendored
View File

@ -24,7 +24,9 @@
(*****************************************************************************)
type t = Seed_repr.nonce
type nonce = t
let encoding = Seed_repr.nonce_encoding
type error +=
@ -39,7 +41,7 @@ let () =
~id:"nonce.too_late_revelation"
~title:"Too late nonce revelation"
~description:"Nonce revelation happens too late"
~pp: (fun ppf () ->
~pp:(fun ppf () ->
Format.fprintf ppf "This nonce cannot be revealed anymore.")
Data_encoding.unit
(function Too_late_revelation -> Some () | _ -> None)
@ -49,7 +51,7 @@ let () =
~id:"nonce.too_early_revelation"
~title:"Too early nonce revelation"
~description:"Nonce revelation happens before cycle end"
~pp: (fun ppf () ->
~pp:(fun ppf () ->
Format.fprintf ppf "This nonce should not yet be revealed")
Data_encoding.unit
(function Too_early_revelation -> Some () | _ -> None)
@ -59,8 +61,7 @@ let () =
~id:"nonce.previously_revealed"
~title:"Previously revealed nonce"
~description:"Duplicated revelation for a nonce."
~pp: (fun ppf () ->
Format.fprintf ppf "This nonce was previously revealed")
~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed")
Data_encoding.unit
(function Previously_revealed_nonce -> Some () | _ -> None)
(fun () -> Previously_revealed_nonce) ;
@ -68,9 +69,13 @@ let () =
`Branch
~id:"nonce.unexpected"
~title:"Unexpected nonce"
~description:"The provided nonce is inconsistent with the committed nonce hash."
~pp: (fun ppf () ->
Format.fprintf ppf "This nonce revelation is invalid (inconsistent with the committed hash)")
~description:
"The provided nonce is inconsistent with the committed nonce hash."
~pp:(fun ppf () ->
Format.fprintf
ppf
"This nonce revelation is invalid (inconsistent with the committed \
hash)")
Data_encoding.unit
(function Unexpected_nonce -> Some () | _ -> None)
(fun () -> Unexpected_nonce)
@ -80,34 +85,40 @@ let () =
let get_unrevealed ctxt level =
let cur_level = Level_storage.current ctxt in
match Cycle_repr.pred cur_level.cycle with
| None -> fail Too_early_revelation (* no revelations during cycle 0 *)
| Some revealed_cycle ->
| None ->
fail Too_early_revelation (* no revelations during cycle 0 *)
| Some revealed_cycle -> (
if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then
fail Too_early_revelation
else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then
fail Too_late_revelation
else
Storage.Seed.Nonce.get ctxt level >>=? function
| Revealed _ -> fail Previously_revealed_nonce
| Unrevealed status -> return status
Storage.Seed.Nonce.get ctxt level
>>=? function
| Revealed _ ->
fail Previously_revealed_nonce
| Unrevealed status ->
return status )
let record_hash ctxt unrevealed =
let level = Level_storage.current ctxt in
Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)
let reveal ctxt level nonce =
get_unrevealed ctxt level >>=? fun unrevealed ->
get_unrevealed ctxt level
>>=? fun unrevealed ->
fail_unless
(Seed_repr.check_hash nonce unrevealed.nonce_hash)
Unexpected_nonce >>=? fun () ->
Storage.Seed.Nonce.set ctxt level (Revealed nonce) >>=? fun ctxt ->
return ctxt
Unexpected_nonce
>>=? fun () ->
Storage.Seed.Nonce.set ctxt level (Revealed nonce)
>>=? fun ctxt -> return ctxt
type unrevealed = Storage.Seed.unrevealed_nonce = {
nonce_hash: Nonce_hash.t ;
delegate: Signature.Public_key_hash.t ;
rewards: Tez_repr.t ;
fees: Tez_repr.t ;
nonce_hash : Nonce_hash.t;
delegate : Signature.Public_key_hash.t;
rewards : Tez_repr.t;
fees : Tez_repr.t;
}
type status = Storage.Seed.nonce_status =
@ -117,5 +128,7 @@ type status = Storage.Seed.nonce_status =
let get = Storage.Seed.Nonce.get
let of_bytes = Seed_repr.make_nonce
let hash = Seed_repr.hash
let check_hash = Seed_repr.check_hash

31
vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli vendored
View File

@ -30,28 +30,29 @@ type error +=
| Unexpected_nonce
type t = Seed_repr.nonce
type nonce = t
val encoding: nonce Data_encoding.t
val encoding : nonce Data_encoding.t
type unrevealed = Storage.Seed.unrevealed_nonce = {
nonce_hash: Nonce_hash.t ;
delegate: Signature.Public_key_hash.t ;
rewards: Tez_repr.t ;
fees: Tez_repr.t ;
nonce_hash : Nonce_hash.t;
delegate : Signature.Public_key_hash.t;
rewards : Tez_repr.t;
fees : Tez_repr.t;
}
type status =
| Unrevealed of unrevealed
| Revealed of Seed_repr.nonce
type status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce
val get: Raw_context.t -> Level_repr.t -> status tzresult Lwt.t
val get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t
val record_hash:
Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t
val record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t
val reveal:
val reveal :
Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t
val of_bytes: MBytes.t -> nonce tzresult
val hash: nonce -> Nonce_hash.t
val check_hash: nonce -> Nonce_hash.t -> bool
val of_bytes : MBytes.t -> nonce tzresult
val hash : nonce -> Nonce_hash.t
val check_hash : nonce -> Nonce_hash.t -> bool

958
vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml vendored
View File

File diff suppressed because it is too large Load Diff

261
vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli vendored
View File

@ -27,204 +27,243 @@
module Kind : sig
type seed_nonce_revelation = Seed_nonce_revelation_kind
type double_endorsement_evidence = Double_endorsement_evidence_kind
type double_baking_evidence = Double_baking_evidence_kind
type activate_account = Activate_account_kind
type endorsement = Endorsement_kind
type proposals = Proposals_kind
type ballot = Ballot_kind
type reveal = Reveal_kind
type transaction = Transaction_kind
type origination = Origination_kind
type delegation = Delegation_kind
type 'a manager =
| Reveal_manager_kind : reveal manager
| Transaction_manager_kind : transaction manager
| Origination_manager_kind : origination manager
| Delegation_manager_kind : delegation manager
end
type raw = Operation.t = {
shell: Operation.shell_header ;
proto: MBytes.t ;
}
type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}
val raw_encoding: raw Data_encoding.t
val raw_encoding : raw Data_encoding.t
type 'kind operation = {
shell: Operation.shell_header ;
protocol_data: 'kind protocol_data ;
shell : Operation.shell_header;
protocol_data : 'kind protocol_data;
}
and 'kind protocol_data = {
contents: 'kind contents_list ;
signature: Signature.t option ;
contents : 'kind contents_list;
signature : Signature.t option;
}
and _ contents_list =
| Single : 'kind contents -> 'kind contents_list
| Cons : 'kind Kind.manager contents * 'rest Kind.manager contents_list ->
(('kind * 'rest) Kind.manager ) contents_list
| Cons :
'kind Kind.manager contents * 'rest Kind.manager contents_list
-> ('kind * 'rest) Kind.manager contents_list
and _ contents =
| Endorsement : {
level: Raw_level_repr.t ;
} -> Kind.endorsement contents
| Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
| Seed_nonce_revelation : {
level: Raw_level_repr.t ;
nonce: Seed_repr.nonce ;
} -> Kind.seed_nonce_revelation contents
level : Raw_level_repr.t;
nonce : Seed_repr.nonce;
}
-> Kind.seed_nonce_revelation contents
| Double_endorsement_evidence : {
op1: Kind.endorsement operation ;
op2: Kind.endorsement operation ;
} -> Kind.double_endorsement_evidence contents
op1 : Kind.endorsement operation;
op2 : Kind.endorsement operation;
}
-> Kind.double_endorsement_evidence contents
| Double_baking_evidence : {
bh1: Block_header_repr.t ;
bh2: Block_header_repr.t ;
} -> Kind.double_baking_evidence contents
bh1 : Block_header_repr.t;
bh2 : Block_header_repr.t;
}
-> Kind.double_baking_evidence contents
| Activate_account : {
id: Ed25519.Public_key_hash.t ;
activation_code: Blinded_public_key_hash.activation_code ;
} -> Kind.activate_account contents
id : Ed25519.Public_key_hash.t;
activation_code : Blinded_public_key_hash.activation_code;
}
-> Kind.activate_account contents
| Proposals : {
source: Signature.Public_key_hash.t ;
period: Voting_period_repr.t ;
proposals: Protocol_hash.t list ;
} -> Kind.proposals contents
source : Signature.Public_key_hash.t;
period : Voting_period_repr.t;
proposals : Protocol_hash.t list;
}
-> Kind.proposals contents
| Ballot : {
source: Signature.Public_key_hash.t ;
period: Voting_period_repr.t ;
proposal: Protocol_hash.t ;
ballot: Vote_repr.ballot ;
} -> Kind.ballot contents
source : Signature.Public_key_hash.t;
period : Voting_period_repr.t;
proposal : Protocol_hash.t;
ballot : Vote_repr.ballot;
}
-> Kind.ballot contents
| Manager_operation : {
source: Signature.Public_key_hash.t ;
fee: Tez_repr.tez ;
counter: counter ;
operation: 'kind manager_operation ;
gas_limit: Z.t;
storage_limit: Z.t;
} -> 'kind Kind.manager contents
source : Signature.Public_key_hash.t;
fee : Tez_repr.tez;
counter : counter;
operation : 'kind manager_operation;
gas_limit : Z.t;
storage_limit : Z.t;
}
-> 'kind Kind.manager contents
and _ manager_operation =
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
| Transaction : {
amount: Tez_repr.tez ;
parameters: Script_repr.lazy_expr ;
entrypoint: string ;
destination: Contract_repr.contract ;
} -> Kind.transaction manager_operation
amount : Tez_repr.tez;
parameters : Script_repr.lazy_expr;
entrypoint : string;
destination : Contract_repr.contract;
}
-> Kind.transaction manager_operation
| Origination : {
delegate: Signature.Public_key_hash.t option ;
script: Script_repr.t ;
credit: Tez_repr.tez ;
preorigination: Contract_repr.t option ;
} -> Kind.origination manager_operation
delegate : Signature.Public_key_hash.t option;
script : Script_repr.t;
credit : Tez_repr.tez;
preorigination : Contract_repr.t option;
}
-> Kind.origination manager_operation
| Delegation :
Signature.Public_key_hash.t option -> Kind.delegation manager_operation
Signature.Public_key_hash.t option
-> Kind.delegation manager_operation
and counter = Z.t
type 'kind internal_operation = {
source: Contract_repr.contract ;
operation: 'kind manager_operation ;
nonce: int ;
source : Contract_repr.contract;
operation : 'kind manager_operation;
nonce : int;
}
type packed_manager_operation =
| Manager : 'kind manager_operation -> packed_manager_operation
type packed_contents =
| Contents : 'kind contents -> packed_contents
type packed_contents = Contents : 'kind contents -> packed_contents
type packed_contents_list =
| Contents_list : 'kind contents_list -> packed_contents_list
val of_list: packed_contents list -> packed_contents_list
val to_list: packed_contents_list -> packed_contents list
val of_list : packed_contents list -> packed_contents_list
val to_list : packed_contents_list -> packed_contents list
type packed_protocol_data =
| Operation_data : 'kind protocol_data -> packed_protocol_data
type packed_operation = {
shell: Operation.shell_header ;
protocol_data: packed_protocol_data ;
shell : Operation.shell_header;
protocol_data : packed_protocol_data;
}
val pack: 'kind operation -> packed_operation
val pack : 'kind operation -> packed_operation
type packed_internal_operation =
| Internal_operation : 'kind internal_operation -> packed_internal_operation
val manager_kind: 'kind manager_operation -> 'kind Kind.manager
val manager_kind : 'kind manager_operation -> 'kind Kind.manager
val encoding: packed_operation Data_encoding.t
val contents_encoding: packed_contents Data_encoding.t
val contents_list_encoding: packed_contents_list Data_encoding.t
val protocol_data_encoding: packed_protocol_data Data_encoding.t
val unsigned_operation_encoding: (Operation.shell_header * packed_contents_list) Data_encoding.t
val encoding : packed_operation Data_encoding.t
val raw: _ operation -> raw
val contents_encoding : packed_contents Data_encoding.t
val hash_raw: raw -> Operation_hash.t
val hash: _ operation -> Operation_hash.t
val hash_packed: packed_operation -> Operation_hash.t
val contents_list_encoding : packed_contents_list Data_encoding.t
val acceptable_passes: packed_operation -> int list
val protocol_data_encoding : packed_protocol_data Data_encoding.t
val unsigned_operation_encoding :
(Operation.shell_header * packed_contents_list) Data_encoding.t
val raw : _ operation -> raw
val hash_raw : raw -> Operation_hash.t
val hash : _ operation -> Operation_hash.t
val hash_packed : packed_operation -> Operation_hash.t
val acceptable_passes : packed_operation -> int list
type error += Missing_signature (* `Permanent *)
type error += Invalid_signature (* `Permanent *)
val check_signature:
val check_signature :
Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult Lwt.t
val check_signature_sync:
val check_signature_sync :
Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult
val internal_operation_encoding:
packed_internal_operation Data_encoding.t
val internal_operation_encoding : packed_internal_operation Data_encoding.t
type ('a, 'b) eq = Eq : ('a, 'a) eq
val equal: 'a operation -> 'b operation -> ('a, 'b) eq option
val equal : 'a operation -> 'b operation -> ('a, 'b) eq option
module Encoding : sig
type 'b case =
Case : { tag: int ;
name: string ;
encoding: 'a Data_encoding.t ;
select: packed_contents -> 'b contents option ;
proj: 'b contents -> 'a ;
inj: 'a -> 'b contents } -> 'b case
| Case : {
tag : int;
name : string;
encoding : 'a Data_encoding.t;
select : packed_contents -> 'b contents option;
proj : 'b contents -> 'a;
inj : 'a -> 'b contents;
}
-> 'b case
val endorsement_case: Kind.endorsement case
val seed_nonce_revelation_case: Kind.seed_nonce_revelation case
val double_endorsement_evidence_case: Kind.double_endorsement_evidence case
val double_baking_evidence_case: Kind.double_baking_evidence case
val activate_account_case: Kind.activate_account case
val proposals_case: Kind.proposals case
val ballot_case: Kind.ballot case
val reveal_case: Kind.reveal Kind.manager case
val transaction_case: Kind.transaction Kind.manager case
val origination_case: Kind.origination Kind.manager case
val delegation_case: Kind.delegation Kind.manager case
val endorsement_case : Kind.endorsement case
val seed_nonce_revelation_case : Kind.seed_nonce_revelation case
val double_endorsement_evidence_case : Kind.double_endorsement_evidence case
val double_baking_evidence_case : Kind.double_baking_evidence case
val activate_account_case : Kind.activate_account case
val proposals_case : Kind.proposals case
val ballot_case : Kind.ballot case
val reveal_case : Kind.reveal Kind.manager case
val transaction_case : Kind.transaction Kind.manager case
val origination_case : Kind.origination Kind.manager case
val delegation_case : Kind.delegation Kind.manager case
module Manager_operations : sig
type 'b case =
MCase : { tag: int ;
name: string ;
encoding: 'a Data_encoding.t ;
select: packed_manager_operation -> 'kind manager_operation option ;
proj: 'kind manager_operation -> 'a ;
inj: 'a -> 'kind manager_operation } -> 'kind case
| MCase : {
tag : int;
name : string;
encoding : 'a Data_encoding.t;
select : packed_manager_operation -> 'kind manager_operation option;
proj : 'kind manager_operation -> 'a;
inj : 'a -> 'kind manager_operation;
}
-> 'kind case
val reveal_case: Kind.reveal case
val transaction_case: Kind.transaction case
val origination_case: Kind.origination case
val delegation_case: Kind.delegation case
val reveal_case : Kind.reveal case
val transaction_case : Kind.transaction case
val origination_case : Kind.origination case
val delegation_case : Kind.delegation case
end
end

357
vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml vendored
View File

@ -24,62 +24,65 @@
(*****************************************************************************)
type bootstrap_account = {
public_key_hash : Signature.Public_key_hash.t ;
public_key : Signature.Public_key.t option ;
amount : Tez_repr.t ;
public_key_hash : Signature.Public_key_hash.t;
public_key : Signature.Public_key.t option;
amount : Tez_repr.t;
}
type bootstrap_contract = {
delegate : Signature.Public_key_hash.t ;
amount : Tez_repr.t ;
script : Script_repr.t ;
delegate : Signature.Public_key_hash.t;
amount : Tez_repr.t;
script : Script_repr.t;
}
type t = {
bootstrap_accounts : bootstrap_account list ;
bootstrap_contracts : bootstrap_contract list ;
commitments : Commitment_repr.t list ;
constants : Constants_repr.parametric ;
security_deposit_ramp_up_cycles : int option ;
no_reward_cycles : int option ;
bootstrap_accounts : bootstrap_account list;
bootstrap_contracts : bootstrap_contract list;
commitments : Commitment_repr.t list;
constants : Constants_repr.parametric;
security_deposit_ramp_up_cycles : int option;
no_reward_cycles : int option;
}
let bootstrap_account_encoding =
let open Data_encoding in
union
[ case (Tag 0) ~title:"Public_key_known"
(tup2
Signature.Public_key.encoding
Tez_repr.encoding)
[ case
(Tag 0)
~title:"Public_key_known"
(tup2 Signature.Public_key.encoding Tez_repr.encoding)
(function
| { public_key_hash ; public_key = Some public_key ; amount } ->
assert (Signature.Public_key_hash.equal
| {public_key_hash; public_key = Some public_key; amount} ->
assert (
Signature.Public_key_hash.equal
(Signature.Public_key.hash public_key)
public_key_hash) ;
public_key_hash ) ;
Some (public_key, amount)
| { public_key = None } -> None)
| {public_key = None} ->
None)
(fun (public_key, amount) ->
{ public_key = Some public_key ;
public_key_hash = Signature.Public_key.hash public_key ;
amount }) ;
case (Tag 1) ~title:"Public_key_unknown"
(tup2
Signature.Public_key_hash.encoding
Tez_repr.encoding)
{
public_key = Some public_key;
public_key_hash = Signature.Public_key.hash public_key;
amount;
});
case
(Tag 1)
~title:"Public_key_unknown"
(tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
(function
| { public_key_hash ; public_key = None ; amount } ->
| {public_key_hash; public_key = None; amount} ->
Some (public_key_hash, amount)
| { public_key = Some _ } -> None)
| {public_key = Some _} ->
None)
(fun (public_key_hash, amount) ->
{ public_key = None ;
public_key_hash ;
amount }) ]
{public_key = None; public_key_hash; amount}) ]
let bootstrap_contract_encoding =
let open Data_encoding in
conv
(fun { delegate ; amount ; script } -> (delegate, amount, script))
(fun (delegate, amount, script) -> { delegate ; amount ; script })
(fun {delegate; amount; script} -> (delegate, amount, script))
(fun (delegate, amount, script) -> {delegate; amount; script})
(obj3
(req "delegate" Signature.Public_key_hash.encoding)
(req "amount" Tez_repr.encoding)
@ -88,16 +91,32 @@ let bootstrap_contract_encoding =
let encoding =
let open Data_encoding in
conv
(fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
security_deposit_ramp_up_cycles ; no_reward_cycles } ->
((bootstrap_accounts, bootstrap_contracts, commitments,
security_deposit_ramp_up_cycles, no_reward_cycles),
constants))
(fun ( (bootstrap_accounts, bootstrap_contracts, commitments,
security_deposit_ramp_up_cycles, no_reward_cycles),
constants) ->
{ bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
security_deposit_ramp_up_cycles ; no_reward_cycles })
(fun { bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles } ->
( ( bootstrap_accounts,
bootstrap_contracts,
commitments,
security_deposit_ramp_up_cycles,
no_reward_cycles ),
constants ))
(fun ( ( bootstrap_accounts,
bootstrap_contracts,
commitments,
security_deposit_ramp_up_cycles,
no_reward_cycles ),
constants ) ->
{
bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles;
})
(merge_objs
(obj5
(req "bootstrap_accounts" (list bootstrap_account_encoding))
@ -106,253 +125,3 @@ let encoding =
(opt "security_deposit_ramp_up_cycles" int31)
(opt "no_reward_cycles" int31))
Constants_repr.parametric_encoding)
(* Only for migration from 004 to 005 *)
module Proto_004 = struct
type parametric = {
preserved_cycles: int ;
blocks_per_cycle: int32 ;
blocks_per_commitment: int32 ;
blocks_per_roll_snapshot: int32 ;
blocks_per_voting_period: int32 ;
time_between_blocks: Period_repr.t list ;
endorsers_per_block: int ;
hard_gas_limit_per_operation: Z.t ;
hard_gas_limit_per_block: Z.t ;
proof_of_work_threshold: int64 ;
tokens_per_roll: Tez_repr.t ;
michelson_maximum_type_size: int;
seed_nonce_revelation_tip: Tez_repr.t ;
origination_size: int ;
block_security_deposit: Tez_repr.t ;
endorsement_security_deposit: Tez_repr.t ;
block_reward: Tez_repr.t ;
endorsement_reward: Tez_repr.t ;
cost_per_byte: Tez_repr.t ;
hard_storage_limit_per_operation: Z.t ;
test_chain_duration: int64 ; (* in seconds *)
}
let default = {
preserved_cycles = 5 ;
blocks_per_cycle = 4096l ;
blocks_per_commitment = 32l ;
blocks_per_roll_snapshot = 256l ;
blocks_per_voting_period = 32768l ;
time_between_blocks =
List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ;
endorsers_per_block = 32 ;
hard_gas_limit_per_operation = Z.of_int 800_000 ;
hard_gas_limit_per_block = Z.of_int 8_000_000 ;
proof_of_work_threshold =
Int64.(sub (shift_left 1L 46) 1L) ;
tokens_per_roll =
Tez_repr.(mul_exn one 8_000) ;
michelson_maximum_type_size = 1000 ;
seed_nonce_revelation_tip = begin
match Tez_repr.(one /? 8L) with
| Ok c -> c
| Error _ -> assert false
end ;
origination_size = 257 ;
block_security_deposit = Tez_repr.(mul_exn one 512) ;
endorsement_security_deposit = Tez_repr.(mul_exn one 64) ;
block_reward = Tez_repr.(mul_exn one 16) ;
endorsement_reward = Tez_repr.(mul_exn one 2) ;
hard_storage_limit_per_operation = Z.of_int 60_000 ;
cost_per_byte = Tez_repr.of_mutez_exn 1_000L ;
test_chain_duration = Int64.mul 32768L 60L;
}
(* This encoding is used to read configuration files (e.g. sandbox.json)
where some fields can be missing, in that case they are replaced by
the default. *)
let constants_encoding =
let open Data_encoding in
conv
(fun (c : parametric) ->
let module Compare_time_between_blocks = Compare.List (Period_repr) in
let module Compare_keys = Compare.List (Ed25519.Public_key) in
let opt (=) def v = if def = v then None else Some v in
let preserved_cycles =
opt Compare.Int.(=)
default.preserved_cycles c.preserved_cycles
and blocks_per_cycle =
opt Compare.Int32.(=)
default.blocks_per_cycle c.blocks_per_cycle
and blocks_per_commitment =
opt Compare.Int32.(=)
default.blocks_per_commitment c.blocks_per_commitment
and blocks_per_roll_snapshot =
opt Compare.Int32.(=)
default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot
and blocks_per_voting_period =
opt Compare.Int32.(=)
default.blocks_per_voting_period c.blocks_per_voting_period
and time_between_blocks =
opt Compare_time_between_blocks.(=)
default.time_between_blocks c.time_between_blocks
and endorsers_per_block =
opt Compare.Int.(=)
default.endorsers_per_block c.endorsers_per_block
and hard_gas_limit_per_operation =
opt Compare.Z.(=)
default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation
and hard_gas_limit_per_block =
opt Compare.Z.(=)
default.hard_gas_limit_per_block c.hard_gas_limit_per_block
and proof_of_work_threshold =
opt Compare.Int64.(=)
default.proof_of_work_threshold c.proof_of_work_threshold
and tokens_per_roll =
opt Tez_repr.(=)
default.tokens_per_roll c.tokens_per_roll
and michelson_maximum_type_size =
opt Compare.Int.(=)
default.michelson_maximum_type_size c.michelson_maximum_type_size
and seed_nonce_revelation_tip =
opt Tez_repr.(=)
default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip
and origination_size =
opt Compare.Int.(=)
default.origination_size c.origination_size
and block_security_deposit =
opt Tez_repr.(=)
default.block_security_deposit c.block_security_deposit
and endorsement_security_deposit =
opt Tez_repr.(=)
default.endorsement_security_deposit c.endorsement_security_deposit
and block_reward =
opt Tez_repr.(=)
default.block_reward c.block_reward
and endorsement_reward =
opt Tez_repr.(=)
default.endorsement_reward c.endorsement_reward
and cost_per_byte =
opt Tez_repr.(=)
default.cost_per_byte c.cost_per_byte
and hard_storage_limit_per_operation =
opt Compare.Z.(=)
default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation
and test_chain_duration =
opt Compare.Int64.(=)
default.test_chain_duration c.test_chain_duration
in
(( preserved_cycles,
blocks_per_cycle,
blocks_per_commitment,
blocks_per_roll_snapshot,
blocks_per_voting_period,
time_between_blocks,
endorsers_per_block,
hard_gas_limit_per_operation,
hard_gas_limit_per_block),
((proof_of_work_threshold,
tokens_per_roll,
michelson_maximum_type_size,
seed_nonce_revelation_tip,
origination_size,
block_security_deposit,
endorsement_security_deposit,
block_reward),
(endorsement_reward,
cost_per_byte,
hard_storage_limit_per_operation,
test_chain_duration))))
(fun (( preserved_cycles,
blocks_per_cycle,
blocks_per_commitment,
blocks_per_roll_snapshot,
blocks_per_voting_period,
time_between_blocks,
endorsers_per_block,
hard_gas_limit_per_operation,
hard_gas_limit_per_block),
((proof_of_work_threshold,
tokens_per_roll,
michelson_maximum_type_size,
seed_nonce_revelation_tip,
origination_size,
block_security_deposit,
endorsement_security_deposit,
block_reward),
(endorsement_reward,
cost_per_byte,
hard_storage_limit_per_operation,
test_chain_duration))) ->
let unopt def = function None -> def | Some v -> v in
{ preserved_cycles =
unopt default.preserved_cycles preserved_cycles ;
blocks_per_cycle =
unopt default.blocks_per_cycle blocks_per_cycle ;
blocks_per_commitment =
unopt default.blocks_per_commitment blocks_per_commitment ;
blocks_per_roll_snapshot =
unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ;
blocks_per_voting_period =
unopt default.blocks_per_voting_period blocks_per_voting_period ;
time_between_blocks =
unopt default.time_between_blocks @@
time_between_blocks ;
endorsers_per_block =
unopt default.endorsers_per_block endorsers_per_block ;
hard_gas_limit_per_operation =
unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ;
hard_gas_limit_per_block =
unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ;
proof_of_work_threshold =
unopt default.proof_of_work_threshold proof_of_work_threshold ;
tokens_per_roll =
unopt default.tokens_per_roll tokens_per_roll ;
michelson_maximum_type_size =
unopt default.michelson_maximum_type_size michelson_maximum_type_size ;
seed_nonce_revelation_tip =
unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ;
origination_size =
unopt default.origination_size origination_size ;
block_security_deposit =
unopt default.block_security_deposit block_security_deposit ;
endorsement_security_deposit =
unopt default.endorsement_security_deposit endorsement_security_deposit ;
block_reward =
unopt default.block_reward block_reward ;
endorsement_reward =
unopt default.endorsement_reward endorsement_reward ;
cost_per_byte =
unopt default.cost_per_byte cost_per_byte ;
hard_storage_limit_per_operation =
unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ;
test_chain_duration =
unopt default.test_chain_duration test_chain_duration ;
} )
(merge_objs
(obj9
(opt "preserved_cycles" uint8)
(opt "blocks_per_cycle" int32)
(opt "blocks_per_commitment" int32)
(opt "blocks_per_roll_snapshot" int32)
(opt "blocks_per_voting_period" int32)
(opt "time_between_blocks" (list Period_repr.encoding))
(opt "endorsers_per_block" uint16)
(opt "hard_gas_limit_per_operation" z)
(opt "hard_gas_limit_per_block" z))
(merge_objs
(obj8
(opt "proof_of_work_threshold" int64)
(opt "tokens_per_roll" Tez_repr.encoding)
(opt "michelson_maximum_type_size" uint16)
(opt "seed_nonce_revelation_tip" Tez_repr.encoding)
(opt "origination_size" int31)
(opt "block_security_deposit" Tez_repr.encoding)
(opt "endorsement_security_deposit" Tez_repr.encoding)
(opt "block_reward" Tez_repr.encoding))
(obj4
(opt "endorsement_reward" Tez_repr.encoding)
(opt "cost_per_byte" Tez_repr.encoding)
(opt "hard_storage_limit_per_operation" z)
(opt "test_chain_duration" int64))))
end

57
vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli vendored
View File

@ -24,55 +24,24 @@
(*****************************************************************************)
type bootstrap_account = {
public_key_hash : Signature.Public_key_hash.t ;
public_key : Signature.Public_key.t option ;
amount : Tez_repr.t ;
public_key_hash : Signature.Public_key_hash.t;
public_key : Signature.Public_key.t option;
amount : Tez_repr.t;
}
type bootstrap_contract = {
delegate : Signature.Public_key_hash.t ;
amount : Tez_repr.t ;
script : Script_repr.t ;
delegate : Signature.Public_key_hash.t;
amount : Tez_repr.t;
script : Script_repr.t;
}
type t = {
bootstrap_accounts : bootstrap_account list ;
bootstrap_contracts : bootstrap_contract list ;
commitments : Commitment_repr.t list ;
constants : Constants_repr.parametric ;
security_deposit_ramp_up_cycles : int option ;
no_reward_cycles : int option ;
bootstrap_accounts : bootstrap_account list;
bootstrap_contracts : bootstrap_contract list;
commitments : Commitment_repr.t list;
constants : Constants_repr.parametric;
security_deposit_ramp_up_cycles : int option;
no_reward_cycles : int option;
}
val encoding: t Data_encoding.t
(* Only for migration from 004 to 005 *)
module Proto_004 : sig
type parametric = {
preserved_cycles: int ;
blocks_per_cycle: int32 ;
blocks_per_commitment: int32 ;
blocks_per_roll_snapshot: int32 ;
blocks_per_voting_period: int32 ;
time_between_blocks: Period_repr.t list ;
endorsers_per_block: int ;
hard_gas_limit_per_operation: Z.t ;
hard_gas_limit_per_block: Z.t ;
proof_of_work_threshold: int64 ;
tokens_per_roll: Tez_repr.t ;
michelson_maximum_type_size: int;
seed_nonce_revelation_tip: Tez_repr.t ;
origination_size: int ;
block_security_deposit: Tez_repr.t ;
endorsement_security_deposit: Tez_repr.t ;
block_reward: Tez_repr.t ;
endorsement_reward: Tez_repr.t ;
cost_per_byte: Tez_repr.t ;
hard_storage_limit_per_operation: Z.t ;
test_chain_duration: int64 ;
}
val constants_encoding: parametric Data_encoding.t
end
val encoding : t Data_encoding.t

24
vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml vendored
View File

@ -24,8 +24,11 @@
(*****************************************************************************)
type t = Int64.t
type period = t
include (Compare.Int64 : Compare.S with type t := t)
let encoding = Data_encoding.int64
let rpc_arg = RPC_arg.int64
@ -33,8 +36,7 @@ let rpc_arg = RPC_arg.int64
let pp ppf v = Format.fprintf ppf "%Ld" v
type error += (* `Permanent *)
| Malformed_period
| Invalid_arg
Malformed_period | Invalid_arg
let () =
let open Data_encoding in
@ -60,22 +62,26 @@ let () =
(fun () -> Invalid_arg)
let of_seconds t =
if Compare.Int64.(t >= 0L)
then ok t
else error Malformed_period
if Compare.Int64.(t >= 0L) then ok t else error Malformed_period
let to_seconds t = t
let of_seconds_exn t =
match of_seconds t with
| Ok t -> t
| _ -> invalid_arg "Period.of_seconds_exn"
| Ok t ->
t
| _ ->
invalid_arg "Period.of_seconds_exn"
let mult i p =
(* TODO check overflow *)
if Compare.Int32.(i < 0l)
then error Invalid_arg
if Compare.Int32.(i < 0l) then error Invalid_arg
else ok (Int64.mul (Int64.of_int32 i) p)
let zero = of_seconds_exn 0L
let one_second = of_seconds_exn 1L
let one_minute = of_seconds_exn 60L
let one_hour = of_seconds_exn 3600L

17
vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli vendored
View File

@ -24,12 +24,16 @@
(*****************************************************************************)
type t
type period = t
include Compare.S with type t := t
val encoding : period Data_encoding.t
val rpc_arg : period RPC_arg.t
val pp: Format.formatter -> period -> unit
type period = t
include Compare.S with type t := t
val encoding : period Data_encoding.t
val rpc_arg : period RPC_arg.t
val pp : Format.formatter -> period -> unit
val to_seconds : period -> int64
@ -43,6 +47,9 @@ val of_seconds_exn : int64 -> period
val mult : int32 -> period -> period tzresult
val zero : period
val one_second : period
val one_minute : period
val one_hour : period

260
vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml vendored
View File

@ -35,18 +35,28 @@ module type S = sig
| Subtraction_underflow of qty * qty (* `Temporary *)
| Multiplication_overflow of qty * int64 (* `Temporary *)
| Negative_multiplicator of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64
(* `Temporary *)
val id : string
val zero : qty
val one_mutez : qty
val one_cent : qty
val fifty_cents : qty
val one : qty
val ( -? ) : qty -> qty -> qty tzresult
val ( +? ) : qty -> qty -> qty tzresult
val ( *? ) : qty -> int64 -> qty tzresult
val ( /? ) : qty -> int64 -> qty tzresult
val to_mutez : qty -> int64
@ -70,15 +80,14 @@ module type S = sig
include Compare.S with type t := qty
val pp: Format.formatter -> qty -> unit
val pp : Format.formatter -> qty -> unit
val of_string: string -> qty option
val to_string: qty -> string
val of_string : string -> qty option
val to_string : qty -> string
end
module Make (T: QTY) : S = struct
module Make (T : QTY) : S = struct
type qty = int64 (* invariant: positive *)
type error +=
@ -86,16 +95,24 @@ module Make (T: QTY) : S = struct
| Subtraction_underflow of qty * qty (* `Temporary *)
| Multiplication_overflow of qty * int64 (* `Temporary *)
| Negative_multiplicator of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64
(* `Temporary *)
include Compare.Int64
let zero = 0L
(* all other constant are defined from the value of one micro tez *)
let one_mutez = 1L
let one_cent = Int64.mul one_mutez 10_000L
let fifty_cents = Int64.mul one_cent 50L
(* 1 tez = 100 cents = 1_000_000 mutez *)
let one = Int64.mul one_cent 100L
let id = T.id
let of_string s =
@ -103,143 +120,130 @@ module Make (T: QTY) : S = struct
| hd :: tl ->
let len = String.length hd in
Compare.Int.(
len <= 3 && len > 0 &&
List.for_all (fun s -> String.length s = 3) tl
)
| [] -> false in
len <= 3 && len > 0
&& List.for_all (fun s -> String.length s = 3) tl)
| [] ->
false
in
let integers s = triplets (String.split_on_char ',' s) in
let decimals s =
let l = String.split_on_char ',' s in
if Compare.Int.(List.length l > 2) then
false
else
triplets (List.rev l) in
if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
in
let parse left right =
let remove_commas s = String.concat "" (String.split_on_char ',' s) in
let pad_to_six s =
let len = String.length s in
String.init 6 (fun i -> if Compare.Int.(i < len) then String.get s i else '0') in
String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
in
try
Some (Int64.of_string (remove_commas left ^ pad_to_six (remove_commas right)))
with _ -> None in
Some
(Int64.of_string
(remove_commas left ^ pad_to_six (remove_commas right)))
with _ -> None
in
match String.split_on_char '.' s with
| [ left ; right ] ->
| [left; right] ->
if String.contains s ',' then
if integers left && decimals right then
parse left right
else
if integers left && decimals right then parse left right else None
else if
Compare.Int.(String.length right > 0)
&& Compare.Int.(String.length right <= 6)
then parse left right
else None
| [left] ->
if (not (String.contains s ',')) || integers left then parse left ""
else None
| _ ->
None
else if Compare.Int.(String.length right > 0)
&& Compare.Int.(String.length right <= 6) then
parse left right
else None
| [ left ] ->
if not (String.contains s ',') || integers left then
parse left ""
else None
| _ -> None
let pp ppf amount =
let mult_int = 1_000_000L in
let rec left ppf amount =
let d, r = Int64.(div amount 1000L), Int64.(rem amount 1000L) in
if d > 0L then
Format.fprintf ppf "%a%03Ld" left d r
else
Format.fprintf ppf "%Ld" r in
let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
else Format.fprintf ppf "%Ld" r
in
let right ppf amount =
let triplet ppf v =
if Compare.Int.(v mod 10 > 0) then
Format.fprintf ppf "%03d" v
if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
else if Compare.Int.(v mod 100 > 0) then
Format.fprintf ppf "%02d" (v / 10)
else
Format.fprintf ppf "%d" (v / 100) in
let hi, lo = amount / 1000, amount mod 1000 in
if Compare.Int.(lo = 0) then
Format.fprintf ppf "%a" triplet hi
else
Format.fprintf ppf "%03d%a" hi triplet lo in
let ints, decs =
Int64.(div amount mult_int),
Int64.(to_int (rem amount mult_int)) in
else Format.fprintf ppf "%d" (v / 100)
in
let (hi, lo) = (amount / 1000, amount mod 1000) in
if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
else Format.fprintf ppf "%03d%a" hi triplet lo
in
let (ints, decs) =
(Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
in
Format.fprintf ppf "%a" left ints ;
if Compare.Int.(decs > 0) then
Format.fprintf ppf ".%a" right decs
if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs
let to_string t =
Format.asprintf "%a" pp t
let to_string t = Format.asprintf "%a" pp t
let (-) t1 t2 =
if t2 <= t1
then Some (Int64.sub t1 t2)
else None
let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None
let ( -? ) t1 t2 =
match t1 - t2 with
| None -> error (Subtraction_underflow (t1, t2))
| Some v -> ok v
| None ->
error (Subtraction_underflow (t1, t2))
| Some v ->
ok v
let ( +? ) t1 t2 =
let t = Int64.add t1 t2 in
if t < t1
then error (Addition_overflow (t1, t2))
else ok t
if t < t1 then error (Addition_overflow (t1, t2)) else ok t
let ( *? ) t m =
let open Compare.Int64 in
let open Int64 in
let rec step cur pow acc =
if cur = 0L then
ok acc
if cur = 0L then ok acc
else
pow +? pow >>? fun npow ->
pow +? pow
>>? fun npow ->
if logand cur 1L = 1L then
acc +? pow >>? fun nacc ->
step (shift_right_logical cur 1) npow nacc
else
step (shift_right_logical cur 1) npow acc in
if m < 0L then
error (Negative_multiplicator (t, m))
acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
else step (shift_right_logical cur 1) npow acc
in
if m < 0L then error (Negative_multiplicator (t, m))
else
match step m t 0L with
| Ok res -> Ok res
| Error ([ Addition_overflow _ ] as errs) ->
| Ok res ->
Ok res
| Error ([Addition_overflow _] as errs) ->
Error (Multiplication_overflow (t, m) :: errs)
| Error errs -> Error errs
| Error errs ->
Error errs
let ( /? ) t d =
if d <= 0L then
error (Invalid_divisor (t, d))
else
ok (Int64.div t d)
if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)
let add_exn t1 t2 =
let t = Int64.add t1 t2 in
if t <= 0L
then invalid_arg "add_exn"
else t
if t <= 0L then invalid_arg "add_exn" else t
let mul_exn t m =
match t *? Int64.(of_int m) with
| Ok v -> v
| Error _ -> invalid_arg "mul_exn"
| Ok v ->
v
| Error _ ->
invalid_arg "mul_exn"
let of_mutez t =
if t < 0L then None
else Some t
let of_mutez t = if t < 0L then None else Some t
let of_mutez_exn x =
match of_mutez x with
| None -> invalid_arg "Qty.of_mutez"
| Some v -> v
match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v
let to_int64 t = t
let to_mutez t = t
let encoding =
let open Data_encoding in
(check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n))
check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)
let () =
let open Data_encoding in
@ -247,11 +251,17 @@ module Make (T: QTY) : S = struct
`Temporary
~id:(T.id ^ ".addition_overflow")
~title:("Overflowing " ^ T.id ^ " addition")
~pp: (fun ppf (opa, opb) ->
Format.fprintf ppf "Overflowing addition of %a %s and %a %s"
pp opa T.id pp opb T.id)
~description:
("An addition of two " ^ T.id ^ " amounts overflowed")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Overflowing addition of %a %s and %a %s"
pp
opa
T.id
pp
opb
T.id)
~description:("An addition of two " ^ T.id ^ " amounts overflowed")
(obj1 (req "amounts" (tup2 encoding encoding)))
(function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Addition_overflow (a, b)) ;
@ -259,11 +269,17 @@ module Make (T: QTY) : S = struct
`Temporary
~id:(T.id ^ ".subtraction_underflow")
~title:("Underflowing " ^ T.id ^ " subtraction")
~pp: (fun ppf (opa, opb) ->
Format.fprintf ppf "Underflowing subtraction of %a %s and %a %s"
pp opa T.id pp opb T.id)
~description:
("An subtraction of two " ^ T.id ^ " amounts underflowed")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Underflowing subtraction of %a %s and %a %s"
pp
opa
T.id
pp
opb
T.id)
~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
(obj1 (req "amounts" (tup2 encoding encoding)))
(function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Subtraction_underflow (a, b)) ;
@ -271,43 +287,51 @@ module Make (T: QTY) : S = struct
`Temporary
~id:(T.id ^ ".multiplication_overflow")
~title:("Overflowing " ^ T.id ^ " multiplication")
~pp: (fun ppf (opa, opb) ->
Format.fprintf ppf "Overflowing multiplication of %a %s and %Ld"
pp opa T.id opb)
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Overflowing multiplication of %a %s and %Ld"
pp
opa
T.id
opb)
~description:
("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
(obj2
(req "amount" encoding)
(req "multiplicator" int64))
(obj2 (req "amount" encoding) (req "multiplicator" int64))
(function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Multiplication_overflow (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".negative_multiplicator")
~title:("Negative " ^ T.id ^ " multiplicator")
~pp: (fun ppf (opa, opb) ->
Format.fprintf ppf "Multiplication of %a %s by negative integer %Ld"
pp opa T.id opb)
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Multiplication of %a %s by negative integer %Ld"
pp
opa
T.id
opb)
~description:
("Multiplication of a " ^ T.id ^ " amount by a negative integer")
(obj2
(req "amount" encoding)
(req "multiplicator" int64))
(obj2 (req "amount" encoding) (req "multiplicator" int64))
(function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Negative_multiplicator (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".invalid_divisor")
~title:("Invalid " ^ T.id ^ " divisor")
~pp: (fun ppf (opa, opb) ->
Format.fprintf ppf "Division of %a %s by non positive integer %Ld"
pp opa T.id opb)
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Division of %a %s by non positive integer %Ld"
pp
opa
T.id
opb)
~description:
("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
(obj2
(req "amount" encoding)
(req "divisor" int64))
(obj2 (req "amount" encoding) (req "divisor" int64))
(function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Invalid_divisor (a, b))
end

765
vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml vendored
View File

File diff suppressed because it is too large Load Diff

231
vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli vendored
View File

@ -35,125 +35,152 @@ type storage_error =
| Corrupted_data of string list
type error += Storage_error of storage_error
type error += Failed_to_parse_parameter of MBytes.t
type error += Failed_to_decode_parameter of Data_encoding.json * string
val storage_error: storage_error -> 'a tzresult Lwt.t
val storage_error : storage_error -> 'a tzresult Lwt.t
(** {1 Abstract Context} *)
(** Abstract view of the context.
Includes a handle to the functional key-value database
({!Context.t}) along with some in-memory values (gas, etc.). *)
module Int_set : sig
type t
end
type t = {
context: Context.t ;
constants: Constants_repr.parametric ;
first_level: Raw_level_repr.t ;
level: Level_repr.t ;
predecessor_timestamp: Time.t ;
timestamp: Time.t ;
fitness: Int64.t ;
deposits: Tez_repr.t Signature.Public_key_hash.Map.t ;
included_endorsements: int ;
allowed_endorsements:
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ;
fees: Tez_repr.t ;
rewards: Tez_repr.t ;
block_gas: Z.t ;
operation_gas: Gas_limit_repr.t ;
internal_gas: Gas_limit_repr.internal_gas ;
storage_space_to_pay: Z.t option ;
allocated_contracts: int option ;
origination_nonce: Contract_repr.origination_nonce option ;
temporary_big_map: Z.t ;
internal_nonce: int ;
internal_nonces_used: Int_set.t ;
context : Context.t;
constants : Constants_repr.parametric;
first_level : Raw_level_repr.t;
level : Level_repr.t;
predecessor_timestamp : Time.t;
timestamp : Time.t;
fitness : Int64.t;
deposits : Tez_repr.t Signature.Public_key_hash.Map.t;
included_endorsements : int;
allowed_endorsements :
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t;
fees : Tez_repr.t;
rewards : Tez_repr.t;
block_gas : Z.t;
operation_gas : Gas_limit_repr.t;
internal_gas : Gas_limit_repr.internal_gas;
storage_space_to_pay : Z.t option;
allocated_contracts : int option;
origination_nonce : Contract_repr.origination_nonce option;
temporary_big_map : Z.t;
internal_nonce : int;
internal_nonces_used : Int_set.t;
}
type context = t
type root_context = t
(** Retrieves the state of the database and gives its abstract view.
It also returns wether this is the first block validated
with this version of the protocol. *)
val prepare:
level: Int32.t ->
predecessor_timestamp: Time.t ->
timestamp: Time.t ->
fitness: Fitness.t ->
Context.t -> context tzresult Lwt.t
val prepare :
level:Int32.t ->
predecessor_timestamp:Time.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
Context.t ->
context tzresult Lwt.t
type previous_protocol =
| Genesis of Parameters_repr.t
| Athens_004
type previous_protocol = Genesis of Parameters_repr.t | Babylon_005
val prepare_first_block:
val prepare_first_block :
level:int32 ->
timestamp:Time.t ->
fitness:Fitness.t ->
Context.t -> (previous_protocol * context) tzresult Lwt.t
Context.t ->
(previous_protocol * context) tzresult Lwt.t
val activate: context -> Protocol_hash.t -> t Lwt.t
val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t
val activate : context -> Protocol_hash.t -> t Lwt.t
val fork_test_chain : context -> Protocol_hash.t -> Time.t -> t Lwt.t
(** Returns the state of the database resulting of operations on its
abstract view *)
val recover: context -> Context.t
val recover : context -> Context.t
val current_level: context -> Level_repr.t
val predecessor_timestamp: context -> Time.t
val current_timestamp: context -> Time.t
val current_level : context -> Level_repr.t
val current_fitness: context -> Int64.t
val set_current_fitness: context -> Int64.t -> t
val predecessor_timestamp : context -> Time.t
val constants: context -> Constants_repr.parametric
val patch_constants:
val current_timestamp : context -> Time.t
val current_fitness : context -> Int64.t
val set_current_fitness : context -> Int64.t -> t
val constants : context -> Constants_repr.parametric
val patch_constants :
context ->
(Constants_repr.parametric -> Constants_repr.parametric) ->
context Lwt.t
val first_level: context -> Raw_level_repr.t
val first_level : context -> Raw_level_repr.t
(** Increment the current block fee stash that will be credited to baker's
frozen_fees account at finalize_application *)
val add_fees: context -> Tez_repr.t -> context tzresult Lwt.t
val add_fees : context -> Tez_repr.t -> context tzresult Lwt.t
(** Increment the current block reward stash that will be credited to baker's
frozen_fees account at finalize_application *)
val add_rewards: context -> Tez_repr.t -> context tzresult Lwt.t
val add_rewards : context -> Tez_repr.t -> context tzresult Lwt.t
(** Increment the current block deposit stash for a specific delegate. All the
delegates' frozen_deposit accounts are credited at finalize_application *)
val add_deposit:
context -> Signature.Public_key_hash.t -> Tez_repr.t -> context tzresult Lwt.t
val add_deposit :
context ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
context tzresult Lwt.t
val get_fees: context -> Tez_repr.t
val get_rewards: context -> Tez_repr.t
val get_deposits: context -> Tez_repr.t Signature.Public_key_hash.Map.t
val get_fees : context -> Tez_repr.t
val get_rewards : context -> Tez_repr.t
val get_deposits : context -> Tez_repr.t Signature.Public_key_hash.Map.t
type error += Gas_limit_too_high (* `Permanent *)
val check_gas_limit: t -> Z.t -> unit tzresult
val set_gas_limit: t -> Z.t -> t
val set_gas_unlimited: t -> t
val gas_level: t -> Gas_limit_repr.t
val gas_consumed: since: t -> until: t -> Z.t
val block_gas_level: t -> Z.t
val check_gas_limit : t -> Z.t -> unit tzresult
val init_storage_space_to_pay: t -> t
val update_storage_space_to_pay: t -> Z.t -> t
val update_allocated_contracts_count: t -> t
val clear_storage_space_to_pay: t -> t * Z.t * int
val set_gas_limit : t -> Z.t -> t
val set_gas_unlimited : t -> t
val gas_level : t -> Gas_limit_repr.t
val gas_consumed : since:t -> until:t -> Z.t
val block_gas_level : t -> Z.t
val init_storage_space_to_pay : t -> t
val update_storage_space_to_pay : t -> Z.t -> t
val update_allocated_contracts_count : t -> t
val clear_storage_space_to_pay : t -> t * Z.t * int
type error += Undefined_operation_nonce (* `Permanent *)
val init_origination_nonce: t -> Operation_hash.t -> t
val origination_nonce: t -> Contract_repr.origination_nonce tzresult
val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult
val unset_origination_nonce: t -> t
val init_origination_nonce : t -> Operation_hash.t -> t
val origination_nonce : t -> Contract_repr.origination_nonce tzresult
val increment_origination_nonce :
t -> (t * Contract_repr.origination_nonce) tzresult
val unset_origination_nonce : t -> t
(** {1 Generic accessors} *)
@ -165,127 +192,127 @@ type value = MBytes.t
as-is for direct context accesses, and used in {!Storage_functors}
to provide restricted views to the context. *)
module type T = sig
type t
type context = t
(** Tells if the key is already defined as a value. *)
val mem: context -> key -> bool Lwt.t
val mem : context -> key -> bool Lwt.t
(** Tells if the key is already defined as a directory. *)
val dir_mem: context -> key -> bool Lwt.t
val dir_mem : context -> key -> bool Lwt.t
(** Retrieve the value from the storage bucket ; returns a
{!Storage_error Missing_key} if the key is not set. *)
val get: context -> key -> value tzresult Lwt.t
val get : context -> key -> value tzresult Lwt.t
(** Retrieves the value from the storage bucket ; returns [None] if
the data is not initialized. *)
val get_option: context -> key -> value option Lwt.t
val get_option : context -> key -> value option Lwt.t
(** Allocates the storage bucket and initializes it ; returns a
{!Storage_error Existing_key} if the bucket exists. *)
val init: context -> key -> value -> context tzresult Lwt.t
val init : context -> key -> value -> context tzresult Lwt.t
(** Updates the content of the bucket ; returns a {!Storage_error
Missing_key} if the value does not exists. *)
val set: context -> key -> value -> context tzresult Lwt.t
val set : context -> key -> value -> context tzresult Lwt.t
(** Allocates the data and initializes it with a value ; just
updates it if the bucket exists. *)
val init_set: context -> key -> value -> context Lwt.t
val init_set : context -> key -> value -> context Lwt.t
(** When the value is [Some v], allocates the data and initializes
it with [v] ; just updates it if the bucket exists. When the
valus is [None], delete the storage bucket when the value ; does
nothing if the bucket does not exists. *)
val set_option: context -> key -> value option -> context Lwt.t
val set_option : context -> key -> value option -> context Lwt.t
(** Delete the storage bucket ; returns a {!Storage_error
Missing_key} if the bucket does not exists. *)
val delete: context -> key -> context tzresult Lwt.t
val delete : context -> key -> context tzresult Lwt.t
(** Removes the storage bucket and its contents ; does nothing if the
bucket does not exists. *)
val remove: context -> key -> context Lwt.t
val remove : context -> key -> context Lwt.t
(** Recursively removes all the storage buckets and contents ; does
nothing if no bucket exists. *)
val remove_rec: context -> key -> context Lwt.t
val remove_rec : context -> key -> context Lwt.t
val copy: context -> from:key -> to_:key -> context tzresult Lwt.t
val copy : context -> from:key -> to_:key -> context tzresult Lwt.t
(** Iterator on all the items of a given directory. *)
val fold:
context -> key -> init:'a ->
f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
val fold :
context ->
key ->
init:'a ->
f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
(** Recursively list all subkeys of a given key. *)
val keys: context -> key -> key list Lwt.t
val keys : context -> key -> key list Lwt.t
(** Recursive iterator on all the subkeys of a given key. *)
val fold_keys:
val fold_keys :
context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
(** Internally used in {!Storage_functors} to escape from a view. *)
val project: context -> root_context
val project : context -> root_context
(** Internally used in {!Storage_functors} to retrieve a full key
from partial key relative a view. *)
val absolute_key: context -> key -> key
val absolute_key : context -> key -> key
(** Internally used in {!Storage_functors} to consume gas from
within a view. *)
val consume_gas: context -> Gas_limit_repr.cost -> context tzresult
val consume_gas : context -> Gas_limit_repr.cost -> context tzresult
(** Check if consume_gas will fail *)
val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult
val description: context Storage_description.t
val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult
val description : context Storage_description.t
end
include T with type t := t and type context := context
(** Initialize the local nonce used for preventing a script to
duplicate an internal operation to replay it. *)
val reset_internal_nonce: context -> context
val reset_internal_nonce : context -> context
(** Increments the internal operation nonce. *)
val fresh_internal_nonce: context -> (context * int) tzresult
val fresh_internal_nonce : context -> (context * int) tzresult
(** Mark an internal operation nonce as taken. *)
val record_internal_nonce: context -> int -> context
val record_internal_nonce : context -> int -> context
(** Check is the internal operation nonce has been taken. *)
val internal_nonce_already_recorded: context -> int -> bool
val internal_nonce_already_recorded : context -> int -> bool
(** Returns a map where to each endorser's pkh is associated the list of its
endorsing slots (in decreasing order) for a given level. *)
val allowed_endorsements:
val allowed_endorsements :
context ->
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t
(** Keep track of the number of endorsements that are included in a block *)
val included_endorsements: context -> int
val included_endorsements : context -> int
(** Initializes the map of allowed endorsements, this function must only be
called once. *)
val init_endorsements:
val init_endorsements :
context ->
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
context
(** Marks an endorsment in the map as used. *)
val record_endorsement:
context -> Signature.Public_key_hash.t -> context
val record_endorsement : context -> Signature.Public_key_hash.t -> context
(** Provide a fresh identifier for a temporary big map (negative index). *)
val fresh_temporary_big_map: context -> context * Z.t
val fresh_temporary_big_map : context -> context * Z.t
(** Reset the temporary big_map identifier generator to [-1]. *)
val reset_temporary_big_map: context -> context
val reset_temporary_big_map : context -> context
(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *)
val temporary_big_maps: context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t
val temporary_big_maps : context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t

50
vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml vendored
View File

@ -24,37 +24,43 @@
(*****************************************************************************)
type t = int32
type raw_level = t
include (Compare.Int32 : Compare.S with type t := t)
let encoding = Data_encoding.int32
let pp ppf level = Format.fprintf ppf "%ld" level
let rpc_arg =
let construct raw_level = Int32.to_string raw_level in
let destruct str =
match Int32.of_string str with
| exception _ -> Error "Cannot parse level"
| raw_level -> Ok raw_level in
| exception _ ->
Error "Cannot parse level"
| raw_level ->
Ok raw_level
in
RPC_arg.make
~descr:"A level integer"
~name: "block_level"
~name:"block_level"
~construct
~destruct
()
let root = 0l
let succ = Int32.succ
let pred l =
if l = 0l
then None
else Some (Int32.pred l)
let pred l = if l = 0l then None else Some (Int32.pred l)
let diff = Int32.sub
let to_int32 l = l
let of_int32_exn l =
if Compare.Int32.(l >= 0l)
then l
else invalid_arg "Level_repr.of_int32"
if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32"
type error += Unexpected_level of Int32.t (* `Permanent *)
@ -65,26 +71,32 @@ let () =
~title:"Unexpected level"
~description:"Level must be non-negative."
~pp:(fun ppf l ->
Format.fprintf ppf "The level is %s but should be non-negative." (Int32.to_string l))
Format.fprintf
ppf
"The level is %s but should be non-negative."
(Int32.to_string l))
Data_encoding.(obj1 (req "level" int32))
(function Unexpected_level l -> Some l | _ -> None)
(fun l -> Unexpected_level l)
let of_int32 l =
try Ok (of_int32_exn l)
with _ -> error (Unexpected_level l)
let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l)
module Index = struct
type t = raw_level
let path_length = 1
let to_path level l = Int32.to_string level :: l
let of_path = function
| [s] -> begin
try Some (Int32.of_string s)
with _ -> None
end
| _ -> None
| [s] -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end

28
vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli vendored
View File

@ -27,21 +27,29 @@
since genesis: genesis is 0, all other blocks have increasing levels from
there. *)
type t
type raw_level = t
val encoding: raw_level Data_encoding.t
val rpc_arg: raw_level RPC_arg.arg
val pp: Format.formatter -> raw_level -> unit
val encoding : raw_level Data_encoding.t
val rpc_arg : raw_level RPC_arg.arg
val pp : Format.formatter -> raw_level -> unit
include Compare.S with type t := raw_level
val to_int32: raw_level -> int32
val of_int32_exn: int32 -> raw_level
val of_int32: int32 -> raw_level tzresult
val to_int32 : raw_level -> int32
val diff: raw_level -> raw_level -> int32
val of_int32_exn : int32 -> raw_level
val root: raw_level
val of_int32 : int32 -> raw_level tzresult
val succ: raw_level -> raw_level
val pred: raw_level -> raw_level option
val diff : raw_level -> raw_level -> int32
val root : raw_level
val succ : raw_level -> raw_level
val pred : raw_level -> raw_level option
module Index : Storage_description.INDEX with type t = raw_level

34
vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml vendored
View File

@ -24,38 +24,42 @@
(*****************************************************************************)
include Compare.Int32
type roll = t
let encoding = Data_encoding.int32
let first = 0l
let succ i = Int32.succ i
let random sequence ~bound =
Seed_repr.take_int32 sequence bound
let random sequence ~bound = Seed_repr.take_int32 sequence bound
let rpc_arg =
RPC_arg.like
RPC_arg.int32
"roll"
let rpc_arg = RPC_arg.like RPC_arg.int32 "roll"
let to_int32 v = v
module Index = struct
type t = roll
let path_length = 3
let to_path roll l =
(Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff)) ::
(Int32.to_string @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)) ::
Int32.to_string roll :: l
(Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff))
:: ( Int32.to_string
@@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)
)
:: Int32.to_string roll :: l
let of_path = function
| _ :: _ :: s :: _ -> begin
try Some (Int32.of_string s)
with _ -> None
end
| _ -> None
| _ :: _ :: s :: _ -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end

18
vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli vendored
View File

@ -24,19 +24,21 @@
(*****************************************************************************)
type t = private int32
type roll = t
val encoding: roll Data_encoding.t
val rpc_arg: roll RPC_arg.t
val encoding : roll Data_encoding.t
val random:
Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence
val rpc_arg : roll RPC_arg.t
val first: roll
val succ: roll -> roll
val random : Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence
val to_int32: roll -> Int32.t
val first : roll
val (=): roll -> roll -> bool
val succ : roll -> roll
val to_int32 : roll -> Int32.t
val ( = ) : roll -> roll -> bool
module Index : Storage_description.INDEX with type t = roll

569
vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml vendored
View File

@ -29,7 +29,9 @@ type error +=
| Consume_roll_change (* `Permanent *)
| No_roll_for_delegate (* `Permanent *)
| No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *)
| Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *)
| Unregistered_delegate of Signature.Public_key_hash.t
(* `Permanent *)
let () =
let open Data_encoding in
@ -59,12 +61,16 @@ let () =
`Permanent
~id:"contract.manager.no_roll_snapshot_for_cycle"
~title:"No roll snapshot for cycle"
~description:"A snapshot of the rolls distribution does not exist for this cycle."
~description:
"A snapshot of the rolls distribution does not exist for this cycle."
~pp:(fun ppf c ->
Format.fprintf ppf
"A snapshot of the rolls distribution does not exist for cycle %a" Cycle_repr.pp c)
Format.fprintf
ppf
"A snapshot of the rolls distribution does not exist for cycle %a"
Cycle_repr.pp
c)
(obj1 (req "cycle" Cycle_repr.encoding))
(function No_roll_snapshot_for_cycle c-> Some c | _ -> None)
(function No_roll_snapshot_for_cycle c -> Some c | _ -> None)
(fun c -> No_roll_snapshot_for_cycle c) ;
(* Unregistered delegate *)
register_error_kind
@ -72,10 +78,13 @@ let () =
~id:"contract.manager.unregistered_delegate"
~title:"Unregistered delegate"
~description:"A contract cannot be delegated to an unregistered delegate"
~pp:(fun ppf k->
Format.fprintf ppf "The provided public key (with hash %a) is \
\ not registered as valid delegate key."
Signature.Public_key_hash.pp k)
~pp:(fun ppf k ->
Format.fprintf
ppf
"The provided public key (with hash %a) is not registered as valid \
delegate key."
Signature.Public_key_hash.pp
k)
(obj1 (req "hash" Signature.Public_key_hash.encoding))
(function Unregistered_delegate k -> Some k | _ -> None)
(fun k -> Unregistered_delegate k)
@ -84,96 +93,109 @@ let get_contract_delegate c contract =
Storage.Contract.Delegate.get_option c contract
let delegate_pubkey ctxt delegate =
Storage.Contract.Manager.get_option ctxt
(Contract_repr.implicit_contract delegate) >>=? function
Storage.Contract.Manager.get_option
ctxt
(Contract_repr.implicit_contract delegate)
>>=? function
| None | Some (Manager_repr.Hash _) ->
fail (Unregistered_delegate delegate)
| Some (Manager_repr.Public_key pk) ->
return pk
let clear_cycle c cycle =
Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index ->
Storage.Roll.Snapshot_for_cycle.delete c cycle >>=? fun c ->
Storage.Roll.Last_for_snapshot.delete (c, cycle) index >>=? fun c ->
Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c ->
return c
Storage.Roll.Snapshot_for_cycle.get c cycle
>>=? fun index ->
Storage.Roll.Snapshot_for_cycle.delete c cycle
>>=? fun c ->
Storage.Roll.Last_for_snapshot.delete (c, cycle) index
>>=? fun c ->
Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c
let fold ctxt ~f init =
Storage.Roll.Next.get ctxt >>=? fun last ->
Storage.Roll.Next.get ctxt
>>=? fun last ->
let rec loop ctxt roll acc =
acc >>=? fun acc ->
if Roll_repr.(roll = last) then
return acc
acc
>>=? fun acc ->
if Roll_repr.(roll = last) then return acc
else
Storage.Roll.Owner.get_option ctxt roll >>=? function
Storage.Roll.Owner.get_option ctxt roll
>>=? function
| None ->
loop ctxt (Roll_repr.succ roll) (return acc)
| Some delegate ->
loop ctxt (Roll_repr.succ roll) (f roll delegate acc) in
loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
in
loop ctxt Roll_repr.first (return init)
let snapshot_rolls_for_cycle ctxt cycle =
Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun index ->
Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) >>=? fun ctxt ->
Storage.Roll.Owner.snapshot ctxt (cycle, index) >>=? fun ctxt ->
Storage.Roll.Next.get ctxt >>=? fun last ->
Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last >>=? fun ctxt ->
return ctxt
Storage.Roll.Snapshot_for_cycle.get ctxt cycle
>>=? fun index ->
Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1)
>>=? fun ctxt ->
Storage.Roll.Owner.snapshot ctxt (cycle, index)
>>=? fun ctxt ->
Storage.Roll.Next.get ctxt
>>=? fun last ->
Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
>>=? fun ctxt -> return ctxt
let freeze_rolls_for_cycle ctxt cycle =
Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun max_index ->
Storage.Seed.For_cycle.get ctxt cycle >>=? fun seed ->
Storage.Roll.Snapshot_for_cycle.get ctxt cycle
>>=? fun max_index ->
Storage.Seed.For_cycle.get ctxt cycle
>>=? fun seed ->
let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
let seq = Seed_repr.sequence rd 0l in
let selected_index =
Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int in
Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index >>=? fun ctxt ->
Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int
in
Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index
>>=? fun ctxt ->
fold_left_s
(fun ctxt index ->
if Compare.Int.(index = selected_index) then
return ctxt
if Compare.Int.(index = selected_index) then return ctxt
else
Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) >>= fun ctxt ->
Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index >>=? fun ctxt ->
return ctxt
)
Storage.Roll.Owner.delete_snapshot ctxt (cycle, index)
>>= fun ctxt ->
Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index
>>=? fun ctxt -> return ctxt)
ctxt
Misc.(0 --> (max_index - 1)) >>=? fun ctxt ->
return ctxt
Misc.(0 --> (max_index - 1))
>>=? fun ctxt -> return ctxt
(* Roll selection *)
module Random = struct
let int32_to_bytes i =
let b = MBytes.create 4 in
MBytes.set_int32 b 0 i;
b
MBytes.set_int32 b 0 i ; b
let level_random seed use level =
let position = level.Level_repr.cycle_position in
Seed_repr.initialize_new seed
[MBytes.of_string ("level "^use^":");
int32_to_bytes position]
Seed_repr.initialize_new
seed
[MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position]
let owner c kind level offset =
let cycle = level.Level_repr.cycle in
Seed_storage.for_cycle c cycle >>=? fun random_seed ->
Seed_storage.for_cycle c cycle
>>=? fun random_seed ->
let rd = level_random random_seed kind level in
let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index ->
Storage.Roll.Last_for_snapshot.get (c, cycle) index >>=? fun bound ->
Storage.Roll.Snapshot_for_cycle.get c cycle
>>=? fun index ->
Storage.Roll.Last_for_snapshot.get (c, cycle) index
>>=? fun bound ->
let rec loop sequence =
let roll, sequence = Roll_repr.random sequence ~bound in
Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll) >>=? function
| None ->
loop sequence
| Some delegate ->
return delegate in
Storage.Roll.Owner.snapshot_exists c (cycle, index) >>= fun snapshot_exists ->
fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle) >>=? fun () ->
loop sequence
let (roll, sequence) = Roll_repr.random sequence ~bound in
Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll)
>>=? function None -> loop sequence | Some delegate -> return delegate
in
Storage.Roll.Owner.snapshot_exists c (cycle, index)
>>= fun snapshot_exists ->
fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle)
>>=? fun () -> loop sequence
end
let baking_rights_owner c level ~priority =
@ -184,125 +206,153 @@ let endorsement_rights_owner c level ~slot =
let traverse_rolls ctxt head =
let rec loop acc roll =
Storage.Roll.Successor.get_option ctxt roll >>=? function
| None -> return (List.rev acc)
| Some next -> loop (next :: acc) next in
Storage.Roll.Successor.get_option ctxt roll
>>=? function
| None -> return (List.rev acc) | Some next -> loop (next :: acc) next
in
loop [head] head
let get_rolls ctxt delegate =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function
| None -> return_nil
| Some head_roll -> traverse_rolls ctxt head_roll
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll
let count_rolls ctxt delegate =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function
| None -> return 0
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None ->
return 0
| Some head_roll ->
let rec loop acc roll =
Storage.Roll.Successor.get_option ctxt roll >>=? function
| None -> return acc
| Some next -> loop (succ acc) next in
Storage.Roll.Successor.get_option ctxt roll
>>=? function None -> return acc | Some next -> loop (succ acc) next
in
loop 1 head_roll
let get_change c delegate =
Storage.Roll.Delegate_change.get_option c delegate >>=? function
| None -> return Tez_repr.zero
| Some change -> return change
Storage.Roll.Delegate_change.get_option c delegate
>>=? function None -> return Tez_repr.zero | Some change -> return change
module Delegate = struct
let fresh_roll c =
Storage.Roll.Next.get c >>=? fun roll ->
Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c ->
return (roll, c)
Storage.Roll.Next.get c
>>=? fun roll ->
Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c)
let get_limbo_roll c =
Storage.Roll.Limbo.get_option c >>=? function
Storage.Roll.Limbo.get_option c
>>=? function
| None ->
fresh_roll c >>=? fun (roll, c) ->
Storage.Roll.Limbo.init c roll >>=? fun c ->
return (roll, c)
fresh_roll c
>>=? fun (roll, c) ->
Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c)
| Some roll ->
return (roll, c)
let consume_roll_change c delegate =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate >>=? fun change ->
trace Consume_roll_change
(Lwt.return Tez_repr.(change -? tokens_per_roll)) >>=? fun new_change ->
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll))
>>=? fun new_change ->
Storage.Roll.Delegate_change.set c delegate new_change
let recover_roll_change c delegate =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate >>=? fun change ->
Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun new_change ->
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun new_change ->
Storage.Roll.Delegate_change.set c delegate new_change
let pop_roll_from_delegate c delegate =
recover_roll_change c delegate >>=? fun c ->
recover_roll_change c delegate
>>=? fun c ->
(* beginning:
delegate : roll -> successor_roll -> ...
limbo : limbo_head -> ...
*)
Storage.Roll.Limbo.get_option c >>=? fun limbo_head ->
Storage.Roll.Delegate_roll_list.get_option c delegate >>=? function
| None -> fail No_roll_for_delegate
Storage.Roll.Limbo.get_option c
>>=? fun limbo_head ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? function
| None ->
fail No_roll_for_delegate
| Some roll ->
Storage.Roll.Owner.delete c roll >>=? fun c ->
Storage.Roll.Successor.get_option c roll >>=? fun successor_roll ->
Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll >>= fun c ->
Storage.Roll.Owner.delete c roll
>>=? fun c ->
Storage.Roll.Successor.get_option c roll
>>=? fun successor_roll ->
Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll
>>= fun c ->
(* delegate : successor_roll -> ...
roll ------^
limbo : limbo_head -> ... *)
Storage.Roll.Successor.set_option c roll limbo_head >>= fun c ->
Storage.Roll.Successor.set_option c roll limbo_head
>>= fun c ->
(* delegate : successor_roll -> ...
roll ------v
limbo : limbo_head -> ... *)
Storage.Roll.Limbo.init_set c roll >>= fun c ->
Storage.Roll.Limbo.init_set c roll
>>= fun c ->
(* delegate : successor_roll -> ...
limbo : roll -> limbo_head -> ... *)
return (roll, c)
let create_roll_in_delegate c delegate delegate_pk =
consume_roll_change c delegate >>=? fun c ->
consume_roll_change c delegate
>>=? fun c ->
(* beginning:
delegate : delegate_head -> ...
limbo : roll -> limbo_successor -> ...
*)
Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun delegate_head ->
get_limbo_roll c >>=? fun (roll, c) ->
Storage.Roll.Owner.init c roll delegate_pk >>=? fun c ->
Storage.Roll.Successor.get_option c roll >>=? fun limbo_successor ->
Storage.Roll.Limbo.set_option c limbo_successor >>= fun c ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun delegate_head ->
get_limbo_roll c
>>=? fun (roll, c) ->
Storage.Roll.Owner.init c roll delegate_pk
>>=? fun c ->
Storage.Roll.Successor.get_option c roll
>>=? fun limbo_successor ->
Storage.Roll.Limbo.set_option c limbo_successor
>>= fun c ->
(* delegate : delegate_head -> ...
roll ------v
limbo : limbo_successor -> ... *)
Storage.Roll.Successor.set_option c roll delegate_head >>= fun c ->
Storage.Roll.Successor.set_option c roll delegate_head
>>= fun c ->
(* delegate : delegate_head -> ...
roll ------^
limbo : limbo_successor -> ... *)
Storage.Roll.Delegate_roll_list.init_set c delegate roll >>= fun c ->
Storage.Roll.Delegate_roll_list.init_set c delegate roll
>>= fun c ->
(* delegate : roll -> delegate_head -> ...
limbo : limbo_successor -> ... *)
return c
let ensure_inited c delegate =
Storage.Roll.Delegate_change.mem c delegate >>= function
| true -> return c
Storage.Roll.Delegate_change.mem c delegate
>>= function
| true ->
return c
| false ->
Storage.Roll.Delegate_change.init c delegate Tez_repr.zero
let is_inactive c delegate =
Storage.Contract.Inactive_delegate.mem c
(Contract_repr.implicit_contract delegate) >>= fun inactive ->
if inactive then
return inactive
Storage.Contract.Inactive_delegate.mem
c
(Contract_repr.implicit_contract delegate)
>>= fun inactive ->
if inactive then return inactive
else
Storage.Contract.Delegate_desactivation.get_option c
(Contract_repr.implicit_contract delegate) >>=? function
Storage.Contract.Delegate_desactivation.get_option
c
(Contract_repr.implicit_contract delegate)
>>=? function
| Some last_active_cycle ->
let { Level_repr.cycle = current_cycle } = Raw_context.current_level c in
let {Level_repr.cycle = current_cycle} =
Raw_context.current_level c
in
return Cycle_repr.(last_active_cycle < current_cycle)
| None ->
(* This case is only when called from `set_active`, when creating
@ -310,79 +360,101 @@ module Delegate = struct
return_false
let add_amount c delegate amount =
ensure_inited c delegate >>=? fun c ->
ensure_inited c delegate
>>=? fun c ->
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate >>=? fun change ->
Lwt.return Tez_repr.(amount +? change) >>=? fun change ->
Storage.Roll.Delegate_change.set c delegate change >>=? fun c ->
delegate_pubkey c delegate >>=? fun delegate_pk ->
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
Lwt.return Tez_repr.(amount +? change)
>>=? fun change ->
Storage.Roll.Delegate_change.set c delegate change
>>=? fun c ->
delegate_pubkey c delegate
>>=? fun delegate_pk ->
let rec loop c change =
if Tez_repr.(change < tokens_per_roll) then
return c
if Tez_repr.(change < tokens_per_roll) then return c
else
Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change ->
create_roll_in_delegate c delegate delegate_pk >>=? fun c ->
loop c change in
is_inactive c delegate >>=? fun inactive ->
if inactive then
return c
Lwt.return Tez_repr.(change -? tokens_per_roll)
>>=? fun change ->
create_roll_in_delegate c delegate delegate_pk
>>=? fun c -> loop c change
in
is_inactive c delegate
>>=? fun inactive ->
if inactive then return c
else
loop c change >>=? fun c ->
Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls ->
loop c change
>>=? fun c ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun rolls ->
match rolls with
| None ->
return c
| Some _ ->
Storage.Active_delegates_with_rolls.add c delegate >>= fun c ->
return c
Storage.Active_delegates_with_rolls.add c delegate
>>= fun c -> return c
let remove_amount c delegate amount =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
let rec loop c change =
if Tez_repr.(amount <= change)
then return (c, change)
if Tez_repr.(amount <= change) then return (c, change)
else
pop_roll_from_delegate c delegate >>=? fun (_, c) ->
Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change ->
loop c change in
Storage.Roll.Delegate_change.get c delegate >>=? fun change ->
is_inactive c delegate >>=? fun inactive ->
begin
if inactive then
return (c, change)
pop_roll_from_delegate c delegate
>>=? fun (_, c) ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun change -> loop c change
in
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
is_inactive c delegate
>>=? fun inactive ->
( if inactive then return (c, change)
else
loop c change >>=? fun (c, change) ->
Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls ->
loop c change
>>=? fun (c, change) ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun rolls ->
match rolls with
| None ->
Storage.Active_delegates_with_rolls.del c delegate >>= fun c ->
return (c, change)
Storage.Active_delegates_with_rolls.del c delegate
>>= fun c -> return (c, change)
| Some _ ->
return (c, change)
end >>=? fun (c, change) ->
Lwt.return Tez_repr.(change -? amount) >>=? fun change ->
Storage.Roll.Delegate_change.set c delegate change
return (c, change) )
>>=? fun (c, change) ->
Lwt.return Tez_repr.(change -? amount)
>>=? fun change -> Storage.Roll.Delegate_change.set c delegate change
let set_inactive ctxt delegate =
ensure_inited ctxt delegate >>=? fun ctxt ->
ensure_inited ctxt delegate
>>=? fun ctxt ->
let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change ->
Storage.Contract.Inactive_delegate.add ctxt
(Contract_repr.implicit_contract delegate) >>= fun ctxt ->
Storage.Active_delegates_with_rolls.del ctxt delegate >>= fun ctxt ->
Storage.Roll.Delegate_change.get ctxt delegate
>>=? fun change ->
Storage.Contract.Inactive_delegate.add
ctxt
(Contract_repr.implicit_contract delegate)
>>= fun ctxt ->
Storage.Active_delegates_with_rolls.del ctxt delegate
>>= fun ctxt ->
let rec loop ctxt change =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function
| None -> return (ctxt, change)
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None ->
return (ctxt, change)
| Some _roll ->
pop_roll_from_delegate ctxt delegate >>=? fun (_, ctxt) ->
Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change ->
loop ctxt change in
loop ctxt change >>=? fun (ctxt, change) ->
Storage.Roll.Delegate_change.set ctxt delegate change >>=? fun ctxt ->
return ctxt
pop_roll_from_delegate ctxt delegate
>>=? fun (_, ctxt) ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun change -> loop ctxt change
in
loop ctxt change
>>=? fun (ctxt, change) ->
Storage.Roll.Delegate_change.set ctxt delegate change
>>=? fun ctxt -> return ctxt
let set_active ctxt delegate =
is_inactive ctxt delegate >>=? fun inactive ->
is_inactive ctxt delegate
>>=? fun inactive ->
let current_cycle = (Raw_context.current_level ctxt).cycle in
let preserved_cycles = Constants_storage.preserved_cycles ctxt in
(* When the delegate is new or inactive, she will become active in
@ -390,126 +462,143 @@ module Delegate = struct
delegate to start baking. When the delegate is active, we only
give her at least `preserved_cycles` after the current cycle
before to be deactivated. *)
Storage.Contract.Delegate_desactivation.get_option ctxt
(Contract_repr.implicit_contract delegate) >>=? fun current_expiration ->
let expiration = match current_expiration with
Storage.Contract.Delegate_desactivation.get_option
ctxt
(Contract_repr.implicit_contract delegate)
>>=? fun current_expiration ->
let expiration =
match current_expiration with
| None ->
Cycle_repr.add current_cycle (1+2*preserved_cycles)
Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))
| Some current_expiration ->
let delay =
if inactive then (1+2*preserved_cycles) else 1+preserved_cycles in
let updated =
Cycle_repr.add current_cycle delay in
Cycle_repr.max current_expiration updated in
Storage.Contract.Delegate_desactivation.init_set ctxt
if inactive then 1 + (2 * preserved_cycles)
else 1 + preserved_cycles
in
let updated = Cycle_repr.add current_cycle delay in
Cycle_repr.max current_expiration updated
in
Storage.Contract.Delegate_desactivation.init_set
ctxt
(Contract_repr.implicit_contract delegate)
expiration >>= fun ctxt ->
if not inactive then
return ctxt
else begin
ensure_inited ctxt delegate >>=? fun ctxt ->
let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change ->
Storage.Contract.Inactive_delegate.del ctxt
(Contract_repr.implicit_contract delegate) >>= fun ctxt ->
delegate_pubkey ctxt delegate >>=? fun delegate_pk ->
let rec loop ctxt change =
if Tez_repr.(change < tokens_per_roll) then
return ctxt
expiration
>>= fun ctxt ->
if not inactive then return ctxt
else
Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change ->
create_roll_in_delegate ctxt delegate delegate_pk >>=? fun ctxt ->
loop ctxt change in
loop ctxt change >>=? fun ctxt ->
Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? fun rolls ->
ensure_inited ctxt delegate
>>=? fun ctxt ->
let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
Storage.Roll.Delegate_change.get ctxt delegate
>>=? fun change ->
Storage.Contract.Inactive_delegate.del
ctxt
(Contract_repr.implicit_contract delegate)
>>= fun ctxt ->
delegate_pubkey ctxt delegate
>>=? fun delegate_pk ->
let rec loop ctxt change =
if Tez_repr.(change < tokens_per_roll) then return ctxt
else
Lwt.return Tez_repr.(change -? tokens_per_roll)
>>=? fun change ->
create_roll_in_delegate ctxt delegate delegate_pk
>>=? fun ctxt -> loop ctxt change
in
loop ctxt change
>>=? fun ctxt ->
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? fun rolls ->
match rolls with
| None ->
return ctxt
| Some _ ->
Storage.Active_delegates_with_rolls.add ctxt delegate >>= fun ctxt ->
return ctxt
end
Storage.Active_delegates_with_rolls.add ctxt delegate
>>= fun ctxt -> return ctxt
end
module Contract = struct
let add_amount c contract amount =
get_contract_delegate c contract >>=? function
| None -> return c
| Some delegate ->
Delegate.add_amount c delegate amount
get_contract_delegate c contract
>>=? function
| None -> return c | Some delegate -> Delegate.add_amount c delegate amount
let remove_amount c contract amount =
get_contract_delegate c contract >>=? function
| None -> return c
get_contract_delegate c contract
>>=? function
| None ->
return c
| Some delegate ->
Delegate.remove_amount c delegate amount
end
let init ctxt =
Storage.Roll.Next.init ctxt Roll_repr.first
let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first
let init_first_cycles ctxt =
let preserved = Constants_storage.preserved_cycles ctxt in
(* Precompute rolls for cycle (0 --> preserved_cycles) *)
List.fold_left
(fun ctxt c ->
ctxt >>=? fun ctxt ->
ctxt
>>=? fun ctxt ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt ->
freeze_rolls_for_cycle ctxt cycle)
(return ctxt) (0 --> preserved) >>=? fun ctxt ->
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle
>>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle)
(return ctxt)
(0 --> preserved)
>>=? fun ctxt ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
(* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt ->
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle
>>=? fun ctxt ->
(* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
return ctxt
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt -> return ctxt
let snapshot_rolls ctxt =
let current_level = Raw_context.current_level ctxt in
let preserved = Constants_storage.preserved_cycles ctxt in
let cycle = Cycle_repr.add current_level.cycle (preserved+2) in
let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in
snapshot_rolls_for_cycle ctxt cycle
let cycle_end ctxt last_cycle =
let preserved = Constants_storage.preserved_cycles ctxt in
begin
match Cycle_repr.sub last_cycle preserved with
| None -> return ctxt
| Some cleared_cycle ->
clear_cycle ctxt cleared_cycle
end >>=? fun ctxt ->
let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved+1) in
freeze_rolls_for_cycle ctxt frozen_roll_cycle >>=? fun ctxt ->
Storage.Roll.Snapshot_for_cycle.init
ctxt (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0 >>=? fun ctxt ->
( match Cycle_repr.sub last_cycle preserved with
| None ->
return ctxt
| Some cleared_cycle ->
clear_cycle ctxt cleared_cycle )
>>=? fun ctxt ->
let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in
freeze_rolls_for_cycle ctxt frozen_roll_cycle
>>=? fun ctxt ->
Storage.Roll.Snapshot_for_cycle.init
ctxt
(Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle))
0
>>=? fun ctxt -> return ctxt
let update_tokens_per_roll ctxt new_tokens_per_roll =
let constants = Raw_context.constants ctxt in
let old_tokens_per_roll = constants.tokens_per_roll in
Raw_context.patch_constants ctxt begin fun constants ->
{ constants with Constants_repr.tokens_per_roll = new_tokens_per_roll }
end >>= fun ctxt ->
Raw_context.patch_constants ctxt (fun constants ->
{constants with Constants_repr.tokens_per_roll = new_tokens_per_roll})
>>= fun ctxt ->
let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in
begin
if decrease then
( if decrease then
Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll)
else
Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll)
end >>=? fun abs_diff ->
Storage.Delegates.fold ctxt (Ok ctxt) begin fun pkh ctxt ->
Lwt.return ctxt >>=? fun ctxt ->
count_rolls ctxt pkh >>=? fun rolls ->
Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls) >>=? fun amount ->
if decrease then
Delegate.add_amount ctxt pkh amount
else
Delegate.remove_amount ctxt pkh amount
end
else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) )
>>=? fun abs_diff ->
Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt ->
Lwt.return ctxt
>>=? fun ctxt ->
count_rolls ctxt pkh
>>=? fun rolls ->
Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls)
>>=? fun amount ->
if decrease then Delegate.add_amount ctxt pkh amount
else Delegate.remove_amount ctxt pkh amount)

74
vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli vendored
View File

@ -37,68 +37,96 @@ type error +=
| Consume_roll_change
| No_roll_for_delegate
| No_roll_snapshot_for_cycle of Cycle_repr.t
| Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *)
| Unregistered_delegate of Signature.Public_key_hash.t
(* `Permanent *)
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t
val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t
val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t
val fold :
Raw_context.t ->
f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) ->
'a -> 'a tzresult Lwt.t
'a ->
'a tzresult Lwt.t
val baking_rights_owner :
Raw_context.t -> Level_repr.t -> priority:int ->
Raw_context.t ->
Level_repr.t ->
priority:int ->
Signature.Public_key.t tzresult Lwt.t
val endorsement_rights_owner :
Raw_context.t -> Level_repr.t -> slot:int ->
Raw_context.t ->
Level_repr.t ->
slot:int ->
Signature.Public_key.t tzresult Lwt.t
module Delegate : sig
val is_inactive :
Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
val add_amount :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
Raw_context.t ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val remove_amount :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
Raw_context.t ->
Signature.Public_key_hash.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val set_inactive : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t
val set_active : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t
val set_inactive :
Raw_context.t ->
Signature.Public_key_hash.t ->
Raw_context.t tzresult Lwt.t
val set_active :
Raw_context.t ->
Signature.Public_key_hash.t ->
Raw_context.t tzresult Lwt.t
end
module Contract : sig
val add_amount :
Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
Raw_context.t ->
Contract_repr.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val remove_amount :
Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
Raw_context.t ->
Contract_repr.t ->
Tez_repr.t ->
Raw_context.t tzresult Lwt.t
end
val delegate_pubkey:
Raw_context.t -> Signature.Public_key_hash.t ->
val delegate_pubkey :
Raw_context.t ->
Signature.Public_key_hash.t ->
Signature.Public_key.t tzresult Lwt.t
val get_rolls:
Raw_context.t -> Signature.Public_key_hash.t -> Roll_repr.t list tzresult Lwt.t
val get_change:
val get_rolls :
Raw_context.t ->
Signature.Public_key_hash.t ->
Roll_repr.t list tzresult Lwt.t
val get_change :
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t
val update_tokens_per_roll:
val update_tokens_per_roll :
Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
(**/**)
val get_contract_delegate:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t
val get_contract_delegate :
Raw_context.t ->
Contract_repr.t ->
Signature.Public_key_hash.t option tzresult Lwt.t

10
vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml vendored
View File

@ -25,12 +25,16 @@
let script_expr_hash = "\013\044\064\027" (* expr(54) *)
include Blake2B.Make(Base58)(struct
include Blake2B.Make
(Base58)
(struct
let name = "script_expr"
let title = "A script expression ID"
let b58check_prefix = script_expr_hash
let size = None
end)
let () =
Base58.check_encoded_prefix b58check_encoding "expr" 54
let () = Base58.check_encoded_prefix b58check_encoding "expr" 54

27
vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml vendored
View File

@ -24,28 +24,37 @@
(*****************************************************************************)
type n = Natural_tag
type z = Integer_tag
type 't num = Z.t
let compare x y = Z.compare x y
let zero = Z.zero
let zero_n = Z.zero
let to_string x = Z.to_string x
let of_string s = try Some (Z.of_string s) with _ -> None
let to_int64 x = try Some (Z.to_int64 x) with _ -> None
let of_int64 n = Z.of_int64 n
let to_int x = try Some (Z.to_int x) with _ -> None
let of_int n = Z.of_int n
let of_zint x = x
let to_zint x = x
let add x y = Z.add x y
let sub x y = Z.sub x y
let mul x y = Z.mul x y
let ediv x y =
@ -55,33 +64,39 @@ let ediv x y =
with _ -> None
let add_n = add
let mul_n = mul
let ediv_n = ediv
let abs x = Z.abs x
let is_nat x =
if Compare.Z.(x < Z.zero) then None else Some x
let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x
let neg x = Z.neg x
let int x = x
let shift_left x y =
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then
None
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
else
let y = Z.to_int y in
Some (Z.shift_left x y)
let shift_right x y =
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then
None
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
else
let y = Z.to_int y in
Some (Z.shift_right x y)
let shift_left_n = shift_left
let shift_right_n = shift_right
let logor x y = Z.logor x y
let logxor x y = Z.logxor x y
let logand x y = Z.logand x y
let lognot x = Z.lognot x

4
vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli vendored
View File

@ -81,7 +81,7 @@ val mul_n : n num -> n num -> n num
(** Euclidean division between naturals.
[ediv_n n d] returns [None] if divisor is zero,
or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *)
val ediv_n: n num -> n num -> (n num * n num) option
val ediv_n : n num -> n num -> (n num * n num) option
(** Sign agnostic addition.
Use {!add_n} when working with naturals to preserve the sign. *)
@ -99,7 +99,7 @@ val mul : _ num -> _ num -> z num
[ediv n d] returns [None] if divisor is zero,
or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise.
Use {!ediv_n} when working with naturals to preserve the sign. *)
val ediv: _ num -> _ num -> (z num * n num) option
val ediv : _ num -> _ num -> (z num * n num) option
(** Compute the absolute value of a relative, turning it into a natural. *)
val abs : z num -> n num

1824
vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml vendored
View File

File diff suppressed because it is too large Load Diff

Some files were not shown because too many files have changed in this diff Show More