Michelson: add SET_DELEGATE opcode

docs/whitedoc/michelson.rst

@@ -1438,6 +1438,12 @@ contract.
 The parameter must be consistent with the one expected by the
 contract, unit for an account.
 
+-  ``SET_DELEGATE``: Forge a delegation.
+
+::
+
+    :: option key_hash : 'S   ->   operation : S
+
 -  ``BALANCE``: Push the current amount of tez of the current contract.
 
 ::
@@ -2469,6 +2475,7 @@ XII - Full grammar
       | MANAGER
       | SELF
       | TRANSFER_TOKENS
+      | SET_DELEGATE
       | CREATE_ACCOUNT
       | CREATE_CONTRACT
       | IMPLICIT_ACCOUNT

src/bin_client/test/contracts/vote_for_delegate.tz

@@ -0,0 +1,30 @@
+parameter (option key_hash) ;
+storage (pair
+           (pair (address @mgr1) (option key_hash))
+           (pair (address @mgr2) (option key_hash))) ;
+code { # Update the storage
+       DUP ; CDAAR ; SOURCE ;
+       IFCMPEQ
+         { UNPAIR ; SWAP ; SET_CADR }
+         { DUP ; CDDAR ; SOURCE ;
+           IFCMPEQ
+             { UNPAIR ; SWAP ; SET_CDDR }
+             { FAIL } } ;
+       # Now compare the proposals
+       DUP ; CADR ;
+       DIP { DUP ; CDDR } ;
+       IF_NONE
+         { IF_NONE
+             { NONE key_hash ;
+               SET_DELEGATE ; NIL operation ; SWAP ; CONS }
+             { DROP ; NIL operation } }
+         { SWAP ;
+           IF_SOME
+             { DIP { DUP } ;
+               IFCMPEQ
+                 { SOME ;
+                   SET_DELEGATE ; NIL operation ; SWAP ; CONS }
+                 { DROP ;
+                   NIL operation }}
+             { DROP ; NIL operation }} ;
+       PAIR }

src/bin_client/test/test_contracts.sh

@@ -414,6 +414,26 @@ init_with_transfer $contract_dir/self.tz $key1 \
 bake_after $client transfer 0 from bootstrap1 to self
 assert_storage_contains self "\"$(get_contract_addr self)\""
 
+# Test SET_DELEGATE
+b2='tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN'
+b3='tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU'
+b4='tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv'
+b5='tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv'
+init_with_transfer $contract_dir/vote_for_delegate.tz bootstrap1 \
+				   "(Pair (Pair \"$b3\" None) (Pair \"$b4\" None))" 1,000 bootstrap1
+$client get delegate for vote_for_delegate | assert_in_output none
+
+assert_fails $client transfer 0 from bootstrap1 to vote_for_delegate -arg None
+assert_fails $client transfer 0 from bootstrap2 to vote_for_delegate -arg None
+bake_after $client transfer 0 from bootstrap3 to vote_for_delegate -arg "(Some \"$b5\")"
+assert_storage_contains vote_for_delegate "\"$b5\""
+$client get delegate for vote_for_delegate | assert_in_output none
+bake_after $client transfer 0 from bootstrap4 to vote_for_delegate -arg "(Some \"$b2\")"
+assert_storage_contains vote_for_delegate "\"$b2\""
+$client get delegate for vote_for_delegate | assert_in_output none
+bake_after $client transfer 0 from bootstrap4 to vote_for_delegate -arg "(Some \"$b5\")"
+$client get delegate for vote_for_delegate | assert_in_output "$b5"
+
 # Test sets and map literals
 assert_fails $client typecheck data '{ Elt 0 1 ; Elt 0 1 }' against type '(map nat nat)'
 assert_fails $client typecheck data '{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }' against type '(map nat nat)'

src/proto_alpha/lib_client/client_proto_context.ml

@@ -80,11 +80,11 @@ let pp_manager_operation_content ppf source operation internal pp_result result
                 Michelson_v1_printer.print_expr storage
         end ;
         begin match delegate with
-          | None -> Format.fprintf ppf "@,Delegate is the manager"
+          | None -> Format.fprintf ppf "@,No delegate for this contract"
           | Some delegate -> Format.fprintf ppf "@,Delegate: %a" Signature.Public_key_hash.pp delegate
         end ;
-        if spendable then Format.fprintf ppf "@,Spendable by its manager" ;
+        if spendable then Format.fprintf ppf "@,Spendable by the manager" ;
-        if delegatable then Format.fprintf ppf "@,Delegate can be changed later" ;
+        if delegatable then Format.fprintf ppf "@,Delegate can be changed by the manager" ;
         pp_result ppf result ;
         Format.fprintf ppf "@]" ;
     | Reveal key ->

src/proto_alpha/lib_client_commands/client_proto_context_commands.ml

@@ -145,6 +145,17 @@ let commands () =
         operation_submitted_message cctxt oph
       end ;
 
+    command ~group ~desc: "Withdraw the delegate from a contract."
+      (args1 fee_arg)
+      (prefixes [ "withdraw" ; "delegate" ; "from" ]
+       @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
+       @@ stop)
+      begin fun fee (_, contract) (cctxt : Proto_alpha.full) ->
+        source_to_keys cctxt cctxt#block contract >>=? fun (src_pk, manager_sk) ->
+        set_delegate ~fee cctxt cctxt#block contract None ~src_pk ~manager_sk >>=? fun oph ->
+        operation_submitted_message cctxt oph
+      end ;
+
     command ~group ~desc:"Open a new account."
       (args4 fee_arg delegate_arg delegatable_switch (Client_keys.force_switch ()))
       (prefixes [ "originate" ; "account" ]

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -236,6 +236,7 @@ module Script : sig
     | I_SUB
     | I_SWAP
     | I_TRANSFER_TOKENS
+    | I_SET_DELEGATE
     | I_UNIT
     | I_UPDATE
     | I_XOR
@@ -566,6 +567,9 @@ module Delegate : sig
   val set:
     context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t
 
+  val set_from_script:
+    context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t
+
   val fold:
     context ->
     init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t

src/proto_alpha/lib_protocol/src/apply.ml

@@ -391,6 +391,8 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
   Contract.must_exist ctxt source >>=? fun () ->
   let spend =
     if internal then Contract.spend_from_script else Contract.spend in
+  let set_delegate =
+    if internal then Delegate.set_from_script else Delegate.set in
   match operation with
   | Reveal _ -> return (ctxt, Reveal_result)
   | Transaction { amount ; parameters ; destination } -> begin
@@ -486,7 +488,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
             storage_fees_increment = fees } in
       return (ctxt, result)
   | Delegation delegate ->
-      Delegate.set ctxt source delegate >>=? fun ctxt ->
+      set_delegate ctxt source delegate >>=? fun ctxt ->
       return (ctxt, Delegation_result)
 
 let apply_internal_manager_operations ctxt ~payer ops =

src/proto_alpha/lib_protocol/src/delegate_storage.ml

@@ -121,7 +121,7 @@ let init ctxt contract delegate =
 
 let get = Roll_storage.get_contract_delegate
 
-let set c contract delegate =
+let set_base c is_delegatable contract delegate =
   match delegate with
   | None -> begin
       match Contract_repr.is_implicit contract with
@@ -180,6 +180,12 @@ let set c contract delegate =
         end >>=? fun c ->
         return c
 
+let set c contract delegate =
+  set_base c is_delegatable contract delegate
+
+let set_from_script c contract delegate =
+  set_base c (fun _ _ -> return true) contract delegate
+
 let remove ctxt contract =
   Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
   unlink ctxt contract balance

src/proto_alpha/lib_protocol/src/delegate_storage.mli

@@ -38,6 +38,11 @@ val set:
   Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
   Raw_context.t tzresult Lwt.t
 
+(** Same as {!set} ignoring the [delegatable] flag. *)
+val set_from_script:
+  Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
+  Raw_context.t tzresult Lwt.t
+
 type error +=
   | Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
   | No_deletion of Signature.Public_key_hash.t (* `Permanent *)

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -176,6 +176,7 @@ module Cost_of = struct
   let create_account = step_cost 20
   let create_contract = step_cost 70
   let implicit_account = step_cost 10
+  let set_delegate = step_cost 10
   let balance = step_cost 5
   let now = step_cost 3
   let check_signature = step_cost 3

src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli

@@ -71,6 +71,7 @@ module Cost_of : sig
   val create_account : Gas.cost
   val create_contract : Gas.cost
   val implicit_account : Gas.cost
+  val set_delegate : Gas.cost
   val balance : Gas.cost
   val now : Gas.cost
   val check_signature : Gas.cost

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml

@@ -89,6 +89,7 @@ type prim =
   | I_SUB
   | I_SWAP
   | I_TRANSFER_TOKENS
+  | I_SET_DELEGATE
   | I_UNIT
   | I_UPDATE
   | I_XOR
@@ -214,6 +215,7 @@ let string_of_prim = function
   | I_SUB -> "SUB"
   | I_SWAP -> "SWAP"
   | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS"
+  | I_SET_DELEGATE -> "SET_DELEGATE"
   | I_UNIT -> "UNIT"
   | I_UPDATE -> "UPDATE"
   | I_XOR -> "XOR"
@@ -320,6 +322,7 @@ let prim_of_string = function
   | "SUB" -> ok I_SUB
   | "SWAP" -> ok I_SWAP
   | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS
+  | "SET_DELEGATE" -> ok I_SET_DELEGATE
   | "UNIT" -> ok I_UNIT
   | "UPDATE" -> ok I_UPDATE
   | "XOR" -> ok I_XOR
@@ -470,6 +473,7 @@ let prim_encoding =
     ("SUB", I_SUB) ;
     ("SWAP", I_SWAP) ;
     ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ;
+    ("SET_DELEGATE", I_SET_DELEGATE) ;
     ("UNIT", I_UNIT) ;
     ("UPDATE", I_UPDATE) ;
     ("XOR", I_XOR) ;

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli

@@ -87,6 +87,7 @@ type prim =
   | I_SUB
   | I_SWAP
   | I_TRANSFER_TOKENS
+  | I_SET_DELEGATE
   | I_UNIT
   | I_UPDATE
   | I_XOR

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -701,6 +701,11 @@ let rec interp
                               (init, rest)))))) ->
             create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
               ~param_type ~storage_type ~rest
+        | Set_delegate,
+          Item (delegate, rest) ->
+            Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
+            let operation = Delegation delegate in
+            logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt)
         | Balance, rest ->
             Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
             Contract.get_balance ctxt self >>=? fun balance ->

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -211,6 +211,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
   | Source -> 0
   | Self _ -> 1
   | Amount -> 0
+  | Set_delegate -> 0
 
 (* ---- Error helpers -------------------------------------------------------*)
 
@@ -302,6 +303,7 @@ let namespace = function
   | I_SUB
   | I_SWAP
   | I_TRANSFER_TOKENS
+  | I_SET_DELEGATE
   | I_UNIT
   | I_UPDATE
   | I_XOR
@@ -2055,6 +2057,9 @@ and parse_instr
                    (Contract_t cp, rest, _), _), _) ->
         check_item_ty p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun Eq ->
         typed ctxt loc Transfer_tokens (Item_t (Operation_t, rest, instr_annot))
+    | Prim (loc, I_SET_DELEGATE, [], instr_annot),
+      Item_t (Option_t Key_hash_t, rest, _) ->
+        typed ctxt loc Set_delegate (Item_t (Operation_t, rest, instr_annot))
     | Prim (loc, I_CREATE_ACCOUNT, [], instr_annot),
       Item_t
         (Key_hash_t, Item_t
@@ -2165,7 +2170,7 @@ and parse_instr
                  | I_COMPARE | I_EQ | I_NEQ
                  | I_LT | I_GT | I_LE | I_GE
                  | I_MANAGER | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT
-                 | I_CREATE_CONTRACT | I_NOW
+                 | I_CREATE_CONTRACT | I_SET_DELEGATE | I_NOW
                  | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE
                  | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE
                  | I_H | I_STEPS_TO_QUOTA | I_ADDRESS

src/proto_alpha/lib_protocol/src/script_typed_ir.ml

@@ -344,6 +344,8 @@ and ('bef, 'aft) instr =
   | Create_contract_literal : 'g ty * 'p ty * ('p * 'g, internal_operation list * 'g) lambda  ->
     (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
      internal_operation * (Contract.t * 'rest)) instr
+  | Set_delegate :
+      (public_key_hash option * 'rest, internal_operation * 'rest) instr
   | Now :
       ('rest, Script_timestamp.t * 'rest) instr
   | Balance :