ligo/src/client/client_commands.ml

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

type ('a, 'b) lwt_format =
  ('a, Format.formatter, unit, 'b Lwt.t) format4

type cfg = {
  (* cli options *)
  base_dir : string ;
  config_file : string ;
  print_timings : bool ;
  force : bool ;
  block : Node_rpc_services.Blocks.block ;

  (* network options (cli and config file) *)
  incoming_addr : string ;
  incoming_port : int ;
  tls : bool ;

  (* webclient options *)
  web_port : int ;
}

type context =
  { config : cfg ;
    error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
    warning : 'a. ('a, unit) lwt_format -> 'a ;
    message : 'a. ('a, unit) lwt_format -> 'a ;
    answer : 'a. ('a, unit) lwt_format -> 'a ;
    log : 'a. string -> ('a, unit) lwt_format -> 'a }

type command = (context, unit) Cli_entries.command

(* Default config *)

let (//) = Filename.concat

let home =
  try Sys.getenv "HOME"
  with Not_found -> "/root"

let default_base_dir = home // ".tezos-client"

let default_cfg_of_base_dir base_dir = {
  base_dir ;
  config_file = base_dir // "config";
  print_timings = false ;
  force = false ;
  block = `Prevalidation ;

  incoming_addr = "127.0.0.1" ;
  incoming_port = 8732 ;
  tls = false ;

  web_port = 8080 ;
}

let default_cfg = default_cfg_of_base_dir default_base_dir

let make_context ?(config = default_cfg) log =
  let error fmt =
    Format.kasprintf
      (fun msg ->
         Lwt.fail (Failure msg))
      fmt in
  let warning fmt =
    Format.kasprintf
      (fun msg -> log "stderr" msg)
      fmt in
  let message fmt =
    Format.kasprintf
      (fun msg -> log "stdout" msg)
      fmt in
  let answer =
    message in
  let log name fmt =
    Format.kasprintf
      (fun msg -> log name msg)
      fmt in
  { config ; error ; warning ; message ; answer ; log }

let ignore_context =
  make_context (fun _ _ -> Lwt.return ())

exception Version_not_found

let versions = Protocol_hash.Table.create 7

let get_versions () =
  Protocol_hash.Table.fold
    (fun k c acc -> (k, c) :: acc)
    versions
    []

let register name commands =
  let previous =
    try Protocol_hash.Table.find versions name
    with Not_found -> [] in
  Protocol_hash.Table.add versions name (commands @ previous)

let commands_for_version version =
  try Protocol_hash.Table.find versions version
  with Not_found -> raise Version_not_found