diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 0f2d2aa13ead76e789d4eed05221b2524db41411..e0b8096ea9f7462c25ffdf6329e188eb0f955a4a 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -65,6 +65,7 @@ "Vote_storage", "Commitment_storage", "Fees_storage", + "Ticket_storage", "Liquidity_baking_repr", "Liquidity_baking_cpmm", "Liquidity_baking_lqt", diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index b4c0654bf0eda90f85d763375803db0be1cb3ddb..189e37f7d219030bd07852de9d1f5c0d11261de6 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -548,3 +548,7 @@ module Cache = struct let identifier_rank ctxt id = Admin.key_rank ctxt (mk ~id) end) end + +module Ticket_balance = struct + include Ticket_storage +end diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 39bb91900b608f6de7dd14264649aaf860b209dc..9e6186a3f2ce6004d7766d027ea33588139b934b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3,6 +3,7 @@ (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) (* Copyright (c) 2019-2021 Nomadic Labs *) +(* Copyright (c) 2021 Trili Tech, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -2084,3 +2085,25 @@ module Liquidity_baking : sig (context -> Contract.t -> (context * 'a list) tzresult Lwt.t) -> (context * 'a list * escape_ema) tzresult Lwt.t end + +(** This module re-exports functions from [Ticket_storage]. See + documentation of the functions there. + *) +module Ticket_balance : sig + type key_hash + + val script_expr_hash_of_key_hash : key_hash -> Script_expr_hash.t + + val make_key_hash : + context -> + ticketer:Script.node -> + typ:Script.node -> + contents:Script.node -> + owner:Script.node -> + (key_hash * context) tzresult + + val adjust_balance : + context -> key_hash -> delta:Z.t -> (Z.t * context) tzresult Lwt.t + + val get_balance : context -> key_hash -> (Z.t option * context) tzresult Lwt.t +end diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index c01d88500d16fadb800577391c92ec54eaa75091..588b53411e540247b5ea08c1158cb25743bb26dc 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -88,6 +88,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml fees_storage.mli fees_storage.ml + ticket_storage.mli ticket_storage.ml liquidity_baking_repr.mli liquidity_baking_repr.ml liquidity_baking_cpmm.ml liquidity_baking_lqt.ml @@ -193,6 +194,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml fees_storage.mli fees_storage.ml + ticket_storage.mli ticket_storage.ml liquidity_baking_repr.mli liquidity_baking_repr.ml liquidity_baking_cpmm.ml liquidity_baking_lqt.ml @@ -298,6 +300,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml fees_storage.mli fees_storage.ml + ticket_storage.mli ticket_storage.ml liquidity_baking_repr.mli liquidity_baking_repr.ml liquidity_baking_cpmm.ml liquidity_baking_lqt.ml @@ -425,6 +428,7 @@ include Tezos_raw_protocol_alpha.Main Vote_storage Commitment_storage Fees_storage + Ticket_storage Liquidity_baking_repr Liquidity_baking_cpmm Liquidity_baking_lqt @@ -569,6 +573,7 @@ include Tezos_raw_protocol_alpha.Main vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml fees_storage.mli fees_storage.ml + ticket_storage.mli ticket_storage.ml liquidity_baking_repr.mli liquidity_baking_repr.ml liquidity_baking_cpmm.ml liquidity_baking_lqt.ml diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index eaab9bcb047d9e36c4e80f238e3daafdb970446a..8af81826d060a63de6803bfa8fc86114469c3041 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1327,3 +1327,14 @@ module Liquidity_baking = struct end) (Contract_repr) end + +module Ticket_balance = struct + module Name = struct + let name = ["ticket_balance"] + end + + module Sub_context = Make_subcontext (Registered) (Raw_context) (Name) + module Index = Make_index (Script_expr_hash) + module Table = + Make_indexed_carbonated_data_storage (Sub_context) (Index) (Encoding.Z) +end diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index ac28bdc722ddd7bd22f4f240fe006e431666eb13..c05f73959eab4222ae6f8eae355887832880970a 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -530,3 +530,19 @@ module Global_constants : sig and type key = Script_expr_hash.t and type value = Script_repr.expr end + +(** This module exposes a balance table for tracking ticket ownership. + The table is a mapping from keys to values where the keys consist of a + hashed representation of: + - A ticketer, i.e. the creator of the ticket + - The content of a the ticket + - The contract that owns some amount of the ticket + The values of the table are the amounts owned by each key. + *) +module Ticket_balance : sig + module Table : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t + and type key = Script_expr_hash.t + and type value = Z.t +end diff --git a/src/proto_alpha/lib_protocol/test/main.ml b/src/proto_alpha/lib_protocol/test/main.ml index bd6fe5bb572da52244ca73a0e778978ab756baf4..3b568a27fb2779a74eecbb7cf0e655959668a66f 100644 --- a/src/proto_alpha/lib_protocol/test/main.ml +++ b/src/proto_alpha/lib_protocol/test/main.ml @@ -68,5 +68,6 @@ let () = ("temp big maps", Test_temp_big_maps.tests); ("timelock", Test_timelock.tests); ("script typed ir size", Test_script_typed_ir_size.tests); + ("ticket storage", Test_ticket_storage.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/test_ticket_storage.ml b/src/proto_alpha/lib_protocol/test/test_ticket_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..16801bdca0cb6e9adfd33c50fcad294b6fe7bd4b --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/test_ticket_storage.ml @@ -0,0 +1,288 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (Alpha_context.Ticket_balance) + Invocation: dune exec src/proto_alpha/lib_protocol/test/main.exe -- test "^ticket storage$" + Subject: Ticket storage functions tested using the Ticket_balance module in Alpha_context. +*) + +open Protocol +open Alpha_context + +let ( let* ) m f = m >>=? f + +let wrap m = m >|= Environment.wrap_tzresult + +let make_context () = + let* (block, _) = Context.init 1 in + let* incr = Incremental.begin_construction block in + return (Fees.start_counting_storage_fees @@ Incremental.alpha_ctxt incr) + +let hash_key ctxt ~ticketer ~typ ~contents ~owner = + let ticketer = Micheline.root @@ Expr.from_string ticketer in + let typ = Micheline.root @@ Expr.from_string typ in + let contents = Micheline.root @@ Expr.from_string contents in + let owner = Micheline.root @@ Expr.from_string owner in + wrap + @@ Lwt.return + (Alpha_context.Ticket_balance.make_key_hash + ctxt + ~ticketer + ~typ + ~contents + ~owner) + +let assert_balance ctxt ~loc key expected = + let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + match balance with + | Some b -> Assert.equal_int ~loc (Z.to_int b) expected + | None -> failwith "Expected balance %d" expected + +let assert_no_balance ctxt key = + let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + match balance with + | Some b -> failwith "Expected empty (none) balance but got %d" (Z.to_int b) + | None -> return () + +let adjust_balance ctxt key delta = + wrap @@ Ticket_balance.adjust_balance ctxt key ~delta:(Z.of_int delta) + +let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 + ~typ1 ~typ2 ~owner1 ~owner2 = + let* ctxt = make_context () in + let* (k1, ctxt) = + hash_key + ctxt + ~ticketer:ticketer1 + ~typ:typ1 + ~contents:contents1 + ~owner:owner1 + in + let* (k2, _ctxt) = + hash_key + ctxt + ~ticketer:ticketer2 + ~typ:typ2 + ~contents:contents2 + ~owner:owner2 + in + let k1 = Ticket_balance.script_expr_hash_of_key_hash k1 in + let k2 = Ticket_balance.script_expr_hash_of_key_hash k2 in + Assert.not_equal + ~loc + Script_expr_hash.equal + "Keys should not overlap" + Script_expr_hash.pp + k1 + k2 + +let make_key ctxt content = + hash_key + ctxt + ~ticketer:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~typ:"string" + ~contents:(Printf.sprintf {|"%s"|} content) + ~owner:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + +(** Test that key-hashes constructed from different ticketers don't overlap. *) +let test_non_overlapping_keys_ticketer () = + assert_non_overlapping_keys + ~loc:__LOC__ + ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~ticketer2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} + ~typ1:"nat" + ~typ2:"int" + ~contents1:{|"1"|} + ~contents2:{|"1"|} + ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~owner2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} + +(** Test that key-hashes constructed from different contents don't overlap. *) +let test_non_overlapping_keys_contents () = + assert_non_overlapping_keys + ~loc:__LOC__ + ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~typ1:"string" + ~typ2:"string" + ~contents1:{|"red"|} + ~contents2:{|"blue"|} + ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~owner2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + +(** Test that key-hashes constructed from different content-types don't overlap. *) +let test_non_overlapping_keys_type () = + assert_non_overlapping_keys + ~loc:__LOC__ + ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~typ1:"nat" + ~typ2:"int" + ~contents1:{|"1"|} + ~contents2:{|"1"|} + ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~owner2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + +(** Test that key-hashes constructed from different owners don't overlap. *) +let test_non_overlapping_keys_owner () = + assert_non_overlapping_keys + ~loc:__LOC__ + ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~typ1:"nat" + ~typ2:"int" + ~contents1:{|"1"|} + ~contents2:{|"1"|} + ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} + ~owner2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} + +(** Test that updating the ticket balance table has + the intended effect. + *) +let test_ticket_balance_single_update () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + assert_balance ctxt ~loc:__LOC__ alice_red 1 + +(** Test that updating the ticket-balance table with different keys + updates both entries. *) +let test_ticket_balance_different_owners () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* (alice_blue, ctxt) = make_key ctxt "alice_blue" in + let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* (_, ctxt) = adjust_balance ctxt alice_blue 1 in + let* () = assert_balance ctxt ~loc:__LOC__ alice_red 1 in + let* () = assert_balance ctxt ~loc:__LOC__ alice_blue 1 in + return () + +(** Test updating the same entry with multiple updates yields + the net result of all balance updates *) +let test_ticket_balance_multiple_updates () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* (_, ctxt) = adjust_balance ctxt alice_red 2 in + let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + assert_balance ctxt ~loc:__LOC__ alice_red 2 + +(** Test that with no updates to the table, no balance is present in + the table *) +let test_empty_balance () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + assert_no_balance ctxt alice_red + +(** Test that adding one entry with positive balance and then + updating with a negative balance also removes the entry *) +let test_empty_balance_after_update () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + assert_no_balance ctxt alice_red + +(** Test that attempting to update an entry with a negative balance + results in an error. *) +let test_negative_balance () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + adjust_balance ctxt alice_red (-1) >>= fun res -> + Assert.proto_error ~loc:__LOC__ res (fun _err -> true) + +(** Test that positive storage spaces are returned for operations + resulting in extra storage space and negative for ones that frees up storage. + *) +let test_storage_space () = + let* ctxt = make_context () in + let* (alice_red, ctxt) = make_key ctxt "alice_red" in + (* Space for adding an entry is 65 for the key plus 1 for the value. *) + let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* () = Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) in + (* Adding one does not consume additional space. *) + let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in + (* Adding a big balance costs extra. *) + let* (space, ctxt) = adjust_balance ctxt alice_red 1000 in + let* () = Assert.equal_int ~loc:__LOC__ 1 (Z.to_int space) in + (* Reset balance to zero should free up space. + The freed up space is 65 for the key + 2 for the value *) + let* (b, ctxt) = wrap @@ Ticket_balance.get_balance ctxt alice_red in + let* (space, ctxt) = + wrap + (Ticket_balance.adjust_balance + ctxt + alice_red + ~delta:(Z.neg @@ Option.value ~default:Z.zero b)) + in + let* () = Assert.equal_int ~loc:__LOC__ (-67) (Z.to_int space) in + (* Adjusting the space to 0 again should not free anything *) + let* (space, ctxt) = adjust_balance ctxt alice_red 0 in + let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in + (* Adding a balance requiers extra space. *) + let* (space, _) = adjust_balance ctxt alice_red 10 in + Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) + +let tests = + [ + Tztest.tztest + "no overlapping keys for ticketer" + `Quick + test_non_overlapping_keys_ticketer; + Tztest.tztest + "no overlapping keys for content" + `Quick + test_non_overlapping_keys_contents; + Tztest.tztest + "no overlapping keys for content type" + `Quick + test_non_overlapping_keys_type; + Tztest.tztest + "no overlapping keys for owner" + `Quick + test_non_overlapping_keys_owner; + Tztest.tztest + "ticket balance single update" + `Quick + test_ticket_balance_single_update; + Tztest.tztest "empty balance" `Quick test_empty_balance; + Tztest.tztest + "empty balance after update" + `Quick + test_empty_balance_after_update; + Tztest.tztest "negative balance" `Quick test_negative_balance; + Tztest.tztest + "ticket balance multiple updates" + `Quick + test_ticket_balance_multiple_updates; + Tztest.tztest + "ticket balance different owners" + `Quick + test_ticket_balance_different_owners; + Tztest.tztest "ticket storage space" `Quick test_storage_space; + ] diff --git a/src/proto_alpha/lib_protocol/ticket_storage.ml b/src/proto_alpha/lib_protocol/ticket_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..4fad95fcd5d41faf1d7dbac6dd41fb6f6c83cfc8 --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_storage.ml @@ -0,0 +1,118 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type key_hash = Script_expr_hash.t + +type error += + | Negative_ticket_balance of {key : Script_expr_hash.t; balance : Z.t} + | Failed_to_hash_node + +let script_expr_hash_of_key_hash key_hash = key_hash + +let hash_bytes_cost bytes = + let module S = Saturation_repr in + let ( + ) = S.add in + let v0 = S.safe_int @@ Bytes.length bytes in + let ( lsr ) = S.shift_right in + S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost + +let hash_of_node ctxt node = + Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) + >>? fun ctxt -> + let node = Micheline.strip_locations node in + match Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node with + | Some bytes -> + Raw_context.consume_gas ctxt (hash_bytes_cost bytes) >|? fun ctxt -> + (Script_expr_hash.hash_bytes [bytes], ctxt) + | None -> error Failed_to_hash_node + +let make_key_hash ctxt ~ticketer ~typ ~contents ~owner = + hash_of_node ctxt @@ Micheline.Seq (0, [ticketer; typ; contents; owner]) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"Negative_ticket_balance" + ~title:"Negative ticket balance" + ~description:"Attempted to set a negative ticket balance value" + ~pp:(fun ppf (key, balance) -> + Format.fprintf + ppf + "Attempted to set negative ticket balance value '%a' for key %a." + Z.pp_print + balance + Script_expr_hash.pp + key) + (obj2 (req "key" Script_expr_hash.encoding) (req "balance" Data_encoding.z)) + (function + | Negative_ticket_balance {key; balance} -> Some (key, balance) + | _ -> None) + (fun (key, balance) -> Negative_ticket_balance {key; balance}) ; + register_error_kind + `Branch + ~id:"Failed_to_hash_node" + ~title:"Failed to hash node" + ~description:"Failed to hash node for a key in the ticket-balance table" + ~pp:(fun ppf () -> + Format.fprintf + ppf + "Failed to hash node for a key in the ticket-balance table") + Data_encoding.empty + (function Failed_to_hash_node -> Some () | _ -> None) + (fun () -> Failed_to_hash_node) + +let get_balance ctxt key = + Storage.Ticket_balance.Table.find ctxt key >|=? fun (ctxt, res) -> (res, ctxt) + +let set_balance ctxt key balance = + let cost_of_key = Z.of_int 65 in + fail_when + Compare.Z.(balance < Z.zero) + (Negative_ticket_balance {key; balance}) + >>=? fun () -> + if Compare.Z.(balance = Z.zero) then + Storage.Ticket_balance.Table.remove ctxt key + >|=? fun (ctxt, freed, existed) -> + (* If we remove an existing entry, then we return the freed size for + both the key and the value. *) + let freed = + if existed then Z.neg @@ Z.add cost_of_key (Z.of_int freed) else Z.zero + in + (freed, ctxt) + else + Storage.Ticket_balance.Table.add ctxt key balance + >|=? fun (ctxt, size_diff, existed) -> + let size_diff = + let z_diff = Z.of_int size_diff in + (* For a new entry we also charge the space for storing the key *) + if existed then z_diff else Z.add cost_of_key z_diff + in + (size_diff, ctxt) + +let adjust_balance ctxt key ~delta = + get_balance ctxt key >>=? fun (res, ctxt) -> + let old_balance = Option.value ~default:Z.zero res in + set_balance ctxt key (Z.add old_balance delta) diff --git a/src/proto_alpha/lib_protocol/ticket_storage.mli b/src/proto_alpha/lib_protocol/ticket_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..c116eb0521771792f4288605bf76a9f032da7a03 --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_storage.mli @@ -0,0 +1,71 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** A value of type [key_hash] is a hashed combination of: + - Ticketer + - Content type + - Content + - Owner +*) +type key_hash + +(** [script_expr_hash_of_key_hash key_hash] returns a [Script_expr_hash.t] value + representation of the given [key_hash]. This is useful for comparing and + pretty-printing key-hash values. *) +val script_expr_hash_of_key_hash : key_hash -> Script_expr_hash.t + +(** [make_key_hash ctxt ~ticketer ~typ ~contents ~owner] creates a hashed + representation of the given [ticketer], [typ], [contents] and [owner]. +*) +val make_key_hash : + Raw_context.t -> + ticketer:Script_repr.node -> + typ:Script_repr.node -> + contents:Script_repr.node -> + owner:Script_repr.node -> + (key_hash * Raw_context.t) tzresult + +(** [get_balance ctxt key] receives the ticket balance for the given + [key] in the context [ctxt]. The [key] represents a ticket content and a + ticket creator pair. In case there exists no value for the given [key], + [None] is returned. + *) +val get_balance : + Raw_context.t -> key_hash -> (Z.t option * Raw_context.t) tzresult Lwt.t + +(** [adjust_balance ctxt key ~delta] adjusts the balance of the + given key (representing a ticket content, creator and owner pair) + and [delta]. The value of [delta] can be positive as well as negative. + If there is no pre-exising balance for the given ticket type and owner, + it is assumed to be 0 and the new balance is [delta]. The function also + returns the difference between the old and the new size of the storage. + Note that the difference may be negative. For example, because when + setting the balance to zero, an entry is removed. + + The function fails with a [Negative_ticket_balance] error + in case the resulting balance is negative. + *) +val adjust_balance : + Raw_context.t -> key_hash -> delta:Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t