ligo/src/proto/bootstrap/services_registration.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2016.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Tezos_context

let rpc_services = ref (RPC.empty : Context.t RPC.directory)
let register0 s f =
  rpc_services :=
    RPC.register !rpc_services (s RPC.Path.root)
      (fun ctxt () ->
         ( Tezos_context.init ctxt >>=? fun ctxt ->
           f ctxt ) >>= RPC.Answer.return)
let register1 s f =
  rpc_services :=
    RPC.register !rpc_services (s RPC.Path.root)
      (fun ctxt arg ->
         ( Tezos_context.init ctxt >>=? fun ctxt ->
           f ctxt arg ) >>= RPC.Answer.return)
let register2 s f =
  rpc_services :=
    RPC.register !rpc_services (s RPC.Path.root)
      (fun (ctxt, arg1) arg2 ->
         ( Tezos_context.init ctxt >>=? fun ctxt ->
           f ctxt arg1 arg2 ) >>= RPC.Answer.return)
let register1_noctxt s f =
  rpc_services :=
    RPC.register !rpc_services (s RPC.Path.root)
      (fun _ arg -> f arg >>= RPC.Answer.return)

(*-- Constants ---------------------------------------------------------------*)

let cycle_length ctxt =
  return @@ Constants.cycle_length ctxt

let () = register0 Services.Constants.cycle_length cycle_length

let voting_period_length ctxt =
  return @@ Constants.voting_period_length ctxt

let () =
  register0
    Services.Constants.voting_period_length
    voting_period_length

let time_before_reward ctxt =
  return @@ Constants.time_before_reward ctxt

let () = register0 Services.Constants.time_before_reward time_before_reward

let time_between_slots ctxt =
  return @@ Constants.time_between_slots ctxt

let () = register0 Services.Constants.time_between_slots time_between_slots

let first_free_mining_slot ctxt =
  return @@ Constants.first_free_mining_slot ctxt

let () =
  register0 Services.Constants.first_free_mining_slot first_free_mining_slot

let max_signing_slot ctxt =
  return @@ Constants.max_signing_slot ctxt

let () = register0 Services.Constants.max_signing_slot max_signing_slot

let instructions_per_transaction ctxt =
  return @@ Constants.instructions_per_transaction ctxt

let () =
  register0
    Services.Constants.instructions_per_transaction instructions_per_transaction

let proof_of_work_threshold ctxt =
  return @@ Constants.proof_of_work_threshold ctxt

let () = register0 Services.Constants.proof_of_work_threshold proof_of_work_threshold

let () =
  register1_noctxt Services.Constants.errors
    (fun () ->
       Lwt.return (Data_encoding.Json.(schema (error_encoding ()))))

let () =
  register1_noctxt Services.Constants.bootstrap
    (fun () -> Lwt.return Bootstrap.accounts)

(*-- Context -----------------------------------------------------------------*)

let level ctxt =
  Level.current ctxt >>=? fun level ->
  match Level.pred ctxt level with
  | None -> fail (Apply.Internal_error "unexpected level in context")
  | Some level -> return level

let () = register0 Services.Context.level level

let next_level ctxt =
  Level.current ctxt

let () = register0 Services.Context.next_level next_level

(*-- Context.Nonce -----------------------------------------------------------*)

let nonce ctxt raw_level () =
  let level = Level.from_raw ctxt raw_level in
  Nonce.get ctxt level >>= function
  | Ok (Revealed nonce) -> return (Services.Context.Nonce.Revealed nonce)
  | Ok (Unrevealed { nonce_hash }) ->
      return (Services.Context.Nonce.Missing nonce_hash)
  | Error _ -> return Services.Context.Nonce.Forgotten

let () = register2 Services.Context.Nonce.get nonce

let nonce_hash ctxt =
  level ctxt >>=? fun level ->
  Nonce.get ctxt level >>=? function
  | Unrevealed { nonce_hash } -> return nonce_hash
  | _ -> assert false

let () = register0 Services.Context.Nonce.hash nonce_hash

(*-- Context.Key -------------------------------------------------------------*)

let get_key ctxt hash () =
  Public_key.get ctxt hash >>=? fun pk ->
  return (hash, pk)

let () = register2 Services.Context.Key.get get_key
let () = register0 Services.Context.Key.list Public_key.list

(*-- Context.Contract --------------------------------------------------------*)

let () =
  register0 Services.Context.Contract.list Contract.list

let () =
  let register2 s f =
    rpc_services :=
      RPC.register !rpc_services (s RPC.Path.root)
        (fun (ctxt, contract) arg ->
           ( Tezos_context.init ctxt >>=? fun ctxt ->
             Contract.exists ctxt contract >>=? function
             | true -> f ctxt contract arg
             | false -> raise Not_found ) >>= RPC.Answer.return) in
  let register2' s f = register2 s (fun ctxt a1 () -> f ctxt a1) in
  register2' Services.Context.Contract.balance Contract.get_balance ;
  register2' Services.Context.Contract.manager Contract.get_manager ;
  register2' Services.Context.Contract.delegate Contract.get_delegate_opt ;
  register2' Services.Context.Contract.counter Contract.get_counter ;
  register2' Services.Context.Contract.spendable Contract.is_spendable ;
  register2' Services.Context.Contract.delegatable Contract.is_delegatable ;
  register2' Services.Context.Contract.script Contract.get_script ;
  register2' Services.Context.Contract.assets Contract.get_assets ;
  register2' Services.Context.Contract.get (fun ctxt contract ->
      Contract.get_balance ctxt contract >>=? fun balance ->
      Contract.get_manager ctxt contract >>=? fun manager ->
      Contract.get_delegate_opt ctxt contract >>=? fun delegate ->
      Contract.get_counter ctxt contract >>=? fun counter ->
      Contract.is_delegatable ctxt contract >>=? fun delegatable ->
      Contract.is_spendable ctxt contract >>=? fun spendable ->
      Contract.get_script ctxt contract >>=? fun script ->
      Contract.get_assets ctxt contract >>=? fun assets ->
      return { Services.Context.Contract.manager ; balance ;
               spendable ; delegate = (delegatable, delegate) ;
               script ; assets ; counter }) ;
  ()

(*-- Helpers -----------------------------------------------------------------*)

let minimal_timestamp ctxt prio =
  let prio = match prio with None -> 0l | Some p -> Int32.of_int p in
  Mining.minimal_time ctxt prio

let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp

let () =
  register1 Services.Helpers.run_code
    (fun ctxt (script, storage, input, amount, contract) ->
       let amount =
         match amount with
         | Some amount -> amount
         | None ->
             match Tez.of_cents 100_00L with
             | Some tez -> tez
             | None -> Tez.zero in
       let contract =
         match contract with
         | Some contract -> contract
         | None ->
             Contract.default_contract
               (List.hd Bootstrap.accounts).Bootstrap.public_key_hash in
       let storage =
         { Script.storage ; storage_type = script.storage_type } in
       let qta =
         Constants.instructions_per_transaction ctxt in
       Script_interpreter.execute
         contract (* transaction initiator *)
         contract (* script owner *)
         ctxt storage script amount input
         qta >>=? fun (sto, ret, _qta, _ctxt) ->
       Error_monad.return (sto, ret))

let () =
  register1 Services.Helpers.typecheck_code
    Script_ir_translator.typecheck_code

let () =
  register1 Services.Helpers.typecheck_tagged_data
    Script_ir_translator.typecheck_tagged_data

let () =
  register1 Services.Helpers.typecheck_untagged_data
    Script_ir_translator.typecheck_untagged_data

let () =
  register1 Services.Helpers.hash_data
    (fun _ctxt expr -> return (Script.hash_expr expr))

let compute_level ctxt raw offset =
  return (Level.from_raw ctxt ?offset raw)

let () = register2 Services.Helpers.level compute_level

let levels ctxt cycle () =
  return (Level.levels_in_cycle ctxt cycle)

let () = register2 Services.Helpers.levels levels


(*-- Helpers.Rights ----------------------------------------------------------*)

let default_max_mining_priority ctxt arg =
  let default = Constants.first_free_mining_slot ctxt in
  match arg with
  | None -> Int32.mul 2l default
  | Some m -> Int32.of_int m

let mining_rights ctxt level max =
  let max = Int32.to_int (default_max_mining_priority ctxt max) in
  Mining.mining_priorities ctxt level >>=? fun contract_list ->
  let rec loop l n =
    match n with
    | 0 -> return []
    | n ->
        let Misc.LCons (h, t) = l in
        t () >>=? fun t ->
        loop t (pred n) >>=? fun t ->
        return (h :: t)
  in
  loop contract_list max >>=? fun prio ->
  return (level.level, prio)

let () =
  register1 Services.Helpers.Rights.mining_rights
    (fun ctxt max ->
       Level.current ctxt >>=? fun level ->
       mining_rights ctxt level max >>=? fun (raw_level, slots) ->
       begin
         Lwt_list.filter_map_p (fun x -> x) @@
         List.mapi
           (fun prio c ->
              Mining.minimal_time
                ctxt (Int32.of_int prio) >>= function
              | Error _ -> Lwt.return None
              | Ok timestamp -> Lwt.return (Some (c, timestamp)))
           slots
       end >>= fun timed_slots ->
       return (raw_level, timed_slots))

let () =
  register2 Services.Helpers.Rights.mining_rights_for_level
    (fun ctxt raw_level max ->
       let level = Level.from_raw ctxt raw_level in
       mining_rights ctxt level max)

let mining_rights_for_delegate
    ctxt contract (max_priority, min_level, max_level) =
  let max_priority = default_max_mining_priority ctxt max_priority in
  Level.current ctxt >>=? fun current_level ->
  let max_level =
    match max_level with
    | None ->
        Level.last_level_in_cycle ctxt @@
        Cycle.succ current_level.cycle
    | Some l -> Level.from_raw ctxt l in
  let min_level = match min_level with
    | None -> current_level
    | Some l -> Level.from_raw ctxt l in
  let rec loop level =
    if Level.(>) level max_level
    then return []
    else
      loop (Level.succ ctxt level) >>=? fun t ->
      Mining.first_mining_priorities
        ctxt ~max_priority contract level >>=? fun priorities ->
      let raw_level = level.level in
      Lwt_list.map_p
        (fun priority ->
           Mining.minimal_time ctxt priority >>= function
           | Ok time -> Lwt.return (raw_level, Int32.to_int priority, Some time)
               | Error _ -> Lwt.return (raw_level, Int32.to_int priority, None))
        priorities >>= fun priorities ->
      return (priorities @ t)
  in
  loop min_level

let () =
  register2 Services.Helpers.Rights.mining_rights_for_delegate
    mining_rights_for_delegate

let default_max_endorsement_priority ctxt arg =
  let default = Constants.max_signing_slot ctxt in
  match arg with
  | None -> default
  | Some m -> m

let endorsement_rights ctxt level max =
  let max = default_max_endorsement_priority ctxt max in
  Mining.endorsement_priorities ctxt level >>=? fun contract_list ->
  let rec loop l n =
    match n with
    | 0 -> return []
    | n ->
        let Misc.LCons (h, t) = l in
        t () >>=? fun t ->
        loop t (pred n) >>=? fun t ->
        return (h :: t)
  in
  loop contract_list max >>=? fun prio ->
  return (level.level, prio)

let () =
  register1 Services.Helpers.Rights.endorsement_rights
    (fun ctxt max ->
       Level.current ctxt >>=? fun level ->
       endorsement_rights ctxt (Level.succ ctxt level) max) ;
  register2 Services.Helpers.Rights.endorsement_rights_for_level
    (fun ctxt raw_level max ->
       let level = Level.from_raw ctxt raw_level in
       endorsement_rights ctxt level max)

let endorsement_rights_for_delegate
    ctxt contract (max_priority, min_level, max_level) =
  let max_priority =
    Int32.of_int @@
    default_max_endorsement_priority ctxt max_priority in
  Level.current ctxt >>=? fun current_level ->
  let max_level =
    match max_level with
    | None ->
        Level.last_level_in_cycle ctxt @@
        Cycle.succ (Cycle.succ current_level.cycle)
    | Some l -> Level.from_raw ctxt l in
  let min_level = match min_level with
    | None -> Level.succ ctxt current_level
    | Some l -> Level.from_raw ctxt l in
  let rec loop level =
    if Level.(>) level max_level
    then return []
    else
      loop (Level.succ ctxt level) >>=? fun t ->
      Mining.first_endorsement_slots
        ctxt ~max_priority contract level >>=? fun slots ->
      let raw_level = level.level in
      let slots =
        List.rev_map
          (fun slot -> (raw_level, Int32.to_int slot, None))
          slots in
      return (List.rev_append slots t)
  in
  loop min_level

let () =
  register2 Services.Helpers.Rights.endorsement_rights_for_delegate
    endorsement_rights_for_delegate

(*-- Helpers.Forge -----------------------------------------------------------*)

let operation_public_key ctxt = function
  | None -> return None
  | Some public_key ->
      let hash = Ed25519.hash public_key in
      Public_key.get_option ctxt hash >>=? function
      | None -> return (Some public_key)
      | Some _ -> return None

let get_contracts ctxt op =
  match op with
  | Anonymous_operations _
  | Sourced_operations (Delegate_operations _) -> return (ctxt, None)
  | Sourced_operations (Manager_operations { operations }) ->
      fold_left_s
        (fun (ctxt, contracts) operation ->
           match operation with
           | Origination { manager ; delegate ; script ;
                           spendable ; delegatable ; credit } ->
               Contract.originate ctxt
                 ~balance:credit ~manager ~delegate
                 ~spendable ~delegatable ~script >>=? fun (ctxt, contract) ->
               return (ctxt, contract :: contracts)
           | _ -> return (ctxt, contracts))
        (ctxt, []) operations >>=? fun (ctxt, contracts) ->
      match contracts with
      | [] -> return (ctxt, None)
      | _ -> return (ctxt, Some (List.rev contracts))

let forge_operations ctxt (shell, proto) =
  get_contracts ctxt proto >>=? fun (_ctxt, contracts) ->
  return (Operation.forge shell proto, contracts)

let () = register1 Services.Helpers.Forge.operations forge_operations

let forge_block _ctxt
    (net_id, predecessor, timestamp, fitness, operations,
     raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
  let priority = Int32.of_int priority in
  let mining_slot = (raw_level, priority) in
  return (Block.forge_header
            { net_id ; predecessor ; timestamp ; fitness ; operations }
            { mining_slot ; seed_nonce_hash ; proof_of_work_nonce })

let () = register1 Services.Helpers.Forge.block forge_block

(*-- Helpers.Parse -----------------------------------------------------------*)

let dummy_hash = Operation_hash.hash_bytes []

let check_signature ctxt signature shell contents =
  match contents with
  | Anonymous_operations _ -> return ()
  | Sourced_operations (Manager_operations op) ->
      begin
        match op.public_key with
        | Some key -> return key
        | None ->
            Contract.get_manager ctxt op.source >>=? fun manager ->
            Public_key.get ctxt manager
      end >>=? fun public_key ->
      Operation.check_signature public_key
        { signature ; shell ; contents ; hash = dummy_hash }
  | Sourced_operations (Delegate_operations { source }) ->
      Operation.check_signature source
        { signature ; shell ; contents ; hash = dummy_hash }

let parse_operations ctxt (shell, bytes, check) =
  Operation.parse_proto bytes >>=? fun (proto, signature) ->
  begin
    match check with
    | Some true -> check_signature ctxt signature shell proto
    | Some false | None -> return ()
  end >>=? fun () ->
  return proto

let () = register1 Services.Helpers.Parse.operations parse_operations

(*****)

let rpc_services = !rpc_services