Alpha/Baker: fee threshold

src/proto_alpha/lib_client/client_proto_args.ml

@@ -13,6 +13,7 @@ open Clic
 
 type error += Bad_tez_arg of string * string (* Arg_name * value *)
 type error += Bad_max_priority of string
+type error += Bad_fee_threshold of string
 type error += Bad_endorsement_delay of string
 
 let () =
@@ -40,6 +41,16 @@ let () =
     Data_encoding.(obj1 (req "parameter" string))
     (function Bad_max_priority parameter -> Some parameter | _ -> None)
     (fun parameter -> Bad_max_priority parameter) ;
+  register_error_kind
+    `Permanent
+    ~id:"badFeeThresholdArg"
+    ~title:"Bad -fee-threshold arg"
+    ~description:("invalid fee threshold in -fee-threshold")
+    ~pp:(fun ppf literal ->
+        Format.fprintf ppf "invalid fee threshold '%s' in -fee-threshold" literal)
+    Data_encoding.(obj1 (req "parameter" string))
+    (function Bad_fee_threshold parameter -> Some parameter | _ -> None)
+    (fun parameter -> Bad_fee_threshold parameter) ;
   register_error_kind
     `Permanent
     ~id:"badEndorsementDelayArg"
@@ -185,6 +196,16 @@ let max_priority_arg =
          try return (int_of_string s)
          with _ -> fail (Bad_max_priority s)))
 
+let fee_threshold_arg =
+  arg
+    ~long:"fee-threshold"
+    ~placeholder:"threshold"
+    ~doc:"exclude operations with fees lower than this threshold (in mutez)"
+    (parameter (fun _ s ->
+         match Tez.of_string s with
+         | Some t -> return t
+         | None -> fail (Bad_fee_threshold s)))
+
 let endorsement_delay_arg =
   default_arg
     ~long:"endorsement-delay"

src/proto_alpha/lib_client/client_proto_args.mli

@@ -23,6 +23,7 @@ val delegate_arg: (Signature.Public_key_hash.t option, Proto_alpha.full) Clic.ar
 val delegatable_switch: (bool, Proto_alpha.full) Clic.arg
 val spendable_switch: (bool, Proto_alpha.full) Clic.arg
 val max_priority_arg: (int option, Proto_alpha.full) Clic.arg
+val fee_threshold_arg: (Tez.tez option, Proto_alpha.full) Clic.arg
 val force_switch: (bool, Proto_alpha.full) Clic.arg
 val minimal_timestamp_switch: (bool, Proto_alpha.full) Clic.arg
 val endorsement_delay_arg: (int, Proto_alpha.full) Clic.arg

src/proto_alpha/lib_delegate/client_baking_forge.ml

@@ -156,14 +156,18 @@ let get_operation_fee op =
           Tez.(total_fee +? fee)
       | _ -> return total_fee) Tez.zero l
 
-let sort_operations_by_fee (operations : Proto_alpha.operation list) =
-  (* There is no sort_s, so : *)
-  map_s (fun op -> get_operation_fee op >>=? fun fee -> return (op, fee))
+let sort_operations_by_fee ?(threshold = Tez.zero) (operations : Proto_alpha.operation list) =
+  filter_map_s
+    (fun op ->
+       get_operation_fee op >>=? fun fee ->
+       if Tez.(<) fee threshold then
+         return None
+       else
+         return (Some (op, fee)))
     operations >>=? fun operations ->
   let compare_fee (_, fee1) (_, fee2) =
-    Tez.compare fee1 fee2 * -1
-  in
-  (* Should we keep operations without fee ? *)
+    (* NOTE: inverted fee comparison to invert the order of sort *)
+    Tez.compare fee2 fee1 in
   return @@ List.map fst (List.sort compare_fee operations)
 
 let retain_operations_up_to_quota operations max_quota =
@@ -183,7 +187,7 @@ let retain_operations_up_to_quota operations max_quota =
     | Full ops -> ops in
   List.rev operations
 
-let classify_operations (ops: Proto_alpha.operation list) =
+let classify_operations ?threshold (ops: Proto_alpha.operation list) =
   let t = Array.make (List.length Proto_alpha.Main.validation_passes) [] in
   List.iter
     (fun (op: Proto_alpha.operation) ->
@@ -196,7 +200,7 @@ let classify_operations (ops: Proto_alpha.operation list) =
   let manager_operations = t.(managers_index) in
   let { Alpha_environment.Updater.max_size } =
     List.nth Proto_alpha.Main.validation_passes managers_index in
-  sort_operations_by_fee manager_operations >>=? fun ordered_operations ->
+  sort_operations_by_fee ?threshold manager_operations >>=? fun ordered_operations ->
   let max_operations =
     retain_operations_up_to_quota ordered_operations max_size
   in
@@ -310,6 +314,7 @@ let error_of_op (result: error Preapply_result.t) op =
 
 
 let forge_block cctxt ?(chain = `Main) block
+    ?threshold
     ?force
     ?operations ?(best_effort = operations = None) ?(sort = best_effort)
     ?timestamp
@@ -324,7 +329,7 @@ let forge_block cctxt ?(chain = `Main) block
 
   (* get basic building blocks *)
   let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
-  classify_operations operations_arg >>=? fun operations ->
+  classify_operations ?threshold operations_arg >>=? fun operations ->
   Alpha_block_services.Helpers.Preapply.block
     cctxt ~block ~timestamp ~sort ~protocol_data operations >>=? fun (shell_header, result) ->
 
@@ -572,6 +577,7 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac
 let bake_slot
     cctxt
     state
+    ?threshold
     seed_nonce_hash
     (timestamp, (bi, priority, delegate)) (* baking slot *)
   =
@@ -601,7 +607,7 @@ let bake_slot
       None in
   let protocol_data =
     forge_faked_protocol_data ~priority ~seed_nonce_hash in
-  classify_operations operations >>=? fun operations ->
+  classify_operations ?threshold operations >>=? fun operations ->
   begin
     (* Don't load an alpha context if the chain is still in genesis *)
     if Protocol_hash.(bi.protocol = bi.next_protocol) then
@@ -669,7 +675,7 @@ let pp_operation_list_list =
 
 (* [bake] create a single block when woken up to do so. All the necessary
    information (e.g., slot) is available in the [state]. *)
-let bake (cctxt : #Proto_alpha.full) state =
+let bake (cctxt : #Proto_alpha.full) ?threshold state =
   let slots = pop_baking_slots state in
   lwt_log_info "Found %d current slots and %d future slots."
     (List.length slots)
@@ -678,7 +684,9 @@ let bake (cctxt : #Proto_alpha.full) state =
   let seed_nonce_hash = Nonce.hash seed_nonce in
 
   (* baking for each slot *)
-  filter_map_s (bake_slot cctxt state seed_nonce_hash) slots >>=? fun candidates ->
+  filter_map_s
+    (bake_slot cctxt ?threshold state seed_nonce_hash)
+    slots >>=? fun candidates ->
 
   (* FIXME: pick one block per-delegate *)
   (* selecting the candidate baked block *)
@@ -740,6 +748,7 @@ let check_error p =
    the [delegates] *)
 let create
     (cctxt : #Proto_alpha.full)
+    ?threshold
     ?max_priority
     ~(context_path: string)
     (delegates: public_key_hash list)
@@ -799,7 +808,7 @@ let create
           (* main event: it's baking time *)
           lwt_debug "Waking up for baking..." >>= fun () ->
           (* core functionality *)
-          check_error @@ bake cctxt state
+          check_error @@ bake cctxt ?threshold state
     end >>= fun () ->
     (* and restart *)
     worker_loop () in
@@ -812,6 +821,7 @@ let create
    unavailable blocks (empty block chain). *)
 let create
     (cctxt : #Proto_alpha.full)
+    ?threshold
     ?max_priority
     ~(context_path: string)
     (delegates: public_key_hash list)
@@ -819,4 +829,4 @@ let create
   Client_baking_scheduling.wait_for_first_block
     ~info:lwt_log_info
     block_stream
-    (create cctxt ?max_priority ~context_path delegates block_stream)
+    (create cctxt ?threshold ?max_priority ~context_path delegates block_stream)

src/proto_alpha/lib_delegate/client_baking_forge.mli

@@ -39,6 +39,7 @@ val forge_block:
   #Proto_alpha.full ->
   ?chain:Chain_services.chain ->
   Block_services.block ->
+  ?threshold:Tez.t ->
   ?force:bool ->
   ?operations: Operation.packed list ->
   ?best_effort:bool ->
@@ -49,7 +50,7 @@ val forge_block:
   src_sk:Client_keys.sk_uri ->
   unit ->
   Block_hash.t tzresult Lwt.t
-(** [forge_block cctxt parent_blk ?force ?operations ?best_effort
+(** [forge_block cctxt parent_blk ?threshold ?force ?operations ?best_effort
     ?sort ?timestamp ?max_priority ?priority ~seed_nonce ~src_sk
     pk_hash] injects a block in the node. In addition of inject_block,
     it will:
@@ -65,6 +66,9 @@ val forge_block:
     * Timestamp: If [?timestamp] is set, and is compatible with the
       computed baking priority, it will be used. Otherwise, it will be
       set at the best baking priority.
+
+    * Threshold: If [?threshold] is given, operations with fees lower than it
+      are not added to the block.
 *)
 
 module State : sig
@@ -83,6 +87,7 @@ end
 
 val create:
   #Proto_alpha.full ->
+  ?threshold:Tez.t ->
   ?max_priority: int ->
   context_path: string ->
   public_key_hash list ->

src/proto_alpha/lib_delegate/client_baking_lib.ml

@@ -12,6 +12,7 @@ open Alpha_context
 
 let bake_block (cctxt : #Proto_alpha.full)
     ?(chain = `Main) block
+    ?threshold
     ?force ?max_priority ?(minimal_timestamp=false)
     ?src_sk ?src_pk delegate =
   begin
@@ -39,6 +40,7 @@ let bake_block (cctxt : #Proto_alpha.full)
       None, None in
   Client_baking_forge.forge_block cctxt
     ?timestamp:(if minimal_timestamp then None else Some (Time.now ()))
+    ?threshold
     ?force
     ?seed_nonce_hash ~src_sk block
     ~priority:(`Auto (delegate, max_priority)) () >>=? fun block_hash ->

src/proto_alpha/lib_delegate/client_baking_lib.mli

@@ -15,6 +15,7 @@ val bake_block:
   #Proto_alpha.full ->
   ?chain:Chain_services.chain ->
   Block_services.block ->
+  ?threshold:Tez.t ->
   ?force:bool ->
   ?max_priority: int ->
   ?minimal_timestamp: bool ->

src/proto_alpha/lib_delegate/client_daemon.ml

@@ -20,11 +20,11 @@ end
 
 module Baker = struct
 
-  let run (cctxt : #Proto_alpha.full) ?max_priority ?min_date ~context_path delegates =
+  let run (cctxt : #Proto_alpha.full) ?threshold ?max_priority ?min_date ~context_path delegates =
     Client_baking_blocks.monitor_heads
       cctxt `Main >>=? fun block_stream ->
     Client_baking_forge.create cctxt
-      ?max_priority ~context_path delegates block_stream >>=? fun () ->
+      ?threshold ?max_priority ~context_path delegates block_stream >>=? fun () ->
     ignore min_date;
     return ()
 

src/proto_alpha/lib_delegate/client_daemon.mli

@@ -21,6 +21,7 @@ end
 module Baker : sig
   val run:
     #Proto_alpha.full ->
+    ?threshold: Tez.tez ->
     ?max_priority: int ->
     ?min_date: Time.t ->
     context_path: string ->

src/proto_alpha/lib_delegate/delegate_commands.ml

@@ -25,14 +25,14 @@ let delegate_commands () =
   let open Clic in
   [
     command ~group ~desc: "Forge and inject block using the delegate rights."
-      (args3 max_priority_arg force_switch minimal_timestamp_switch)
+      (args4 max_priority_arg fee_threshold_arg force_switch minimal_timestamp_switch)
       (prefixes [ "bake"; "for" ]
        @@ Client_keys.Public_key_hash.source_param
          ~name:"baker" ~desc: "name of the delegate owning the baking right"
        @@ stop)
-      (fun (max_priority, force, minimal_timestamp) delegate cctxt ->
+      (fun (max_priority, threshold, force, minimal_timestamp) delegate cctxt ->
          bake_block cctxt cctxt#block
-           ~force ?max_priority ~minimal_timestamp delegate) ;
+           ?threshold ~force ?max_priority ~minimal_timestamp delegate) ;
     command ~group ~desc: "Forge and inject a seed-nonce revelation operation."
       no_options
       (prefixes [ "reveal"; "nonce"; "for" ]
@@ -62,15 +62,16 @@ let baker_commands () =
   in
   [
     command ~group ~desc: "Launch the baker daemon."
-      (args1 max_priority_arg)
+      (args2 max_priority_arg fee_threshold_arg)
       (prefixes [ "run" ; "with" ; "local" ; "node" ]
        @@ param
          ~name:"context_path"
          ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)"
          directory_parameter
        @@ seq_of_param Client_keys.Public_key_hash.alias_param)
-      (fun max_priority node_path delegates cctxt ->
+      (fun (max_priority, threshold) node_path delegates cctxt ->
          Client_daemon.Baker.run cctxt
+           ?threshold
            ?max_priority
            ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
            ~context_path:(Filename.concat node_path "context")