Alphanet: let the number of rolls never reach 100000.

This is a hack! This is a possible mitigation for the 'faucet war'.

src/proto/alpha/bootstrap_storage.ml

@@ -12,8 +12,6 @@ type account = {
   public_key : Ed25519.Public_key.t ;
 }
 
-(* FIXME: when incresing wealth *10, the node is very slow to initialize...
-   this should be investigated... *)
 let wealth = Tez_repr.of_cents_exn 4_000_000_00L
 
 let init_account ctxt account =
@@ -69,4 +67,6 @@ let refill ctxt =
        | Error _ -> return ctxt
        | Ok tez -> Contract_storage.credit ctxt contract tez)
     ctxt
-    accounts
+    accounts >>=? fun c ->
+  Roll_storage.may_recompute_rolls c >>=? fun c ->
+  return c

src/proto/alpha/constants_repr.ml

@@ -12,8 +12,6 @@ let version_number = "\000"
 let proof_of_work_nonce_size = 8
 let nonce_length = 32
 
-let roll_value =
-  Tez_repr.of_cents_exn 10000_00L
 let seed_nonce_revelation_tip =
   Tez_repr.of_cents_exn 10_00L
 let origination_burn =
@@ -44,6 +42,7 @@ type constants = {
   dictator_pubkey: Ed25519.Public_key.t ;
   max_number_of_operations: int list ;
   max_operation_data_length: int ;
+  initial_roll_value: Tez_repr.t ;
 }
 
 let read_public_key s =
@@ -78,6 +77,8 @@ let default = {
     [ 300 ] ;
   max_operation_data_length =
     16 * 1024 ; (* 16kB *)
+  initial_roll_value =
+    Tez_repr.of_cents_exn 10000_00L ;
 }
 
 let opt (=) def v = if def = v then None else Some v
@@ -132,6 +133,9 @@ let constants_encoding =
        and max_operation_data_length =
          opt Compare.Int.(=)
            default.max_operation_data_length c.max_operation_data_length
+       and initial_roll_value =
+         opt Tez_repr.(=)
+           default.initial_roll_value c.initial_roll_value
        in
        ((( cycle_length,
            voting_period_length,
@@ -144,7 +148,8 @@ let constants_encoding =
            bootstrap_keys,
            dictator_pubkey),
          (max_number_of_operations,
-          max_operation_data_length)), ()) )
+          max_operation_data_length,
+          initial_roll_value)), ()) )
     (fun ((( cycle_length,
              voting_period_length,
              time_before_reward,
@@ -156,7 +161,8 @@ let constants_encoding =
              bootstrap_keys,
              dictator_pubkey),
            (max_number_of_operations,
-            max_operation_data_length)), ()) ->
+            max_operation_data_length,
+            initial_roll_value)), ()) ->
       { cycle_length =
           unopt default.cycle_length cycle_length ;
         voting_period_length =
@@ -183,6 +189,8 @@ let constants_encoding =
           unopt default.max_number_of_operations max_number_of_operations ;
         max_operation_data_length =
           unopt default.max_operation_data_length max_operation_data_length ;
+        initial_roll_value =
+          unopt default.initial_roll_value initial_roll_value ;
       } )
     Data_encoding.(
       merge_objs
@@ -198,9 +206,10 @@ let constants_encoding =
               (opt "proof_of_work_threshold" int64)
               (opt "bootstrap_keys" (list Ed25519.Public_key.encoding))
               (opt "dictator_pubkey" Ed25519.Public_key.encoding))
-           (obj2
+           (obj3
               (opt "max_number_of_operations" (list uint16))
               (opt "max_number_of_operations" int31)
+              (opt "initial_roll_value" Tez_repr.encoding)
            ))
         unit)
 

src/proto/alpha/raw_context.ml

@@ -14,6 +14,7 @@ type t = {
   level: Level_repr.t ;
   timestamp: Time.t ;
   fitness: Int64.t ;
+  roll_value: Tez_repr.t ;
 }
 type context = t
 type root_context = t
@@ -23,6 +24,7 @@ let current_timestamp ctxt = ctxt.timestamp
 let current_fitness ctxt = ctxt.fitness
 let first_level ctxt = ctxt.first_level
 let constants ctxt = ctxt.constants
+let roll_value ctxt = ctxt.roll_value
 let recover ctxt = ctxt.context
 
 let set_current_fitness ctxt fitness = { ctxt with fitness }
@@ -124,6 +126,7 @@ let is_first_block ctxt =
 
 let version = "v1"
 let first_level_key = [ version ; "first_level" ]
+let roll_value_key = [ version ; "roll_value" ]
 let sandboxed_key = [ version ; "sandboxed" ]
 
 let get_first_level ctxt =
@@ -142,6 +145,22 @@ let set_first_level ctxt level =
   Context.set ctxt first_level_key bytes >>= fun ctxt ->
   return ctxt
 
+let get_roll_value ctxt =
+  Context.get ctxt roll_value_key >>= function
+  | None -> storage_error (Missing_key (roll_value_key, `Get))
+  | Some bytes ->
+      match
+        Data_encoding.Binary.of_bytes Tez_repr.encoding bytes
+      with
+      | None -> storage_error (Corrupted_data roll_value_key)
+      | Some level -> return level
+
+let set_roll_value ctxt level =
+  let bytes =
+    Data_encoding.Binary.to_bytes Tez_repr.encoding level in
+  Context.set ctxt roll_value_key bytes >>= fun ctxt ->
+  return ctxt
+
 type error += Failed_to_parse_sandbox_parameter of MBytes.t
 
 let () =
@@ -188,16 +207,34 @@ let prepare ~level ~timestamp ~fitness ctxt =
   Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
   may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
   get_sandboxed ctxt >>=? fun sandbox ->
-  Constants_repr.read sandbox >>=? function constants ->
+  Constants_repr.read sandbox >>=? fun constants ->
-    let level =
+  begin
-      Level_repr.from_raw
+    if first_block then begin
-        ~first_level
+      set_roll_value ctxt constants.initial_roll_value >>=? fun ctxt ->
-        ~cycle_length:constants.Constants_repr.cycle_length
+      return (ctxt, constants.initial_roll_value)
-        ~voting_period_length:constants.Constants_repr.voting_period_length
+    end else begin
-        level in
+      get_roll_value ctxt >>=? fun roll_value ->
-    return ({ context = ctxt ; constants ; level ;
+      return (ctxt, roll_value)
-              timestamp ; fitness ; first_level},
+    end
-            first_block)
+  end >>=? fun (ctxt, roll_value) ->
+  let level =
+    Level_repr.from_raw
+      ~first_level
+      ~cycle_length:constants.Constants_repr.cycle_length
+      ~voting_period_length:constants.Constants_repr.voting_period_length
+      level in
+  return ({ context = ctxt ; constants ; level ;
+            timestamp ; fitness ; first_level ; roll_value ;
+          },
+          first_block)
+
+let rec double_roll_value ctxt i =
+  if Compare.Int.(i <= 0) then
+    return ctxt
+  else
+    Lwt.return Tez_repr.(ctxt.roll_value +? ctxt.roll_value) >>=? fun roll_value ->
+    set_roll_value ctxt.context roll_value >>=? fun context ->
+    double_roll_value { ctxt with context ; roll_value } (i-1)
 
 let activate ({ context = c } as s) h =
   Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
@@ -214,6 +251,7 @@ let register_resolvers enc resolve =
       level =  Level_repr.root Raw_level_repr.root ;
       timestamp = Time.of_seconds 0L ;
       fitness = 0L ;
+      roll_value = Tez_repr.zero ;
     } in
     resolve faked_context str in
   Context.register_resolver enc  resolve

src/proto/alpha/raw_context.mli

@@ -58,6 +58,7 @@ val set_current_fitness: context -> Int64.t -> t
 
 val constants: context -> Constants_repr.constants
 val first_level: context -> Raw_level_repr.t
+val roll_value: context -> Tez_repr.t
 
 (** {1 Generic accessors} *************************************************)
 
@@ -132,3 +133,6 @@ module type T = sig
 end
 
 include T with type t := t and type context := context
+
+(** HACK alphanet *)
+val double_roll_value: context -> int -> context tzresult Lwt.t

src/proto/alpha/roll_repr.ml

@@ -36,3 +36,9 @@ module Index = struct
       end
     | _ -> None
 end
+
+let rec too_many_roll next =
+  if Compare.Int32.(next < 100_000l) then
+    0
+  else
+    1 + too_many_roll (Int32.div next 2l)

src/proto/alpha/roll_repr.mli

@@ -28,3 +28,6 @@ module Index : sig
   val to_path: t -> string list -> string list
   val of_path: string list -> t option
 end
+
+(** Hack for the alphanet. *)
+val too_many_roll: t -> int

src/proto/alpha/roll_storage.ml

@@ -97,14 +97,16 @@ module Contract = struct
         return (roll, c)
 
   let consume_roll_change c contract =
+    let roll_value = Raw_context.roll_value c in
     Storage.Roll.Contract_change.get c contract >>=? fun change ->
     trace Consume_roll_change
-      (Lwt.return Tez_repr.(change -? Constants_repr.roll_value)) >>=? fun new_change ->
+      (Lwt.return Tez_repr.(change -? roll_value)) >>=? fun new_change ->
     Storage.Roll.Contract_change.set c contract new_change
 
   let recover_roll_change c contract =
+    let roll_value = Raw_context.roll_value c in
     Storage.Roll.Contract_change.get c contract >>=? fun change ->
-    Lwt.return Tez_repr.(change +? Constants_repr.roll_value) >>=? fun new_change ->
+    Lwt.return Tez_repr.(change +? roll_value) >>=? fun new_change ->
     Storage.Roll.Contract_change.set c contract new_change
 
   let pop_roll_from_contract c contract =
@@ -160,25 +162,27 @@ module Contract = struct
     Storage.Roll.Contract_change.init c contract Tez_repr.zero
 
   let add_amount c contract amount =
+    let roll_value = Raw_context.roll_value c in
     Storage.Roll.Contract_change.get c contract >>=? fun change ->
     Lwt.return Tez_repr.(amount +? change) >>=? fun change ->
     Storage.Roll.Contract_change.set c contract change >>=? fun c ->
     let rec loop c change =
-      if Tez_repr.(change < Constants_repr.roll_value) then
+      if Tez_repr.(change < roll_value) then
         return c
       else
-        Lwt.return Tez_repr.(change -? Constants_repr.roll_value) >>=? fun  change ->
+        Lwt.return Tez_repr.(change -? 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 roll_value = Raw_context.roll_value c in
     let rec loop c change =
       if Tez_repr.(amount <= 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 ->
+        Lwt.return Tez_repr.(change +? roll_value) >>=? fun change ->
         loop c change in
     Storage.Roll.Contract_change.get c contract >>=? fun change ->
     loop c change >>=? fun (c, change) ->
@@ -195,5 +199,32 @@ module Contract = struct
 
 end
 
+let value = Raw_context.roll_value
+
+(* HACK for the alphanet: let's increase the roll value when
+   the total amount of roll is greater than 100,000. *)
+let may_recompute_rolls c =
+  Storage.Roll.Next.get c >>=? fun next ->
+  let double = Roll_repr.too_many_roll next in
+  if Compare.Int.(double <= 0) then
+    return c
+  else
+    Raw_context.double_roll_value c double >>=? fun c ->
+    Storage.Roll.clear c >>= fun c ->
+    Storage.Roll.Limbo.remove c >>= fun c ->
+    Storage.Roll.Next.init_set c Roll_repr.first >>= fun c ->
+    Storage.Contract.fold c ~init:(ok c) ~f:begin fun k c ->
+      Lwt.return c >>=? fun c ->
+      Storage.Roll.Contract_roll_list.remove c k >>= fun c ->
+      Storage.Roll.Contract_change.init_set c k Tez_repr.zero >>= fun c ->
+      Storage.Contract.Balance.get c k >>=? fun balance ->
+      Contract.add_amount c k balance >>=? fun c ->
+      return c
+    end
+
+let next c =
+  Storage.Roll.Next.get c >>=? fun next ->
+  return (Roll_repr.to_int32 next)
+
 let init c =
   Storage.Roll.Next.init c Roll_repr.first

src/proto/alpha/roll_storage.mli

@@ -61,3 +61,9 @@ end
 
 val get_contract_delegate:
   Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t
+
+val value: Raw_context.t -> Tez_repr.t
+
+(** HACK for the alphanet. *)
+val may_recompute_rolls: Raw_context.t -> Raw_context.t tzresult Lwt.t
+val next: Raw_context.t -> Int32.t tzresult Lwt.t

src/proto/alpha/services.ml

@@ -161,6 +161,18 @@ module Context = struct
                 describe ~title: "detailled level info" Level.encoding)
       RPC.Path.(custom_root / "context" / "next_level")
 
+  let roll_value custom_root =
+    RPC.service
+      ~input: empty
+      ~output: (wrap_tzerror Tez.encoding)
+      RPC.Path.(custom_root / "context" / "roll_value")
+
+  let next_roll custom_root =
+    RPC.service
+      ~input: empty
+      ~output: (wrap_tzerror int32)
+      RPC.Path.(custom_root / "context" / "next_roll")
+
   let voting_period_kind custom_root =
     RPC.service
       ~description: "Voting period kind for the current block"

src/proto/alpha/services_registration.ml

@@ -158,6 +158,12 @@ let next_level ctxt =
 
 let () = register0 Services.Context.next_level next_level
 
+let roll_value ctxt =
+  return (Roll.value ctxt)
+let () = register0 Services.Context.roll_value roll_value
+
+let () = register0 Services.Context.next_roll Roll.next
+
 let () =
   register0 Services.Context.voting_period_kind Vote.get_current_period_kind
 

src/proto/alpha/storage.ml

@@ -38,6 +38,7 @@ module Contract = struct
       (Make_subcontext(Raw_context)(struct let name = ["index"] end))
       (Contract_repr.Index)
 
+  let fold = Indexed_context.fold_keys
   let list = Indexed_context.keys
 
   module Balance =
@@ -233,6 +234,8 @@ module Roll = struct
   module Last_for_cycle = Cycle.Last_roll
   module Owner_for_cycle = Cycle.Roll_owner
 
+  let clear = Indexed_context.clear
+
 end
 
 (** Votes **)

src/proto/alpha/storage.mli

@@ -30,6 +30,8 @@ module Roll : sig
      and type value = Contract_repr.t
      and type t := Raw_context.t
 
+  val clear: Raw_context.t -> Raw_context.t Lwt.t
+
   (** The next roll to be allocated. *)
   module Next : Single_data_storage
     with type value = Roll_repr.t
@@ -87,6 +89,9 @@ module Contract : sig
   end
 
   (** The domain of alive contracts *)
+  val fold :
+    Raw_context.t ->
+    init:'a -> f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t
   val list : Raw_context.t -> Contract_repr.t list Lwt.t
 
   (** All the tez possesed by a contract, including rolls and change *)

src/proto/alpha/storage_functors.ml

@@ -265,6 +265,10 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
   type context = t
   type key = I.t
 
+  let clear t =
+    C.remove_rec t [] >>= fun t ->
+    Lwt.return (C.project t)
+
   module Raw_context = struct
     type t = C.t * I.t
     type context = t
@@ -297,10 +301,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
     let project (t, _) = C.project t
   end
 
-  let clear t i =
-    Raw_context.remove_rec (t, i) [] >>= fun (t, _) ->
-    Lwt.return (C.project t)
-
   let fold_keys t ~init ~f =
     let rec dig i path acc =
       if Compare.Int.(i <= 0) then

src/proto/alpha/storage_sigs.ml

@@ -189,7 +189,7 @@ module type Indexed_raw_context = sig
   type context = t
   type key
 
-  val clear: context -> key -> Raw_context.t Lwt.t
+  val clear: context -> Raw_context.t Lwt.t
 
   val fold_keys:
     context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

src/proto/alpha/tezos_context.mli

@@ -681,6 +681,9 @@ end
 
 module Roll : sig
 
+  val value: context -> Tez.t
+  val next: context -> Int32.t tzresult Lwt.t
+
   val freeze_rolls_for_cycle: context -> Cycle.t -> context tzresult Lwt.t
   val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t