From 259972a3dd808cf078926617834ecaf77a07f787 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Fri, 10 Mar 2017 14:39:22 +0100 Subject: [PATCH] Alpha: classify and document qty errors. --- src/proto/alpha/bootstrap_storage.ml | 4 +- src/proto/alpha/mining.ml | 4 +- src/proto/alpha/qty_repr.ml | 178 +++++++++++++++++++------- src/proto/alpha/roll_storage.ml | 29 ++--- src/proto/alpha/script_interpreter.ml | 4 +- src/proto/alpha/tez_repr.ml | 2 +- src/proto/alpha/tezos_context.mli | 7 +- 7 files changed, 159 insertions(+), 69 deletions(-) diff --git a/src/proto/alpha/bootstrap_storage.ml b/src/proto/alpha/bootstrap_storage.ml index c5588cdd4..6a57de564 100644 --- a/src/proto/alpha/bootstrap_storage.ml +++ b/src/proto/alpha/bootstrap_storage.ml @@ -59,13 +59,13 @@ let refill ctxt = of tokens. *) let accounts = accounts ctxt in let min_balance = - Tez_repr.(total / 2L / (Int64.of_int (List.length accounts))) in + Tez_repr.(total /? 2L >>? fun r -> r /? (Int64.of_int (List.length accounts))) in fold_left_s (fun ctxt account -> let contract = Contract_repr.default_contract account.public_key_hash in Contract_storage.get_balance ctxt contract >>=? fun balance -> - match Tez_repr.(min_balance -? balance) with + match Tez_repr.(min_balance >>? fun r -> r -? balance) with | Error _ -> return ctxt | Ok tez -> Contract_storage.credit ctxt contract tez) ctxt diff --git a/src/proto/alpha/mining.ml b/src/proto/alpha/mining.ml index 8cc281238..dd0a2008c 100644 --- a/src/proto/alpha/mining.ml +++ b/src/proto/alpha/mining.ml @@ -111,8 +111,8 @@ type error += Incorect_priority let endorsement_reward ~block_priority:prio = if Compare.Int32.(prio >= 0l) then - return - Tez.(Constants.endorsement_reward / (Int64.(succ (of_int32 prio)))) + Lwt.return + Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int32 prio)))) else fail Incorect_priority let mining_priorities c level = diff --git a/src/proto/alpha/qty_repr.ml b/src/proto/alpha/qty_repr.ml index 032501a31..81cd1d654 100644 --- a/src/proto/alpha/qty_repr.ml +++ b/src/proto/alpha/qty_repr.ml @@ -7,57 +7,72 @@ (* *) (**************************************************************************) -module type QTY = - sig - val id:string - end +module type QTY = sig + val id : string +end -module type S = - sig - type qty - val id : string - val zero : qty - val ( - ) : qty -> qty -> qty option - val ( -? ) : qty -> qty -> qty tzresult - val ( +? ) : qty -> qty -> qty tzresult - val ( *? ) : qty -> int64 -> qty tzresult - val ( / ) : qty -> int64 -> qty - val to_cents : qty -> int64 +module type S = sig + type qty - (** [of_cents n] is None if n is negative *) - val of_cents : int64 -> qty option + type error += + | Addition_overflow of qty * qty (* `Temporary *) + | Substraction_underflow of qty * qty (* `Temporary *) + | Multiplication_overflow of qty * int64 (* `Temporary *) + | Negative_multiplicator of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 (* `Temporary *) - (** [of_cents_exn n] fails if n is negative. - It should only be used at toplevel for constants. *) - val of_cents_exn : int64 -> qty + val id : string + val zero : qty + val one_cent : qty + val fifty_cents : qty + val one : qty - (** It should only be used at toplevel for constants. *) - val add_exn : qty -> qty -> qty + val ( -? ) : qty -> qty -> qty tzresult + val ( +? ) : qty -> qty -> qty tzresult + val ( *? ) : qty -> int64 -> qty tzresult + val ( /? ) : qty -> int64 -> qty tzresult - val encoding : qty Data_encoding.t + val to_cents : qty -> int64 - val to_int64 : qty -> int64 + (** [of_cents n] is None if n is negative *) + val of_cents : int64 -> qty option - include Compare.S with type t := qty + (** [of_cents_exn n] fails if n is negative. + It should only be used at toplevel for constants. *) + val of_cents_exn : int64 -> qty - val pp: Format.formatter -> qty -> unit + (** It should only be used at toplevel for constants. *) + val add_exn : qty -> qty -> qty - val of_string: string -> qty option - val to_string: qty -> string + val encoding : qty Data_encoding.t - end + val to_int64 : qty -> int64 -type error += - | Qty_overflow - | Negative_qty - | Negative_qty_multiplicator + include Compare.S with type t := qty + + val pp: Format.formatter -> qty -> unit + + val of_string: string -> qty option + val to_string: qty -> string + +end module Make (T: QTY) : S = struct type qty = int64 (* invariant: positive *) + type error += + | Addition_overflow of qty * qty (* `Temporary *) + | Substraction_underflow of qty * qty (* `Temporary *) + | Multiplication_overflow of qty * int64 (* `Temporary *) + | Negative_multiplicator of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 (* `Temporary *) + include Compare.Int64 let zero = 0L + let one_cent = 1L + let fifty_cents = 50L + let one = 100L let id = T.id let of_cents t = @@ -123,13 +138,13 @@ module Make (T: QTY) : S = struct let (-?) t1 t2 = match t1 - t2 with - | None -> error Negative_qty + | None -> error (Substraction_underflow (t1, t2)) | Some v -> ok v let (+?) t1 t2 = let t = Int64.add t1 t2 in if t < t1 - then error Qty_overflow + then error (Addition_overflow (t1, t2)) else ok t let ( *? ) t m = @@ -137,21 +152,27 @@ module Make (T: QTY) : S = struct let open Int64 in let rec step cur pow acc = if cur = 0L then - ok acc + ok acc else - pow +? pow >>? fun npow -> - if logand cur 1L = 1L then + 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 + else + step (shift_right_logical cur 1) npow acc in if m < 0L then - error Negative_qty_multiplicator + error (Negative_multiplicator (t, m)) else - step m t 0L + match step m t 0L with + | Ok res -> Ok res + | Error ([ Addition_overflow _ ] as errs) -> + Error (Multiplication_overflow (t, m) :: errs) - let (/) t1 t2 = Int64.div t1 t2 + let ( /? ) 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 @@ -174,4 +195,73 @@ module Make (T: QTY) : S = struct ~title: "Amount in centiles" (conv to_int64 (Json.wrap_error of_cents_exn) int64) + let () = + let open Data_encoding in + register_error_kind + `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") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Addition_overflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Addition_overflow (a, b)) ; + register_error_kind + `Temporary + ~id:(T.id ^ ".substraction_underflow") + ~title:("Underflowing " ^ T.id ^ " substraction") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Underflowing substraction of %a %s and %a %s" + pp opa T.id pp opb T.id) + ~description: + ("An substraction of two " ^ T.id ^ " amounts underflowed") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Substraction_underflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Substraction_underflow (a, b)) ; + register_error_kind + `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) + ~description: + ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed") + (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) + ~description: + ("Multiplication of a " ^ T.id ^ " amount by a negative integer") + (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) + ~description: + ("Multiplication of a " ^ T.id ^ " amount by a non positive integer") + (obj2 + (req "amount" encoding) + (req "divisor" int64)) + (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Invalid_divisor (a, b)) + end diff --git a/src/proto/alpha/roll_storage.ml b/src/proto/alpha/roll_storage.ml index 44893e070..2a568b586 100644 --- a/src/proto/alpha/roll_storage.ml +++ b/src/proto/alpha/roll_storage.ml @@ -104,10 +104,9 @@ module Contract = struct let consume_roll_change c contract = Storage.Roll.Contract_change.get c contract >>=? fun change -> - match Tez_repr.(change - Constants_repr.roll_value) with - | None -> fail Consume_roll_change - | Some new_change -> - Storage.Roll.Contract_change.set c contract new_change + trace Consume_roll_change + (Lwt.return Tez_repr.(change -? Constants_repr.roll_value)) >>=? fun new_change -> + Storage.Roll.Contract_change.set c contract new_change let recover_roll_change c contract = Storage.Roll.Contract_change.get c contract >>=? fun change -> @@ -170,28 +169,26 @@ module Contract = struct Lwt.return Tez_repr.(amount +? change) >>=? fun change -> Storage.Roll.Contract_change.set c contract change >>=? fun c -> let rec loop c change = - match Tez_repr.(change - Constants_repr.roll_value) with - | None -> Lwt.return (Ok c) - | Some change -> - create_roll_in_contract c contract >>=? fun c -> - loop c change in + if Tez_repr.(change < Constants_repr.roll_value) then + return c + else + Lwt.return Tez_repr.(change -? Constants_repr.roll_value) >>=? fun change -> + create_roll_in_contract c contract >>=? fun c -> + loop c change in loop c change let remove_amount c contract amount = let rec loop c change = if Tez_repr.(amount <= change) - then Lwt.return (Ok (c, change)) + then return (c, change) else pop_roll_from_contract c contract >>=? fun (_, c) -> Lwt.return Tez_repr.(change +? Constants_repr.roll_value) >>=? fun change -> - loop c change - in + loop c change in Storage.Roll.Contract_change.get c contract >>=? fun change -> loop c change >>=? fun (c, change) -> - match Tez_repr.(change - amount) with - | None -> assert false - | Some change -> - Storage.Roll.Contract_change.set c contract change + Lwt.return Tez_repr.(change -? amount) >>=? fun change -> + Storage.Roll.Contract_change.set c contract change let assert_empty c contract = Storage.Roll.Contract_change.get c contract >>=? fun change -> diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index 01cdf880f..0e8db053c 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -13,8 +13,8 @@ open Script open Script_typed_ir open Script_ir_translator -let dummy_code_fee = Tez.zero -let dummy_storage_fee = Tez.zero +let dummy_code_fee = Tez.fifty_cents +let dummy_storage_fee = Tez.fifty_cents (* ---- Run-time errors -----------------------------------------------------*) diff --git a/src/proto/alpha/tez_repr.ml b/src/proto/alpha/tez_repr.ml index 38576fa10..ecd77f62d 100644 --- a/src/proto/alpha/tez_repr.ml +++ b/src/proto/alpha/tez_repr.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -include Qty_repr.Make (struct let id="tez" end) +include Qty_repr.Make (struct let id = "tez" end) type t = qty type tez = qty diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 793ae2f37..e0f4c96a0 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -32,11 +32,14 @@ module Tez : sig type tez = t val zero: tez - val ( - ) : tez -> tez -> tez option + val one_cent : tez + val fifty_cents : tez + val one : tez + val ( -? ) : tez -> tez -> tez tzresult val ( +? ) : tez -> tez -> tez tzresult val ( *? ) : tez -> int64 -> tez tzresult - val ( / ) : tez -> int64 -> tez + val ( /? ) : tez -> int64 -> tez tzresult val of_string: string -> tez option val to_string: tez -> string