Source file client_proto_multisig.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019-2021 Nomadic Labs <contact@nomadic-labs.com>           *)
(*                                                                           *)
(* 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context
open Michelson_v1_helpers

type error += Contract_has_no_script of Contract.t

type error += Not_a_supported_multisig_contract of Script_expr_hash.t

type error += Contract_has_no_storage of Contract.t

type error += Contract_has_unexpected_storage of Contract.t

type error += Invalid_signature of signature

type error += Not_enough_signatures of int * int

type error += Action_deserialisation_error of Script.expr

type error += Bytes_deserialisation_error of Bytes.t

type error += Bad_deserialized_contract of (Contract.t * Contract.t)

type error += Bad_deserialized_counter of (counter * counter)

type error += Non_positive_threshold of int

type error += Threshold_too_high of int * int

type error += Unsupported_feature_generic_call of Script.expr

type error += Unsupported_feature_generic_call_ty of Script.expr

type error += Unsupported_feature_lambda of string

type error +=
  | Ill_typed_argument of Contract.t * string * Script.expr * Script.expr

type error += Ill_typed_lambda of Script.expr * Script.expr

let () =
  register_error_kind
    `Permanent
    ~id:"contractHasNoScript"
    ~title:
      "The given contract is not a multisig contract because it has no script"
    ~description:
      "A multisig command has referenced a scriptless smart contract instead \
       of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no script %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_script c -> Some c | _ -> None)
    (fun c -> Contract_has_no_script c) ;
  register_error_kind
    `Permanent
    ~id:"notASupportedMultisigContract"
    ~title:"The given contract is not one of the supported contracts"
    ~description:
      "A multisig command has referenced a smart contract whose script is not \
       one of the known multisig contract scripts."
    ~pp:(fun ppf hash ->
      Format.fprintf
        ppf
        "Not a supported multisig contract.@\n\
         The hash of this script is %a, it was not found among in the list of \
         known multisig script hashes."
        Script_expr_hash.pp
        hash)
    Data_encoding.(obj1 (req "hash" Script_expr_hash.encoding))
    (function Not_a_supported_multisig_contract h -> Some h | _ -> None)
    (fun h -> Not_a_supported_multisig_contract h) ;
  register_error_kind
    `Permanent
    ~id:"contractHasNoStorage"
    ~title:
      "The given contract is not a multisig contract because it has no storage"
    ~description:
      "A multisig command has referenced a smart contract without storage \
       instead of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no storage %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_no_storage c) ;
  register_error_kind
    `Permanent
    ~id:"contractHasUnexpectedStorage"
    ~title:
      "The storage of the given contract is not of the shape expected for a \
       multisig contract"
    ~description:
      "A multisig command has referenced a smart contract whose storage is of \
       a different shape than the expected one."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Contract has unexpected storage %a."
        Contract.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_unexpected_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_unexpected_storage c) ;
  register_error_kind
    `Permanent
    ~id:"invalidSignature"
    ~title:
      "The following signature did not match a public key in the given \
       multisig contract"
    ~description:
      "A signature was given for a multisig contract that matched none of the \
       public keys of the contract signers"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Invalid signature %s."
        (Tezos_crypto.Signature.V0.to_b58check s))
    Data_encoding.(
      obj1 (req "invalid_signature" Tezos_crypto.Signature.V0.encoding))
    (function Invalid_signature s -> Some s | _ -> None)
    (fun s -> Invalid_signature s) ;
  register_error_kind
    `Permanent
    ~id:"notEnoughSignatures"
    ~title:"Not enough signatures were provided for this multisig action"
    ~description:
      "To run an action on a multisig contract, you should provide at least as \
       many signatures as indicated by the threshold stored in the multisig \
       contract."
    ~pp:(fun ppf (threshold, nsigs) ->
      Format.fprintf
        ppf
        "Not enough signatures: only %d signatures were given but the \
         threshold is currently %d"
        nsigs
        threshold)
    Data_encoding.(obj1 (req "threshold_nsigs" (tup2 int31 int31)))
    (function
      | Not_enough_signatures (threshold, nsigs) -> Some (threshold, nsigs)
      | _ -> None)
    (fun (threshold, nsigs) -> Not_enough_signatures (threshold, nsigs)) ;
  register_error_kind
    `Permanent
    ~id:"actionDeserialisation"
    ~title:"The expression is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an expression that does not correspond to a known multisig action"
    ~pp:(fun ppf e ->
      Format.fprintf
        ppf
        "Action deserialisation error %a."
        Michelson_v1_printer.print_expr
        e)
    Data_encoding.(obj1 (req "expr" Script.expr_encoding))
    (function Action_deserialisation_error e -> Some e | _ -> None)
    (fun e -> Action_deserialisation_error e) ;
  register_error_kind
    `Permanent
    ~id:"bytesDeserialisation"
    ~title:"The byte sequence is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an error"
    ~pp:(fun ppf b ->
      Format.fprintf ppf "Bytes deserialisation error %s." (Bytes.to_string b))
    Data_encoding.(obj1 (req "expr" bytes))
    (function Bytes_deserialisation_error b -> Some b | _ -> None)
    (fun b -> Bytes_deserialisation_error b) ;
  register_error_kind
    `Permanent
    ~id:"badDeserializedContract"
    ~title:"The byte sequence is not for the given multisig contract"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an action for another multisig contract"
    ~pp:(fun ppf (received, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized contract, received %a expected %a."
        Contract.pp
        received
        Contract.pp
        expected)
    Data_encoding.(
      obj1 (req "received_expected" (tup2 Contract.encoding Contract.encoding)))
    (function Bad_deserialized_contract b -> Some b | _ -> None)
    (fun b -> Bad_deserialized_contract b) ;
  register_error_kind
    `Permanent
    ~id:"Bad deserialized counter"
    ~title:"Deserialized counter does not match the stored one"
    ~description:
      "The byte sequence references a multisig counter that does not match the \
       one currently stored in the given multisig contract"
    ~pp:(fun ppf (received, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized counter, received %d expected %d."
        received
        expected)
    Data_encoding.(obj1 (req "received_expected" (tup2 int31 int31)))
    (function
      | Bad_deserialized_counter (c1, c2) -> Some (Z.to_int c1, Z.to_int c2)
      | _ -> None)
    (fun (c1, c2) -> Bad_deserialized_counter (Z.of_int c1, Z.of_int c2)) ;
  register_error_kind
    `Permanent
    ~id:"thresholdTooHigh"
    ~title:"Given threshold is too high"
    ~description:
      "The given threshold is higher than the number of keys, this would lead \
       to a frozen multisig contract"
    ~pp:(fun ppf (threshold, nkeys) ->
      Format.fprintf
        ppf
        "Threshold too high: %d expected at most %d."
        threshold
        nkeys)
    Data_encoding.(obj1 (req "received_expected" (tup2 int31 int31)))
    (function Threshold_too_high (c1, c2) -> Some (c1, c2) | _ -> None)
    (fun (c1, c2) -> Threshold_too_high (c1, c2)) ;
  register_error_kind
    `Permanent
    ~id:"nonPositiveThreshold"
    ~title:"Given threshold is not positive"
    ~description:"A multisig threshold should be a positive number"
    ~pp:(fun ppf threshold ->
      Format.fprintf ppf "Multisig threshold %d should be positive." threshold)
    Data_encoding.(obj1 (req "threshold" int31))
    (function Non_positive_threshold t -> Some t | _ -> None)
    (fun t -> Non_positive_threshold t) ;
  register_error_kind
    `Permanent
    ~id:"unsupportedGenericMultisigFeature"
    ~title:"Unsupported multisig feature: generic call"
    ~description:
      "This multisig contract does not feature calling contracts with arguments"
    ~pp:(fun ppf arg ->
      Format.fprintf
        ppf
        "This multisig contract can only transfer tokens to contracts of type \
         unit; calling a contract with argument %a is not supported."
        Michelson_v1_printer.print_expr
        arg)
    Data_encoding.(obj1 (req "arg" Script.expr_encoding))
    (function Unsupported_feature_generic_call arg -> Some arg | _ -> None)
    (fun arg -> Unsupported_feature_generic_call arg) ;
  register_error_kind
    `Permanent
    ~id:"unsupportedGenericMultisigFeatureTy"
    ~title:"Unsupported multisig feature: generic call to non-unit entrypoint"
    ~description:
      "This multisig contract does not feature calling contracts with arguments"
    ~pp:(fun ppf ty ->
      Format.fprintf
        ppf
        "This multisig contract can only transfer tokens to contracts of type \
         unit; calling a contract of type %a is not supported."
        Michelson_v1_printer.print_expr
        ty)
    Data_encoding.(obj1 (req "ty" Script.expr_encoding))
    (function Unsupported_feature_generic_call_ty ty -> Some ty | _ -> None)
    (fun ty -> Unsupported_feature_generic_call_ty ty) ;
  register_error_kind
    `Permanent
    ~id:"unsupportedGenericMultisigLambda"
    ~title:"Unsupported multisig feature: running lambda"
    ~description:"This multisig contract does not feature running lambdas"
    ~pp:(fun ppf lam ->
      Format.fprintf
        ppf
        "This multisig contract has a fixed set of actions, it cannot run the \
         following lambda: %s."
        lam)
    Data_encoding.(obj1 (req "lam" string))
    (function Unsupported_feature_lambda lam -> Some lam | _ -> None)
    (fun lam -> Unsupported_feature_lambda lam) ;
  register_error_kind
    `Permanent
    ~id:"illTypedArgumentForMultisig"
    ~title:"Ill-typed argument in multi-signed transfer"
    ~description:
      "The provided argument for a transfer from a multisig contract is \
       ill-typed"
    ~pp:(fun ppf (destination, entrypoint, parameter_ty, parameter) ->
      Format.fprintf
        ppf
        "The entrypoint %s of contract %a called from a multisig contract is \
         of type %a; the provided parameter %a is ill-typed."
        entrypoint
        Contract.pp
        destination
        Michelson_v1_printer.print_expr
        parameter_ty
        Michelson_v1_printer.print_expr
        parameter)
    Data_encoding.(
      obj4
        (req "destination" Contract.encoding)
        (req "entrypoint" string)
        (req "parameter_ty" Script.expr_encoding)
        (req "parameter" Script.expr_encoding))
    (function
      | Ill_typed_argument (destination, entrypoint, parameter_ty, parameter) ->
          Some (destination, entrypoint, parameter_ty, parameter)
      | _ -> None)
    (fun (destination, entrypoint, parameter_ty, parameter) ->
      Ill_typed_argument (destination, entrypoint, parameter_ty, parameter)) ;
  register_error_kind
    `Permanent
    ~id:"illTypedLambdaForMultisig"
    ~title:"Ill-typed lambda for multi-signed transfer"
    ~description:
      "The provided lambda for a transfer from a multisig contract is ill-typed"
    ~pp:(fun ppf (lam, exp) ->
      Format.fprintf
        ppf
        "The provided lambda %a for multisig contract is ill-typed; %a is \
         expected."
        Michelson_v1_printer.print_expr
        lam
        Michelson_v1_printer.print_expr
        exp)
    Data_encoding.(
      obj2 (req "lam" Script.expr_encoding) (req "exp" Script.expr_encoding))
    (function Ill_typed_lambda (lam, exp) -> Some (lam, exp) | _ -> None)
    (fun (lam, exp) -> Ill_typed_lambda (lam, exp))

(* The multisig contract script written by Arthur Breitman
     https://github.com/murbard/smart-contracts/blob/abdb582d8f1fe7ba7eb15975867d8862cb70acfe/multisig/michelson/generic.tz *)
let multisig_script_string =
  {|
parameter (or (unit %default)
              (pair %main
                 (pair :payload
                    (nat %counter) # counter, used to prevent replay attacks
                    (or :action    # payload to sign, represents the requested action
                       (lambda %operation unit (list operation))
                       (pair %change_keys          # change the keys controlling the multisig
                          (nat %threshold)         # new threshold
                          (list %keys key))))     # new list of keys
                 (list %sigs (option signature))));    # signatures

storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys key))) ;

code
  {
    UNPAIR ;
    IF_LEFT
      { # Default entry point: do nothing
        # This entry point can be used to send tokens to this contract
        DROP ; NIL operation ; PAIR }
      { # Main entry point
        # Assert no token was sent:
        # to send tokens, the default entry point should be used
        PUSH mutez 0 ; AMOUNT ; ASSERT_CMPEQ ;
        SWAP ; DUP ; DIP { SWAP } ;
        DIP
          {
            UNPAIR ;
            # pair the payload with the current contract address, to ensure signatures
            # can't be replayed accross different contracts if a key is reused.
            DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;
            PACK ; # form the binary payload that we expect to be signed
            DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP
          } ;

        # Check that the counters match
        UNPAIR @stored_counter; DIP { SWAP };
        ASSERT_CMPEQ ;

        # Compute the number of valid signatures
        DIP { SWAP } ; UNPAIR @threshold @keys;
        DIP
          {
            # Running count of valid signatures
            PUSH @valid nat 0; SWAP ;
            ITER
              {
                DIP { SWAP } ; SWAP ;
                IF_CONS
                  {
                    IF_SOME
                      { SWAP ;
                        DIP
                          {
                            SWAP ; DIIP { DUUP } ;
                            # Checks signatures, fails if invalid
                            { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH} };
                            PUSH nat 1 ; ADD @valid } }
                      { SWAP ; DROP }
                  }
                  {
                    # There were fewer signatures in the list
                    # than keys. Not all signatures must be present, but
                    # they should be marked as absent using the option type.
                    FAIL
                  } ;
                SWAP
              }
          } ;
        # Assert that the threshold is less than or equal to the
        # number of valid signatures.
        ASSERT_CMPLE ;
        # Assert no unchecked signature remains
        IF_CONS {FAIL} {} ;
        DROP ;

        # Increment counter and place in storage
        DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;

        # We have now handled the signature verification part,
        # produce the operation requested by the signers.
        IF_LEFT
          { # Get operation
            UNIT ; EXEC
          }
          {
            # Change set of signatures
            DIP { CAR } ; SWAP ; PAIR ; NIL operation
          };
        PAIR }
  }
|}

(* Client_proto_context.originate expects the contract script as a Script.expr *)
let multisig_script : Script.expr =
  Michelson_v1_parser.parse_toplevel ?check:(Some true) multisig_script_string
  |> Tezos_micheline.Micheline_parser.no_parsing_error
  |> function
  | Error _ ->
      assert false
      (* This is a top level assertion, it is asserted when the client's process runs. *)
  | Ok parsing_result -> parsing_result.Michelson_v1_parser.expanded

let multisig_script_hash =
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding multisig_script
  in
  Script_expr_hash.hash_bytes [bytes]

(* The previous multisig script is the only one that the client can
   originate but the client knows how to interact with several
   versions of the multisig contract. For each version, the description
   indicates which features are available and how to interact with
   the contract. *)

type multisig_contract_description = {
  hash : Script_expr_hash.t;
  (* The hash of the contract script *)
  requires_chain_id : bool;
  (* The signatures should contain the chain identifier *)
  main_entrypoint : string option;
  (* name of the main entrypoint of the multisig contract, None means use the default entrypoint *)
  generic : bool;
      (* False means that the contract uses a custom action type, true
                       means that the contract expects the action as a (lambda unit
                       (list operation)). *)
}

(* List of known multisig contracts hashes with their kinds *)
let known_multisig_contracts : multisig_contract_description list =
  [
    {
      (* First supported version of the generic multisig contract. Supports incoming
         transfers from unauthenticated senders and outgoing transfers of
         arbitrary operation lists.

         See docs/user/multisig.rst for more details. *)
      hash = multisig_script_hash;
      requires_chain_id = true;
      main_entrypoint = Some "main";
      generic = true;
    };
    {
      (* Fourth supported version of the legacy multisig contract. This script is
         functionally equivalent to the third version but uses the [DUP 2]
         instruction introduced in Edo instead of the macro for [DIG 2; DUP; DUG 3]. *)
      hash =
        Script_expr_hash.of_b58check_exn
          "exprutz4BVGJ3Qms6qjmqvUF8sEk27H1cfqhRT17qpTdhEs5hEjbWm";
      requires_chain_id = true;
      main_entrypoint = None;
      generic = false;
    };
    {
      (* Third supported version of the legacy multisig contract. This script is
         functionally equivalent to the second version but uses the [DIP 2]
         instruction introduced in Babylon instead of the [DIIP] macro. *)
      hash =
        Script_expr_hash.of_b58check_exn
          "exprumpS39YZd26Cn4kyKUK5ezTR3at838iGWg7i6uETv8enDeAnfb";
      requires_chain_id = true;
      main_entrypoint = None;
      generic = false;
    };
    {
      (* Second supported version of the legacy multisig contract. This script
         is the one resulting from the stitching of the Babylon protocol, the
         only difference with the first version is that the chain id is part of
         the data to sign. *)
      hash =
        Script_expr_hash.of_b58check_exn
          "exprtw1v4KvQN414oEXdGuA1U3eQizuCdS8cipx8QGK8TbNLRwc3qL";
      requires_chain_id = true;
      main_entrypoint = None;
      generic = false;
    };
    {
      (* First supported version of the legacy multisig contract. This script should not
         be used anymore because it is subject to a small replay attack: when
         the test chain is forked both instances have the same address and
         counter so whatever happens on the test chain can be replayed on the
         main chain. The script has been fixed during the activation of the
         Babylon protocol. *)
      hash =
        Script_expr_hash.of_b58check_exn
          "expru4Ju9kf6MQ216FxUEsb9P6j8UhkPtsFcYP8r9XhQSRb47FZGfM";
      requires_chain_id = false;
      main_entrypoint = None;
      generic = false;
    };
  ]

let known_multisig_hashes =
  List.map (fun descr -> descr.hash) known_multisig_contracts

let check_multisig_script_hash hash :
    multisig_contract_description tzresult Lwt.t =
  match
    List.find_opt
      (fun d -> Script_expr_hash.(d.hash = hash))
      known_multisig_contracts
  with
  | None -> fail (Not_a_supported_multisig_contract hash)
  | Some d -> return d

(* Returns [Ok ()] if [~contract] is an originated contract whose code
   is [multisig_script] *)
let check_multisig_contract (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  Client_proto_context.get_script_hash cctxt ~chain ~block contract
  >>=? function
  | None -> fail (Contract_has_no_script contract)
  | Some hash -> check_multisig_script_hash hash

(* Some Michelson building functions, specific to the needs of the multisig
   interface.*)

(* The type of the lambdas consumed by the generic script *)
let lambda_action_t ~loc = lambda_t ~loc (unit_t ~loc) (operations_t ~loc)

(* Conversion functions from common types to Script_expr using the optimized representation *)
let mutez ~loc (amount : Tez.t) = int ~loc (Z.of_int64 (Tez.to_mutez amount))

let optimized_key_hash ~loc
    (key_hash : Tezos_crypto.Signature.V0.Public_key_hash.t) =
  bytes
    ~loc
    (Data_encoding.Binary.to_bytes_exn
       Tezos_crypto.Signature.V0.Public_key_hash.encoding
       key_hash)

let optimized_address ~loc ~(address : Contract.t) ~(entrypoint : string) =
  let entrypoint = match entrypoint with "default" -> "" | name -> name in
  bytes
    ~loc
    (Data_encoding.Binary.to_bytes_exn
       Data_encoding.(tup2 Contract.encoding Variable.string)
       (address, entrypoint))

let optimized_key ~loc (key : Tezos_crypto.Signature.V0.Public_key.t) =
  bytes
    ~loc
    (Data_encoding.Binary.to_bytes_exn
       Tezos_crypto.Signature.V0.Public_key.encoding
       key)

(** * Actions *)

type multisig_action =
  | Transfer of {
      amount : Tez.t;
      destination : Contract.t;
      entrypoint : string;
      parameter_type : Script.expr;
      parameter : Script.expr;
    }
  | Change_delegate of public_key_hash option
  | Lambda of Script.expr
  | Change_keys of Z.t * public_key list

let action_to_expr_generic ~loc = function
  | Transfer {amount; destination; entrypoint; parameter_type; parameter} -> (
      match Contract.is_implicit destination with
      | Some destination ->
          lambda_from_string
          @@ Managed_contract.build_lambda_for_transfer_to_implicit
               ~destination
               ~amount
          >|? left ~loc
      | None ->
          lambda_from_string
          @@ Managed_contract.build_lambda_for_transfer_to_originated
               ~destination
               ~entrypoint
               ~parameter_type
               ~parameter
               ~amount
          >|? left ~loc)
  | Lambda code -> ok Tezos_micheline.Micheline.(left ~loc (root code))
  | Change_delegate delegate ->
      lambda_from_string
      @@ Managed_contract.build_lambda_for_set_delegate ~delegate
      >|? left ~loc
  | Change_keys (threshold, keys) ->
      let optimized_keys = seq ~loc (List.map (optimized_key ~loc) keys) in
      let expr = right ~loc (pair ~loc (int ~loc threshold) optimized_keys) in
      ok expr

let action_to_expr_legacy ~loc = function
  | Transfer {amount; destination; entrypoint; parameter_type; parameter} ->
      if parameter <> Tezos_micheline.Micheline.strip_locations (unit ~loc:0)
      then error @@ Unsupported_feature_generic_call parameter
      else if
        parameter_type
        <> Tezos_micheline.Micheline.strip_locations (unit_t ~loc:0)
      then error @@ Unsupported_feature_generic_call_ty parameter_type
      else
        ok
        @@ left
             ~loc
             (pair
                ~loc
                (mutez ~loc amount)
                (optimized_address ~loc ~address:destination ~entrypoint))
  | Lambda _ -> error @@ Unsupported_feature_lambda ""
  | Change_delegate delegate ->
      let delegate_opt =
        match delegate with
        | None -> none ~loc ()
        | Some delegate -> some ~loc (optimized_key_hash ~loc delegate)
      in
      ok @@ right ~loc (left ~loc delegate_opt)
  | Change_keys (threshold, keys) ->
      let optimized_keys = seq ~loc (List.map (optimized_key ~loc) keys) in
      let expr = right ~loc (pair ~loc (int ~loc threshold) optimized_keys) in
      ok (right ~loc expr)

let action_to_expr ~loc ~generic action =
  if generic then action_to_expr_generic ~loc action
  else action_to_expr_legacy ~loc action

let action_of_expr_generic e =
  let fail () =
    fail
      (Action_deserialisation_error
         (Tezos_micheline.Micheline.strip_locations e))
  in
  match e with
  | Tezos_micheline.Micheline.Prim (_, Script.D_Left, [lam], []) ->
      return @@ Lambda (Tezos_micheline.Micheline.strip_locations lam)
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [
          Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [
                Tezos_micheline.Micheline.Int (_, threshold);
                Tezos_micheline.Micheline.Seq (_, key_bytes);
              ],
              [] );
        ],
        [] ) ->
      List.map_es
        (function
          | Tezos_micheline.Micheline.Bytes (_, s) ->
              return
              @@ Data_encoding.Binary.of_bytes_exn
                   Tezos_crypto.Signature.V0.Public_key.encoding
                   s
          | _ -> fail ())
        key_bytes
      >>=? fun keys -> return @@ Change_keys (threshold, keys)
  | _ -> fail ()

let action_of_expr_not_generic e =
  let fail () =
    fail
      (Action_deserialisation_error
         (Tezos_micheline.Micheline.strip_locations e))
  in
  match e with
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Left,
        [
          Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [
                Tezos_micheline.Micheline.Int (_, i);
                Tezos_micheline.Micheline.Bytes (_, s);
              ],
              [] );
        ],
        [] ) -> (
      match Tez.of_mutez (Z.to_int64 i) with
      | None -> fail ()
      | Some amount ->
          return
          @@ Transfer
               {
                 amount;
                 destination =
                   Data_encoding.Binary.of_bytes_exn Contract.encoding s;
                 entrypoint = "default";
                 parameter_type =
                   Tezos_micheline.Micheline.strip_locations @@ unit_t ~loc:0;
                 parameter =
                   Tezos_micheline.Micheline.strip_locations @@ unit ~loc:0;
               })
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [
          Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [Tezos_micheline.Micheline.Prim (_, Script.D_None, [], [])],
              [] );
        ],
        [] ) ->
      return @@ Change_delegate None
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [
          Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [
                Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Some,
                    [Tezos_micheline.Micheline.Bytes (_, s)],
                    [] );
              ],
              [] );
        ],
        [] ) ->
      return
      @@ Change_delegate
           (Some
              (Data_encoding.Binary.of_bytes_exn
                 Tezos_crypto.Signature.V0.Public_key_hash.encoding
                 s))
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [
          Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Right,
              [
                Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [
                      Tezos_micheline.Micheline.Int (_, threshold);
                      Tezos_micheline.Micheline.Seq (_, key_bytes);
                    ],
                    [] );
              ],
              [] );
        ],
        [] ) ->
      List.map_es
        (function
          | Tezos_micheline.Micheline.Bytes (_, s) ->
              return
              @@ Data_encoding.Binary.of_bytes_exn
                   Tezos_crypto.Signature.V0.Public_key.encoding
                   s
          | _ -> fail ())
        key_bytes
      >>=? fun keys -> return @@ Change_keys (threshold, keys)
  | _ -> fail ()

let action_of_expr ~generic =
  if generic then action_of_expr_generic else action_of_expr_not_generic

type key_list = Tezos_crypto.Signature.V0.Public_key.t list

(* The relevant information that we can get about a multisig smart contract *)
type multisig_contract_information = {
  counter : Z.t;
  threshold : Z.t;
  keys : key_list;
}

let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  let open Client_proto_context in
  let open Tezos_micheline.Micheline in
  get_storage cctxt ~chain ~block ~unparsing_mode:Readable contract
  >>=? fun storage_opt ->
  match storage_opt with
  | None -> fail (Contract_has_no_storage contract)
  | Some storage -> (
      match root storage with
      | Prim
          ( _,
            D_Pair,
            [Int (_, counter); Int (_, threshold); Seq (_, key_nodes)],
            _ ) ->
          List.map_es
            (function
              | String (_, key_str) ->
                  return
                  @@ Tezos_crypto.Signature.V0.Public_key.of_b58check_exn
                       key_str
              | _ -> fail (Contract_has_unexpected_storage contract))
            key_nodes
          >>=? fun keys -> return {counter; threshold; keys}
      | _ -> fail (Contract_has_unexpected_storage contract))

let multisig_create_storage ~counter ~threshold ~keys () :
    Script.expr tzresult Lwt.t =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let open Tezos_micheline.Micheline in
  List.map_es
    (fun key ->
      let key_str = Tezos_crypto.Signature.V0.Public_key.to_b58check key in
      return (String (loc, key_str)))
    keys
  >>=? fun l ->
  return @@ strip_locations
  @@ pair ~loc (int ~loc counter) (pair ~loc (int ~loc threshold) (seq ~loc l))

(* Client_proto_context.originate expects the initial storage as a string *)
let multisig_storage_string ~counter ~threshold ~keys () =
  multisig_create_storage ~counter ~threshold ~keys () >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let multisig_create_param ~counter ~generic ~action ~optional_signatures () :
    Script.expr tzresult Lwt.t =
  let loc = 0 in
  let open Tezos_micheline.Micheline in
  List.map_es
    (fun sig_opt ->
      match sig_opt with
      | None -> return @@ none ~loc ()
      | Some signature ->
          return
          @@ some
               ~loc
               (String (loc, Tezos_crypto.Signature.V0.to_b58check signature)))
    optional_signatures
  >>=? fun l ->
  Lwt.return @@ action_to_expr ~loc:0 ~generic action >>=? fun expr ->
  return @@ strip_locations
  @@ pair ~loc (pair ~loc (int ~loc counter) expr) (Seq (loc, l))

let multisig_param_string ~counter ~action ~optional_signatures ~generic () =
  multisig_create_param ~counter ~action ~optional_signatures ~generic ()
  >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract =
  let address =
    bytes ~loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract)
  in
  if descr.requires_chain_id then
    let chain_id_bytes =
      bytes ~loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
    in
    pair ~loc chain_id_bytes address
  else address

let multisig_bytes ~counter ~action ~contract ~chain_id ~descr () =
  let loc = 0 in
  Lwt.return @@ action_to_expr ~loc ~generic:descr.generic action
  >>=? fun expr ->
  let triple =
    pair
      ~loc
      (get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract)
      (pair ~loc (int ~loc counter) expr)
  in
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding
    @@ Tezos_micheline.Micheline.strip_locations @@ triple
  in
  return @@ Bytes.cat (Bytes.of_string "\005") bytes

let check_threshold ~threshold ~keys () =
  let threshold = Z.to_int threshold in
  if Compare.List_length_with.(keys < threshold) then
    fail (Threshold_too_high (threshold, List.length keys))
  else if Compare.Int.(threshold <= 0) then
    fail (Non_positive_threshold threshold)
  else return_unit

let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?branch ?fee ?gas_limit ?storage_limit
    ?verbose_signing ~delegate ~threshold ~keys ~balance ~source ~src_pk ~src_sk
    ~fee_parameter () =
  multisig_storage_string ~counter:Z.zero ~threshold ~keys ()
  >>=? fun initial_storage ->
  check_threshold ~threshold ~keys () >>=? fun () ->
  Client_proto_context.originate_contract
    cctxt
    ~chain
    ~block
    ?branch
    ?confirmations
    ?dry_run
    ?fee
    ?gas_limit
    ?storage_limit
    ?verbose_signing
    ~delegate
    ~initial_storage
    ~balance
    ~source
    ~src_pk
    ~src_sk
    ~code:multisig_script
    ~fee_parameter
    ()

type multisig_prepared_action = {
  bytes : Bytes.t;
  threshold : Z.t;
  keys : public_key list;
  counter : Z.t;
  entrypoint : string option;
  generic : bool;
}

let check_parameter_type (cctxt : #Protocol_client_context.full) ?gas ?legacy
    ~destination ~entrypoint ~parameter_type ~parameter () =
  trace
    (Ill_typed_argument (destination, entrypoint, parameter_type, parameter))
  @@ Plugin.RPC.Scripts.typecheck_data
       cctxt
       (cctxt#chain, cctxt#block)
       ~data:parameter
       ~ty:parameter_type
       ?gas
       ?legacy
  >>=? fun _ -> return_unit

let check_action (cctxt : #Protocol_client_context.full) ~action ~balance ?gas
    ?legacy () =
  match action with
  | Change_keys (threshold, keys) ->
      check_threshold ~threshold ~keys () >>=? fun () -> return_unit
  | Transfer {amount; destination; entrypoint; parameter_type; parameter} ->
      check_parameter_type
        cctxt
        ~destination
        ~entrypoint
        ~parameter_type
        ~parameter
        ()
      >>=? fun () ->
      if Tez.(amount > balance) then
        (* This is warning only because the contract can be filled
           before sending the signatures or even in the same
           transaction *)
        Format.eprintf
          "Transferred amount is bigger than current multisig balance" ;
      return_unit
  | Lambda code ->
      let action_t =
        Tezos_micheline.Micheline.strip_locations (lambda_action_t ~loc:0)
      in
      trace (Ill_typed_lambda (code, action_t))
      @@ Plugin.RPC.Scripts.typecheck_data
           cctxt
           (cctxt#chain, cctxt#block)
           ~data:code
           ~ty:action_t
           ?gas
           ?legacy
      >>=? fun _remaining_gas -> return_unit
  | _ -> return_unit

let prepare_multisig_transaction (cctxt : #Protocol_client_context.full) ~chain
    ~block ~multisig_contract ~action () =
  let contract = multisig_contract in
  check_multisig_contract cctxt ~chain ~block contract >>=? fun descr ->
  multisig_get_information cctxt ~chain ~block contract
  >>=? fun {counter; threshold; keys} ->
  Chain_services.chain_id cctxt ~chain () >>=? fun chain_id ->
  multisig_bytes ~counter ~action ~contract ~descr ~chain_id ()
  >>=? fun bytes ->
  Client_proto_context.get_balance
    cctxt
    ~chain:cctxt#chain
    ~block:cctxt#block
    contract
  >>=? fun balance ->
  check_action cctxt ~action ~balance () >>=? fun () ->
  return
    {
      bytes;
      threshold;
      keys;
      counter;
      entrypoint = descr.main_entrypoint;
      generic = descr.generic;
    }

let check_multisig_signatures ~bytes ~threshold ~keys signatures =
  let key_array = Array.of_list keys in
  let nkeys = Array.length key_array in
  let opt_sigs_arr = Array.make nkeys None in
  let matching_key_found = ref false in
  let check_signature_against_key_number signature i key =
    if Tezos_crypto.Signature.V0.check key signature bytes then (
      matching_key_found := true ;
      opt_sigs_arr.(i) <- Some signature)
  in
  List.iter_ep
    (fun signature ->
      matching_key_found := false ;
      List.iteri (check_signature_against_key_number signature) keys ;
      fail_unless !matching_key_found (Invalid_signature signature))
    signatures
  >>=? fun () ->
  let opt_sigs = Array.to_list opt_sigs_arr in
  let signature_count =
    List.fold_left
      (fun n sig_opt -> match sig_opt with Some _ -> n + 1 | None -> n)
      0
      opt_sigs
  in
  let threshold_int = Z.to_int threshold in
  if signature_count >= threshold_int then return opt_sigs
  else fail (Not_enough_signatures (threshold_int, signature_count))

let call_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk
    ~multisig_contract ~action ~signatures ~amount ?fee ?gas_limit
    ?storage_limit ?counter ~fee_parameter () =
  prepare_multisig_transaction cctxt ~chain ~block ~multisig_contract ~action ()
  >>=? fun {
             bytes;
             threshold;
             keys;
             counter = stored_counter;
             entrypoint;
             generic;
           } ->
  check_multisig_signatures ~bytes ~threshold ~keys signatures
  >>=? fun optional_signatures ->
  multisig_param_string
    ~counter:stored_counter
    ~action
    ~optional_signatures
    ~generic
    ()
  >>=? fun arg ->
  Client_proto_context.transfer
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~destination:multisig_contract
    ?entrypoint
    ~arg
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ?verbose_signing
    ()

let action_of_bytes ~multisig_contract ~stored_counter ~descr ~chain_id bytes =
  if
    Compare.Int.(Bytes.length bytes >= 1)
    && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
  then
    let nbytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
    match Data_encoding.Binary.of_bytes_opt Script.expr_encoding nbytes with
    | None -> fail (Bytes_deserialisation_error bytes)
    | Some e -> (
        match Tezos_micheline.Micheline.root e with
        | Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [
                Tezos_micheline.Micheline.Bytes (_, contract_bytes);
                Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [Tezos_micheline.Micheline.Int (_, counter); e],
                    [] );
              ],
              [] )
          when not descr.requires_chain_id ->
            let contract =
              Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
            in
            if counter = stored_counter then
              if Contract.(multisig_contract = contract) then
                action_of_expr ~generic:descr.generic e
              else
                fail (Bad_deserialized_contract (contract, multisig_contract))
            else fail (Bad_deserialized_counter (counter, stored_counter))
        | Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [
                Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [
                      Tezos_micheline.Micheline.Bytes (_, chain_id_bytes);
                      Tezos_micheline.Micheline.Bytes (_, contract_bytes);
                    ],
                    [] );
                Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [Tezos_micheline.Micheline.Int (_, counter); e],
                    [] );
              ],
              [] )
          when descr.requires_chain_id ->
            let contract =
              Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
            in
            let cid =
              Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes
            in
            if counter = stored_counter then
              if multisig_contract = contract && chain_id = cid then
                action_of_expr ~generic:descr.generic e
              else
                fail (Bad_deserialized_contract (contract, multisig_contract))
            else fail (Bad_deserialized_counter (counter, stored_counter))
        | _ -> fail (Bytes_deserialisation_error bytes))
  else fail (Bytes_deserialisation_error bytes)

let call_multisig_on_bytes (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk
    ~multisig_contract ~bytes ~signatures ~amount ?fee ?gas_limit ?storage_limit
    ?counter ~fee_parameter () =
  multisig_get_information cctxt ~chain ~block multisig_contract
  >>=? fun info ->
  check_multisig_contract cctxt ~chain ~block multisig_contract
  >>=? fun descr ->
  Chain_services.chain_id cctxt ~chain () >>=? fun chain_id ->
  action_of_bytes
    ~multisig_contract
    ~stored_counter:info.counter
    ~chain_id
    ~descr
    bytes
  >>=? fun action ->
  call_multisig
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~multisig_contract
    ~action
    ~signatures
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ?verbose_signing
    ()