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

Alpha: classify and document qty errors.

Browse Source
This commit is contained in:
Benjamin Canou 2017-03-10 14:39:22 +01:00
parent 9caef6fae4
commit 259972a3dd
7 changed files with 159 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/proto/alpha/bootstrap_storage.ml
View File

@ -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

4
src/proto/alpha/mining.ml
View File

@ -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 =

178
src/proto/alpha/qty_repr.ml
View File

@ -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

29
src/proto/alpha/roll_storage.ml
View File

@ -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 ->

4
src/proto/alpha/script_interpreter.ml
View File

@ -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 -----------------------------------------------------*)

2
src/proto/alpha/tez_repr.ml
View File

@ -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

7
src/proto/alpha/tezos_context.mli
View File

@ -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