From 087a097cf7f1e9862b8861789cecf74e487c4b4b Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Tue, 22 Nov 2016 14:23:40 +0100 Subject: [PATCH 1/8] Client: cli_entries module refactoring. --- src/client/client_aliases.ml | 101 +++-- src/client/client_aliases.mli | 6 +- src/client/client_generic_rpcs.ml | 4 +- src/client/client_node_rpcs.ml | 54 +-- src/client/client_protocols.ml | 9 +- .../embedded/bootstrap/client_proto_args.ml | 6 +- .../embedded/bootstrap/client_proto_args.mli | 2 +- .../bootstrap/client_proto_context.ml | 72 ++-- .../bootstrap/client_proto_contracts.ml | 60 +-- .../bootstrap/client_proto_contracts.mli | 4 +- .../bootstrap/client_proto_programs.ml | 13 +- .../bootstrap/mining/client_mining_main.ml | 8 +- src/client_main.ml | 25 +- src/utils/cli_entries.ml | 344 ++++++++++-------- src/utils/cli_entries.mli | 41 +-- 15 files changed, 401 insertions(+), 348 deletions(-) diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index cb5464cb6..19f2c45e7 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -33,16 +33,16 @@ module type Alias = sig val save : (Lwt_io.file_name * t) list -> unit Lwt.t val to_source : t -> string Lwt.t val alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * t -> 'a) Cli_entries.params val fresh_alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (string -> 'a) Cli_entries.params val source_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (t -> 'a) Cli_entries.params end @@ -115,9 +115,8 @@ module Alias = functor (Entity : Entity) -> struct (if not Client_config.force#get then Lwt_list.iter_s (fun (n, v) -> if n = name && v = value then - (message "The %s alias %s already exists with the same value." Entity.name n ; - keep := true ; - return ()) + (keep := true ; + message "The %s alias %s already exists with the same value." Entity.name n) else if n = name && v <> value then error "another %s is already aliased as %s, use -force true to update" Entity.name n else if n <> name && v = value then @@ -130,8 +129,7 @@ module Alias = functor (Entity : Entity) -> struct return () else save list >>= fun () -> - message "New %s alias '%s' saved." Entity.name name ; - return () + message "New %s alias '%s' saved." Entity.name name let del name = load () >>= fun list -> @@ -140,55 +138,56 @@ module Alias = functor (Entity : Entity) -> struct let save list = save list >>= fun () -> - message "Successful update of the %s alias file." Entity.name ; - return () + message "Successful update of the %s alias file." Entity.name include Entity - let alias_param ?(n = "name") ?(desc = "existing " ^ name ^ " alias") next = - Param (n, desc, (fun s -> find s >>= fun v -> return (s, v)), next) + let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next = + param ~name ~desc + (fun s -> find s >>= fun v -> return (s, v)) + next - let fresh_alias_param ?(n = "new") ?(desc = "new " ^ name ^ " alias") next = - Param (n, - desc, - (fun s -> - load () >>= fun list -> - if not Client_config.force#get then - Lwt_list.iter_s (fun (n, _v) -> - if n = name then - error "the %s alias %s already exists, use -force true to update" Entity.name n - else return ()) - list >>= fun () -> - return s - else return s), - next) + let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next = + param ~name ~desc + (fun s -> + load () >>= fun list -> + if not Client_config.force#get then + Lwt_list.iter_s (fun (n, _v) -> + if n = name then + error "the %s alias %s already exists, use -force true to update" Entity.name n + else return ()) + list >>= fun () -> + return s + else return s) + next - let source_param ?(n = "src") ?(desc = "source " ^ name) next = - Param (n, - desc ^ "\n" - ^ "can be an alias, file or litteral (autodetected in this order)\n\ - use 'file:path', 'text:litteral' or 'alias:name' to force", - (fun s -> - let read path = - catch - (fun () -> Lwt_io.(with_file ~mode:Input path read)) - (fun exn -> param_error "cannot read file (%s)" (Printexc.to_string exn)) - >>= of_source in - match Utils.split ~limit:1 ':' s with - | [ "alias" ; alias ]-> - find alias - | [ "text" ; text ] -> - of_source text - | [ "file" ; path ] -> - read path - | _ -> + let source_param ?(name = "src") ?(desc = "source " ^ name) next = + let desc = + desc ^ "\n" + ^ "can be an alias, file or litteral (autodetected in this order)\n\ + use 'file:path', 'text:litteral' or 'alias:name' to force" in + param ~name ~desc + (fun s -> + let read path = + catch + (fun () -> Lwt_io.(with_file ~mode:Input path read)) + (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn)) + >>= of_source in + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "text" ; text ] -> + of_source text + | [ "file" ; path ] -> + read path + | _ -> + catch + (fun () -> find s) + (fun _ -> catch - (fun () -> find s) - (fun _ -> - catch - (fun () -> read s) - (fun _ -> of_source s))), - next) + (fun () -> read s) + (fun _ -> of_source s))) + next let name d = rev_find d >>= function diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli index 70296652c..a8f75e8af 100644 --- a/src/client/client_aliases.mli +++ b/src/client/client_aliases.mli @@ -29,16 +29,16 @@ module type Alias = sig val save : (Lwt_io.file_name * t) list -> unit Lwt.t val to_source : t -> string Lwt.t val alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * t -> 'a) Cli_entries.params val fresh_alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (string -> 'a) Cli_entries.params val source_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (t -> 'a) Cli_entries.params end diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 402b5ea94..22509b65a 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -332,9 +332,9 @@ let commands = Cli_entries.([ ~desc: "list all understood protocol versions" (fixed [ "list" ; "versions" ]) (fun () -> - List.iter + Lwt_list.iter_s (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver) - (Client_version.get_versions ()) ; return ()) ; + (Client_version.get_versions ())) ; command ~tags: [ "low-level" ; "local" ] ~group: "rpc" diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 247195539..def106a08 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -13,31 +13,13 @@ open Lwt open Cli_entries open Logging.RPC -let log_file = - let open CalendarLib in - Printer.Precise_Calendar.sprint - "%Y-%m-%dT%H:%M:%SZ.log" - (Calendar.Precise.now ()) - -let with_log_file f = - Utils.create_dir Client_config.(base_dir#get // "logs") >>= fun () -> - Lwt_io.with_file - ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] - ~mode: Lwt_io.Output - Client_config.(base_dir#get // "logs" // log_file) - f - let log_request cpt url req = - with_log_file - (fun fp -> - Lwt_io.fprintf fp">>>>%d: %s\n%s\n" cpt url req >>= fun () -> - Lwt_io.flush fp) + Cli_entries.log "requests" + ">>>>%d: %s\n%s\n" cpt url req let log_response cpt code ans = - with_log_file - (fun fp -> - Lwt_io.fprintf fp"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans >>= fun () -> - Lwt_io.flush fp) + Cli_entries.log "requests" + "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans let cpt = ref 0 let make_request service json = @@ -67,9 +49,10 @@ let get_streamed_json service json = let ansbody = Cohttp_lwt_body.to_stream ansbody in match code, ansbody with | #Cohttp.Code.success_status, ansbody -> - if Client_config.print_timings#get then + (if Client_config.print_timings#get then message "Request to /%s succeeded in %gs" - (String.concat "/" service) time ; + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> Lwt.return ( Lwt_stream.filter_map_s (function @@ -80,11 +63,12 @@ let get_streamed_json service json = Lwt.return None) (Data_encoding.Json.from_stream ansbody)) | err, _ansbody -> - if Client_config.print_timings#get then + (if Client_config.print_timings#get then message "Request to /%s failed in %gs" - (String.concat "/" service) time ; + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) @@ -93,9 +77,10 @@ let get_json service json = Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> match code, ansbody with | #Cohttp.Code.success_status, ansbody -> begin - if Client_config.print_timings#get then - message "Request to /%s succeeded in %gs" - (String.concat "/" service) time ; + (if Client_config.print_timings#get then + message "Request to /%s succeeded in %gs" + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> log_response cpt code ansbody >>= fun () -> if ansbody = "" then Lwt.return `Null else match Data_encoding.Json.from_string ansbody with @@ -103,11 +88,12 @@ let get_json service json = | Ok res -> Lwt.return res end | err, _ansbody -> - if Client_config.print_timings#get then - message "Request to /%s failed in %gs" - (String.concat "/" service) time ; + (if Client_config.print_timings#get then + message "Request to /%s failed in %gs" + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index b8a1213ff..d6d3e0afc 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -11,8 +11,8 @@ let commands () = ~desc: "list known protocols" (prefixes [ "list" ; "protocols" ] stop) (fun () -> - Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos -> - List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos + Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos -> + Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos ); command ~group: "protocols" @@ -26,8 +26,7 @@ let commands () = let proto = Tezos_compiler.Protocol.of_dir dirname in Client_node_rpcs.inject_protocol proto >>= function | Ok hash -> - message "Injected protocol %a successfully" Protocol_hash.pp_short hash; - Lwt.return (); + message "Injected protocol %a successfully" Protocol_hash.pp_short hash | Error err -> error "Error while injecting protocol from %s: %a" dirname Error_monad.pp_print_error err) @@ -44,7 +43,7 @@ let commands () = (fun ph () -> Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with | Ok proto -> - Updater.extract "" ph proto >|= fun () -> + Updater.extract "" ph proto >>= fun () -> message "Extracted protocol %a" Protocol_hash.pp_short ph | Error err -> error "Error while dumping protocol %a: %a" diff --git a/src/client/embedded/bootstrap/client_proto_args.ml b/src/client/embedded/bootstrap/client_proto_args.ml index 2e3b66991..ac2f66c36 100644 --- a/src/client/embedded/bootstrap/client_proto_args.ml +++ b/src/client/embedded/bootstrap/client_proto_args.ml @@ -81,14 +81,14 @@ let delegatable_args = Arg.Clear delegatable, "Set the created contract to be non delegatable (default)" ] -let tez_param ~n ~desc next = +let tez_param ~name ~desc next = Cli_entries.param - n + name (desc ^ " in \xEA\x9C\xA9\n\ text format: D,DDD,DDD.DD (centiles and comas are optional)") (fun s -> try Lwt.return (tez_of_string s) - with _ -> Cli_entries.param_error "invalid \xEA\x9C\xA9 notation") + with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation") next let max_priority = ref None diff --git a/src/client/embedded/bootstrap/client_proto_args.mli b/src/client/embedded/bootstrap/client_proto_args.mli index fbe0ec496..ab04ad0be 100644 --- a/src/client/embedded/bootstrap/client_proto_args.mli +++ b/src/client/embedded/bootstrap/client_proto_args.mli @@ -23,7 +23,7 @@ val force_arg: string * Arg.spec * string val endorsement_delay_arg: string * Arg.spec * string val tez_param : - n:string -> + name:string -> desc:string -> 'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params diff --git a/src/client/embedded/bootstrap/client_proto_context.ml b/src/client/embedded/bootstrap/client_proto_context.ml index ecffdecfb..fc48aab3b 100644 --- a/src/client/embedded/bootstrap/client_proto_context.ml +++ b/src/client/embedded/bootstrap/client_proto_context.ml @@ -34,8 +34,7 @@ let get_delegate_pkh = function let get_timestamp block () = Client_node_rpcs.Blocks.timestamp block >>= fun v -> - Cli_entries.message "%s" (Time.to_notation v) ; - Lwt.return () + Cli_entries.message "%s" (Time.to_notation v) let list_contracts block () = Client_proto_rpcs.Context.Contract.list block >>=? fun contracts -> @@ -58,7 +57,7 @@ let list_contracts block () = let kind = match Contract.is_default h with | Some _ -> " (default)" | None -> "" in - Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm; + Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () -> return ()) contracts @@ -75,15 +74,15 @@ let transfer block ?force Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_proto_rpcs.Helpers.Forge.Manager.transaction block ~net ~source ~sourcePubKey:src_pk ~counter ~amount ~destination ?parameters ~fee () >>=? fun bytes -> - message "Forged the raw transaction frame." ; + message "Forged the raw transaction frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - answer "Operation successfully injected in the node." ; - answer "Operation hash is '%a'." Operation_hash.pp oph ; + answer "Operation successfully injected in the node." >>= fun () -> + answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () let originate_account block ?force @@ -93,16 +92,16 @@ let originate_account block ?force Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_proto_rpcs.Helpers.Forge.Manager.origination block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ?spendable ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." ; + message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." ; - message "Operation hash is '%a'." Operation_hash.pp oph ; + message "Operation successfully injected in the node." >>= fun () -> + message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract let originate_contract @@ -115,18 +114,18 @@ let originate_contract Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_node_rpcs.Blocks.net block >>= fun net -> Client_proto_rpcs.Helpers.Forge.Manager.origination block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ~spendable:!spendable ?delegatable ?delegatePubKey ~script:(code, init) ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." ; + message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." ; - message "Operation hash is '%a'." Operation_hash.pp oph ; + message "Operation successfully injected in the node." >>= fun () -> + message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract let commands () = @@ -157,26 +156,24 @@ let commands () = Public_key_hash.add name pkh >>= fun () -> Public_key.add name pk >>= fun () -> Secret_key.add name sk >>= fun () -> - message "Bootstrap keys added under the name '%s'." name; - Lwt.return_unit) + message "Bootstrap keys added under the name '%s'." name) accounts >>= fun () -> Lwt.return_unit) ; command ~group: "context" ~desc: "get the balance of a contract" (prefixes [ "get" ; "balance" ] - @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) () -> Client_proto_rpcs.Context.Contract.balance (block ()) contract >>= Client_proto_rpcs.handle_error >>= fun amount -> - answer "%a %s" Tez.pp amount tez_sym; - Lwt.return ()); + answer "%a %s" Tez.pp amount tez_sym); command ~group: "context" ~desc: "get the manager of a block" (prefixes [ "get" ; "manager" ] - @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) () -> Client_proto_rpcs.Context.Contract.manager (block ()) contract @@ -184,8 +181,7 @@ let commands () = Public_key_hash.rev_find manager >>= fun mn -> Public_key_hash.to_source manager >>= fun m -> message "%s (%s)" m - (match mn with None -> "unknown" | Some n -> "known as " ^ n) ; - Lwt.return ()); + (match mn with None -> "unknown" | Some n -> "known as " ^ n)); command ~group: "context" ~desc: "open a new account" @@ -193,16 +189,16 @@ let commands () = @ delegatable_args @ spendable_args) (prefixes [ "originate" ; "account" ] @@ RawContractAlias.fresh_alias_param - ~n: "new" ~desc: "name of the new contract" + ~name: "new" ~desc: "name of the new contract" @@ prefix "for" @@ Public_key_hash.alias_param - ~n: "mgr" ~desc: "manager of the new contract" + ~name: "mgr" ~desc: "manager of the new contract" @@ prefix "transfering" @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n:"src" ~desc: "name of the source contract" + ~name:"src" ~desc: "name of the source contract" @@ stop) (fun neu (_, manager) balance (_, source) -> handle_error @@ fun () -> @@ -210,7 +206,7 @@ let commands () = get_delegate_pkh !delegate >>= fun delegate -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_account (block ()) ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate @@ -224,19 +220,19 @@ let commands () = delegatable_args @ spendable_args @ [ init_arg ]) (prefixes [ "originate" ; "contract" ] @@ RawContractAlias.fresh_alias_param - ~n: "new" ~desc: "name of the new contract" + ~name: "new" ~desc: "name of the new contract" @@ prefix "for" @@ Public_key_hash.alias_param - ~n: "mgr" ~desc: "manager of the new contract" + ~name: "mgr" ~desc: "manager of the new contract" @@ prefix "transfering" @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n:"src" ~desc: "name of the source contract" + ~name:"src" ~desc: "name of the source contract" @@ prefix "running" @@ Program.source_param - ~n:"prg" ~desc: "script of the account\n\ + ~name:"prg" ~desc: "script of the account\n\ combine with -init if the storage type is non void" @@ stop) (fun neu (_, manager) balance (_, source) code -> @@ -245,7 +241,7 @@ let commands () = get_delegate_pkh !delegate >>= fun delegate -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_contract (block ()) ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init () @@ -258,19 +254,19 @@ let commands () = ~args: [ fee_arg ; arg_arg ; force_arg ] (prefixes [ "transfer" ] @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n: "src" ~desc: "name of the source contract" + ~name: "src" ~desc: "name of the source contract" @@ prefix "to" @@ ContractAlias.destination_param - ~n: "dst" ~desc: "name/literal of the destination contract" + ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) (fun amount (_, source) (_, destination) -> handle_error @@ fun () -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> transfer (block ()) ~force:!force ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) ] diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index 9a921f594..d48d540e9 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -51,33 +51,34 @@ module ContractAlias = struct find_key key | _ -> find s - let alias_param ?(n = "name") ?(desc = "existing contract alias") next = - Cli_entries.Param - (n, desc ^ "\n" - ^ "can be an contract alias or a key alias (autodetected in this order)\n\ - use 'key:name' to force the later", get_contract, next) + let alias_param ?(name = "name") ?(desc = "existing contract alias") next = + let desc = + desc ^ "\n" + ^ "can be an contract alias or a key alias (autodetected in this order)\n\ + use 'key:name' to force the later" in + Cli_entries.param ~name ~desc get_contract next - let destination_param ?(n = "dst") ?(desc = "destination contract") next = - Cli_entries.Param - (n, - desc ^ "\n" - ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ - use 'text:litteral', 'alias:name', 'key:name' to force", - (fun s -> - match Utils.split ~limit:1 ':' s with - | [ "alias" ; alias ]-> - find alias - | [ "key" ; text ] -> - Client_keys.Public_key_hash.find text >>= fun v -> - Lwt.return (s, Contract.default_contract v) - | _ -> - Lwt.catch - (fun () -> find s) - (fun _ -> - match Contract.of_b48check s with - | Error _ -> Lwt.fail (Failure "bad contract notation") - | Ok v -> Lwt.return (s, v))), - next) + let destination_param ?(name = "dst") ?(desc = "destination contract") next = + let desc = + desc ^ "\n" + ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ + use 'text:litteral', 'alias:name', 'key:name' to force" in + Cli_entries.param ~name ~desc + (fun s -> + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "key" ; text ] -> + Client_keys.Public_key_hash.find text >>= fun v -> + Lwt.return (s, Contract.default_contract v) + | _ -> + Lwt.catch + (fun () -> find s) + (fun _ -> + match Contract.of_b48check s with + | Error _ -> Lwt.fail (Failure "bad contract notation") + | Ok v -> Lwt.return (s, v))) + next let name contract = rev_find contract >|= function @@ -150,17 +151,16 @@ let commands () = (fixed [ "list" ; "known" ; "contracts" ]) (fun () -> RawContractAlias.load () >>= fun list -> - List.iter (fun (n, v) -> + Lwt_list.iter_s (fun (n, v) -> let v = Contract.to_b48check v in message "%s: %s" n v) - list ; + list >>= fun () -> Client_keys.Public_key_hash.load () >>= fun list -> Lwt_list.iter_s (fun (n, v) -> RawContractAlias.mem n >>= fun mem -> let p = if mem then "key:" else "" in let v = Contract.to_b48check (Contract.default_contract v) in - message "%s%s: %s" p n v ; - Lwt.return_unit) + message "%s%s: %s" p n v) list >>= fun () -> Lwt.return ()) ; command diff --git a/src/client/embedded/bootstrap/client_proto_contracts.mli b/src/client/embedded/bootstrap/client_proto_contracts.mli index 87e40ba04..54257e48f 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.mli +++ b/src/client/embedded/bootstrap/client_proto_contracts.mli @@ -13,12 +13,12 @@ module RawContractAlias : module ContractAlias : sig val get_contract: string -> (string * Contract.t) Lwt.t val alias_param: - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params val destination_param: - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 5620b123d..a7cabf824 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -183,7 +183,7 @@ let commands () = ~desc: "lists all known programs" (fixed [ "list" ; "known" ; "programs" ]) (fun () -> Program.load () >>= fun list -> - List.iter (fun (n, _) -> message "%s" n) list ; Lwt.return ()) ; + Lwt_list.iter_s (fun (n, _) -> message "%s" n) list) ; command ~group: "programs" ~desc: "remember a program under some name" @@ -262,7 +262,7 @@ let commands () = Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function | Ok type_map -> let type_map, program = unexpand_macros type_map program in - message "Well typed" ; + message "Well typed" >>= fun () -> if !show_types then begin print_program (fun l -> List.mem_assoc l type_map) @@ -296,8 +296,7 @@ let commands () = Client_proto_rpcs.Helpers.typecheck_untagged_data (block ()) (data, exp_ty) >>= function | Ok () -> - message "Well typed" ; - Lwt.return () + message "Well typed" | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-typed data") ; @@ -312,8 +311,7 @@ let commands () = let open Data_encoding in Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function | Ok hash -> - message "%S" hash; - Lwt.return () + message "%S" hash | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-formed data") ; @@ -337,8 +335,7 @@ let commands () = hash (signature |> Data_encoding.Binary.to_bytes Ed25519.signature_encoding |> - Hex_encode.hex_of_bytes) ; - Lwt.return () + Hex_encode.hex_of_bytes) | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-formed data") ; diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml index e87c68216..9e8c33156 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -101,7 +101,7 @@ let reveal_nonces ?force () = open Client_proto_args -let run_daemon delegates = +let run_daemon delegates () = Client_mining_daemon.run ?max_priority:!max_priority ~delay:!endorsement_delay @@ -126,7 +126,7 @@ let commands () = ~args: [ force_arg ] (prefixes [ "endorse"; "for" ] @@ Client_keys.Public_key_hash.alias_param - ~n:"miner" ~desc: "name of the delegate owning the endorsement right" + ~name:"miner" ~desc: "name of the delegate owning the endorsement right" @@ stop) (fun (_, delegate) () -> endorse_block @@ -138,7 +138,7 @@ let commands () = ~args: [ max_priority_arg ; force_arg ] (prefixes [ "mine"; "for" ] @@ Client_keys.Public_key_hash.alias_param - ~n:"miner" ~desc: "name of the delegate owning the mining right" + ~name:"miner" ~desc: "name of the delegate owning the mining right" @@ stop) (fun (_, delegate) () -> mine_block (block ()) @@ -150,7 +150,7 @@ let commands () = ~args: [ force_arg ] (prefixes [ "reveal"; "nonce"; "for" ] @@ Cli_entries.seq_of_param Block_hash.param) - (fun block_hashes -> + (fun block_hashes () -> reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ; command ~group: "delegate" diff --git a/src/client_main.ml b/src/client_main.ml index e57cdd9cf..11d278621 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -11,6 +11,27 @@ open Lwt +let () = + let startup = + CalendarLib.Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (CalendarLib.Calendar.Precise.now ()) in + let log channel msg = match channel with + | "stdout" -> + print_endline msg ; + Lwt.return () + | "stderr" -> + prerr_endline msg ; + Lwt.return () + | log -> + Utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> + Lwt_io.with_file + ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] + ~mode: Lwt_io.Output + Client_config.(base_dir#get // "logs" // log // startup) + (fun chan -> Lwt_io.write chan msg) in + Cli_entries.log_hook := Some log + (* Main (lwt) entry *) let main () = Random.self_init () ; @@ -24,7 +45,7 @@ let main () = (fun _ -> Cli_entries.message "\n\ The connection to the RPC server failed, \ - using the default protocol version.\n" ; + using the default protocol version.\n" >>= fun () -> Lwt.return Client_bootstrap.Client_proto_main.protocol) >>= fun version -> let commands = @@ -35,7 +56,7 @@ let main () = Client_version.commands_for_version version in Client_config.parse_args ~version (Cli_entries.usage commands) - (Cli_entries.inline_dispatcher commands)) + (Cli_entries.inline_dispatch commands)) (function | Arg.Help help -> Format.printf "%s%!" help ; diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 3e262b0a6..c7071af56 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -16,21 +16,30 @@ exception Command_not_found exception Bad_argument of int * string * string exception Command_failed of string -(* A simple structure for command interpreters. *) -type 'a params = - | Prefix : string * 'a params -> 'a params - | Param : string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params - | Stop : (unit -> unit Lwt.t) params - | More : (string list -> unit Lwt.t) params - | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params +(* A simple structure for command interpreters. + This is more generic than the exported one, see end of file. *) +type ('a, 'arg, 'ret) tparams = + | Prefix : string * ('a, 'arg, 'ret) tparams -> + ('a, 'arg, 'ret) tparams + | Param : string * string * + (string -> 'p Lwt.t) * + ('a, 'arg, 'ret) tparams -> + ('p -> 'a, 'arg, 'ret) tparams + | Stop : + ('arg -> 'ret Lwt.t, 'arg, 'ret) tparams + | More : + (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams + | Seq : string * string * + (string -> 'p Lwt.t) -> + ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams (* A command wraps a callback with its type and info *) -and command = +and ('arg, 'ret) tcommand = | Command - : 'a params * 'a * + : ('a, 'arg, 'ret) tparams * 'a * desc option * tag list * group option * (Arg.key * Arg.spec * Arg.doc) list - -> command + -> ('arg, 'ret) tcommand and desc = string and group = string @@ -77,25 +86,15 @@ let command ?desc ?(tags = []) ?group ?(args = []) params cb = (* Param combinators *) let string n desc next = param n desc (fun s -> return s) next -(* Error combinators for use in commands *) -let kasprintf cont fmt = - let buffer = Buffer.create 100 in - let ppf = Format.formatter_of_buffer buffer in - Format.kfprintf (fun ppf -> - Format.fprintf ppf "%!"; - cont (Buffer.contents buffer)) - ppf fmt -let error fmt = kasprintf (fun msg -> Lwt.fail (Command_failed msg)) fmt -let message fmt = kasprintf (Format.eprintf "%s\n%!") fmt -let answer fmt = kasprintf (Format.printf "%s\n%!") fmt -let param_error fmt = kasprintf (fun msg -> Lwt.fail (Failure msg)) fmt - (* Command execution *) -let exec (Command (params, cb, _, _, _, _)) args = +let exec + (type arg) (type ret) + (Command (params, cb, _, _, _, _)) (last : arg) args = let rec exec - : type a. int -> a params -> a -> string list -> unit Lwt.t = fun i params cb args -> + : type a. int -> (a, arg, ret) tparams -> a -> string list -> ret Lwt.t + = fun i params cb args -> match params, args with - | Stop, [] -> cb () + | Stop, [] -> cb last | Stop, _ -> Lwt.fail Command_not_found | Seq (_, _, f), seq -> let rec do_seq i acc = function @@ -108,8 +107,8 @@ let exec (Command (params, cb, _, _, _, _)) args = | exn -> Lwt.fail exn) >>= fun v -> do_seq (succ i) (v :: acc) rest in do_seq i [] seq >>= fun parsed -> - cb parsed - | More, rest -> cb rest + cb parsed last + | More, rest -> cb rest last | Prefix (n, next), p :: rest when n = p -> exec (succ i) next cb rest | Param (_, _, f, next), p :: rest -> @@ -122,116 +121,125 @@ let exec (Command (params, cb, _, _, _, _)) args = | _ -> Lwt.fail Command_not_found in exec 1 params cb args -module Command_tree = struct - type level = - { stop : command option ; - prefix : (string * tree) list } - and param_level = - { stop : command option ; - tree : tree } - and tree = - | TPrefix of level - | TParam of param_level - | TStop of command - | TMore of command - | TEmpty - let insert root (Command (params, _, _, _, _, _) as command) = - let rec insert_tree - : type a. tree -> a params -> tree - = fun t c -> match t, c with - | TEmpty, Stop -> TStop command - | TEmpty, More -> TMore command - | TEmpty, Seq _ -> TMore command - | TEmpty, Param (_, _, _, next) -> - TParam { tree = insert_tree TEmpty next ; stop = None } - | TEmpty, Prefix (n, next) -> - TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } - | TStop command, Param (_, _, _, next) -> - TParam { tree = insert_tree TEmpty next ; stop = Some command } - | TStop command, Prefix (n, next) -> - TPrefix { stop = Some command ; - prefix = [ (n, insert_tree TEmpty next) ] } - | TParam t, Param (_, _, _, next) -> - TParam { t with tree = insert_tree t.tree next } - | TPrefix ({ prefix } as l), Prefix (n, next) -> - let rec insert_prefix = function - | [] -> [ (n, insert_tree TEmpty next) ] - | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest - | item :: rest -> item :: insert_prefix rest in - TPrefix { l with prefix = insert_prefix prefix } - | TPrefix ({ stop = None } as l), Stop -> - TPrefix { l with stop = Some command } - | TParam ({ stop = None } as l), Stop -> - TParam { l with stop = Some command } - | _, _ -> - Pervasives.failwith - "Cli_entries.Command_tree.insert: conflicting commands" in - insert_tree root params - let make commands = - List.fold_left insert TEmpty commands - let dispatcher tree args = - let rec loop = function - | TStop c, [] -> exec c args - | TPrefix { stop = Some c }, [] -> exec c args - | TMore c, _ -> exec c args - | TPrefix { prefix }, n :: rest -> - begin try - let t = List.assoc n prefix in - loop (t, rest) - with Not_found -> Lwt.fail Command_not_found end - | TParam { tree }, _ :: rest -> - loop (tree, rest) - | _, _ -> Lwt.fail Command_not_found - in - loop (tree, args) - let inline_dispatcher tree () = - let state = ref (tree, []) in - fun arg -> match !state, arg with - | (( TStop c | - TMore c | - TPrefix { stop = Some c } | - TParam { stop = Some c}), acc), - `End -> - state := (TEmpty, []) ; - `Res (exec c (List.rev acc)) - | (TMore c, acc), `Arg n -> - state := (TMore c, n :: acc) ; - `Nop - | (TPrefix { prefix }, acc), `Arg n -> - begin try - let t = List.assoc n prefix in - state := (t, n :: acc) ; - begin match t with - | TStop (Command (_, _, _, _, _, args)) - | TMore (Command (_, _, _, _, _, args)) -> `Args args - | _ -> `Nop end - with Not_found -> `Fail Command_not_found end - | (TParam { tree }, acc), `Arg n -> - state := (tree, n :: acc) ; - begin match tree with - | TStop (Command (_, _, _, _, _, args)) - | TMore (Command (_, _, _, _, _, args)) -> `Args args - | _ -> `Nop end - | _, _ -> `Fail Command_not_found -end +(* Command dispatch tree *) +type ('arg, 'ret) level = + { stop : ('arg, 'ret) tcommand option ; + prefix : (string * ('arg, 'ret) tree) list } +and ('arg, 'ret) param_level = + { stop : ('arg, 'ret) tcommand option ; + tree : ('arg, 'ret) tree } +and ('arg, 'ret) tree = + | TPrefix of ('arg, 'ret) level + | TParam of ('arg, 'ret) param_level + | TStop of ('arg, 'ret) tcommand + | TMore of ('arg, 'ret) tcommand + | TEmpty + +let insert_in_dispatch_tree + (type arg) (type ret) + root (Command (params, _, _, _, _, _) as command) = + let rec insert_tree + : type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree + = fun t c -> match t, c with + | TEmpty, Stop -> TStop command + | TEmpty, More -> TMore command + | TEmpty, Seq _ -> TMore command + | TEmpty, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = None } + | TEmpty, Prefix (n, next) -> + TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } + | TStop command, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = Some command } + | TStop command, Prefix (n, next) -> + TPrefix { stop = Some command ; + prefix = [ (n, insert_tree TEmpty next) ] } + | TParam t, Param (_, _, _, next) -> + TParam { t with tree = insert_tree t.tree next } + | TPrefix ({ prefix } as l), Prefix (n, next) -> + let rec insert_prefix = function + | [] -> [ (n, insert_tree TEmpty next) ] + | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest + | item :: rest -> item :: insert_prefix rest in + TPrefix { l with prefix = insert_prefix prefix } + | TPrefix ({ stop = None } as l), Stop -> + TPrefix { l with stop = Some command } + | TParam ({ stop = None } as l), Stop -> + TParam { l with stop = Some command } + | _, _ -> + Pervasives.failwith + "Cli_entries.Command_tree.insert: conflicting commands" in + insert_tree root params + +let make_dispatch_tree commands = + List.fold_left insert_in_dispatch_tree TEmpty commands + +let tree_dispatch tree last args = + let rec loop = function + | TStop c, [] -> exec c last args + | TPrefix { stop = Some c }, [] -> exec c last args + | TMore c, _ -> exec c last args + | TPrefix { prefix }, n :: rest -> + begin try + let t = List.assoc n prefix in + loop (t, rest) + with Not_found -> Lwt.fail Command_not_found end + | TParam { tree }, _ :: rest -> + loop (tree, rest) + | _, _ -> Lwt.fail Command_not_found + in + loop (tree, args) + +let inline_tree_dispatch tree last = + let state = ref (tree, []) in + fun arg -> match !state, arg with + | (( TStop c | + TMore c | + TPrefix { stop = Some c } | + TParam { stop = Some c}), acc), + `End -> + state := (TEmpty, []) ; + `Res (exec c last (List.rev acc)) + | (TMore c, acc), `Arg n -> + state := (TMore c, n :: acc) ; + `Nop + | (TPrefix { prefix }, acc), `Arg n -> + begin try + let t = List.assoc n prefix in + state := (t, n :: acc) ; + begin match t with + | TStop (Command (_, _, _, _, _, args)) + | TMore (Command (_, _, _, _, _, args)) -> `Args args + | _ -> `Nop end + with Not_found -> `Fail Command_not_found end + | (TParam { tree }, acc), `Arg n -> + state := (tree, n :: acc) ; + begin match tree with + | TStop (Command (_, _, _, _, _, args)) + | TMore (Command (_, _, _, _, _, args)) -> `Args args + | _ -> `Nop end + | _, _ -> `Fail Command_not_found (* Try a list of commands on a list of arguments *) -let dispatcher commands = - let tree = Command_tree.make commands in - fun args -> Command_tree.dispatcher tree args +let dispatch commands = + let tree = make_dispatch_tree commands in + tree_dispatch tree (* Argument-by-argument dispatcher to be used during argument parsing *) -let inline_dispatcher commands = - let tree = Command_tree.make commands in - Command_tree.inline_dispatcher tree +let inline_dispatch commands = + let tree = make_dispatch_tree commands in + inline_tree_dispatch tree (* Command line help for a set of commands *) -let usage commands options = +let usage + (type arg) (type ret) + commands options = let trim s = (* config-file wokaround *) Utils.split '\n' s |> List.map String.trim |> String.concat "\n" in - let rec help : type a. Format.formatter -> a params -> unit = fun ppf -> function + let rec help + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." | Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n @@ -242,7 +250,9 @@ let usage commands options = | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in - let rec help_sum : type a. Format.formatter -> a params -> unit = fun ppf -> function + let rec help_sum + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." | Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n @@ -250,13 +260,21 @@ let usage commands options = | Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in - let rec help_args : type a. Format.formatter -> a params -> unit = fun ppf -> function - | Stop -> () - | More -> Format.fprintf ppf "..." - | Seq (n, desc, _) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) - | Prefix (_, next) -> help_args ppf next - | Param (n, desc, _, Stop) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) - | Param (n, desc, _, next) -> Format.fprintf ppf "(%s): @[%a@]@,%a" n Format.pp_print_text (trim desc) help_args next in + let rec help_args + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function + | Stop -> () + | More -> Format.fprintf ppf "..." + | Seq (n, desc, _) -> + Format.fprintf ppf "(%s): @[%a@]" + n Format.pp_print_text (trim desc) + | Prefix (_, next) -> help_args ppf next + | Param (n, desc, _, Stop) -> + Format.fprintf ppf "(%s): @[%a@]" + n Format.pp_print_text (trim desc) + | Param (n, desc, _, next) -> + Format.fprintf ppf "(%s): @[%a@]@,%a" + n Format.pp_print_text (trim desc) help_args next in let option_help ppf (n, opt, desc) = Format.fprintf ppf "%s%s" n Arg.(let rec example opt = match opt with @@ -277,27 +295,38 @@ let usage commands options = Format.fprintf ppf "@, @[%a@]" Format.pp_print_text (trim desc) in let command_help ppf (Command (p, _, desc, _, _, options)) = let small = Format.asprintf "@[%a@]" help p in + let desc = + match desc with + | None -> "undocumented command" + | Some desc -> trim desc in if String.length small < 50 then begin Format.fprintf ppf "@[%s@,@[%a@]" - small - Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + small Format.pp_print_text desc end else begin Format.fprintf ppf "@[%a@,@[%a@]@,%a" help_sum p - Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + Format.pp_print_text desc help_args p ; end ; if options = [] then Format.fprintf ppf "@]" else - Format.fprintf ppf "@,%a@]" (Format.pp_print_list option_help) options in + Format.fprintf ppf "@,%a@]" + (Format.pp_print_list option_help) + options in let rec group_help ppf (n, commands) = + let title = + match n with + | None -> "Miscellaneous commands" + | Some n -> group_title n in Format.fprintf ppf "@[%s:@,%a@]" - (match n with None -> "Miscellaneous commands" | Some n -> group_title n) + title (Format.pp_print_list command_help) !commands in let usage ppf (by_group, options) = Format.fprintf ppf - "@[@[Usage:@,%s [ options ] command [ command options ]@]@,@[Options:@,%a@]@,%a@]" + "@[@[Usage:@,%s [ options ] command [ command options ]@]@,\ + @[Options:@,%a@]@,\ + %a@]" Sys.argv.(0) (Format.pp_print_list option_help) options (Format.pp_print_list group_help) by_group in @@ -312,3 +341,34 @@ let usage commands options = (g, ref [ c ]) :: acc) [] commands |> List.sort compare in Format.asprintf "%a" usage (by_group, options) + +(* Pre-instanciated types *) +type 'a params = ('a, unit, unit) tparams +type command = (unit, unit) tcommand + +let log_hook + : (string -> string -> unit Lwt.t) option ref + = ref None + +let log channel msg = + match !log_hook with + | None -> Lwt.fail (Invalid_argument "Cli_entries.log: uninitialized hook") + | Some hook -> hook channel msg + +let error fmt= + Format.kasprintf + (fun msg -> + Lwt.fail (Failure msg)) + fmt + +let message fmt = + Format.kasprintf + (fun msg -> log "stdout" msg) + fmt + +let answer = message + +let log name fmt = + Format.kasprintf + (fun msg -> log name msg) + fmt diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 7d6e63bde..209289a3b 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -14,29 +14,13 @@ exception Command_not_found exception Bad_argument of int * string * string exception Command_failed of string -type 'a params = - | Prefix: string * 'a params -> 'a params - | Param: string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params - | Stop: (unit -> unit Lwt.t) params - | More: (string list -> unit Lwt.t) params - | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params - -and command = - | Command - : 'a params * 'a * - desc option * tag list * group option * - (Arg.key * Arg.spec * Arg.doc) list - -> command +type 'a params +type command and desc = string and group = string and tag = string -val error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a -val param_error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a -val message: ('a, Format.formatter, unit, unit) format4 -> 'a -val answer: ('a, Format.formatter, unit, unit) format4 -> 'a - val param: name: string -> desc: string -> @@ -49,12 +33,13 @@ val stop: (unit -> unit Lwt.t) params val seq: name: string -> desc: string -> - (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params + (string -> 'p Lwt.t) -> + ('p list -> unit -> unit Lwt.t) params -(* [seq_of_param (param ~name ~desc f) = seq ~name ~desc f] *) val seq_of_param: - ((unit -> unit Lwt.t) params -> ('a -> unit -> unit Lwt.t) params) -> - ('a list -> unit Lwt.t) params + ((unit -> unit Lwt.t) params -> + ('a -> unit -> unit Lwt.t) params) -> + ('a list -> unit -> unit Lwt.t) params val command: ?desc:desc -> @@ -68,7 +53,7 @@ val register_tag: tag -> string -> unit val usage: command list -> (string * Arg.spec * string) list -> string -val inline_dispatcher: +val inline_dispatch: command list -> unit -> [> `Arg of string | `End ] -> @@ -76,3 +61,13 @@ val inline_dispatcher: | `Fail of exn | `Nop | `Res of unit Lwt.t ] + +val dispatch: + command list -> unit -> string list -> unit Lwt.t + +val log_hook : (string -> string -> unit Lwt.t) option ref + +val error : ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a +val message : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val answer : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val log : string -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a From 80e1b0f3125d32a3a48b8c456d35dcd0c8d70cca Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Tue, 22 Nov 2016 17:24:52 +0100 Subject: [PATCH 2/8] Client: add Cli_entries.warning to log a message on stderr without raising exception --- src/utils/cli_entries.ml | 5 +++++ src/utils/cli_entries.mli | 1 + 2 files changed, 6 insertions(+) diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index c7071af56..9cca0bd66 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -361,6 +361,11 @@ let error fmt= Lwt.fail (Failure msg)) fmt +let warning fmt = + Format.kasprintf + (fun msg -> log "stderr" msg) + fmt + let message fmt = Format.kasprintf (fun msg -> log "stdout" msg) diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 209289a3b..1b431e0c8 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -68,6 +68,7 @@ val dispatch: val log_hook : (string -> string -> unit Lwt.t) option ref val error : ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a +val warning : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val message : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val answer : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val log : string -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a From 3c2453f00d0d2346a37adea4d76ac68ae7f3b42c Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Tue, 22 Nov 2016 17:27:00 +0100 Subject: [PATCH 3/8] Client: catch Failure exceptions in Client_main --- src/client_main.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/client_main.ml b/src/client_main.ml index 11d278621..b74ad2e56 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -76,6 +76,9 @@ let main () = | Cli_entries.Command_failed message -> Format.eprintf "Command failed, %s.\n%!" message ; Pervasives.exit 1 + | Failure message -> + Format.eprintf "%s%!" message ; + Pervasives.exit 1 | exn -> Format.printf "Fatal internal error: %s\n%!" (Printexc.to_string exn) ; From a48d8c0026902c8749ef3718ada1b3c46bc0a851 Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Tue, 22 Nov 2016 17:28:25 +0100 Subject: [PATCH 4/8] Client: replace (e)printfs with Cli_entries.{error,warning,message} equivalent --- src/client/client_config.ml | 40 ++++++++++--------- src/client/client_generic_rpcs.ml | 28 ++++++------- .../bootstrap/client_proto_contracts.ml | 3 +- .../bootstrap/client_proto_programs.ml | 23 +++++------ .../bootstrap/mining/client_mining_main.ml | 13 +++--- src/client_main.ml | 2 +- 6 files changed, 53 insertions(+), 56 deletions(-) diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 62af71802..21560a74e 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -128,8 +128,8 @@ let parse_args ?version usage dispatcher = ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; Lwt.return () with Sys_error msg -> - Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg; - exit 1 + Cli_entries.error + "Error: can't read the configuration file: %s\n%!" msg end else begin try (* parse once again with contextual options *) @@ -139,9 +139,8 @@ let parse_args ?version usage dispatcher = file_group#write config_file#get ; Lwt.return () with Sys_error msg -> - Printf.eprintf - "Warning: can't create the default configuration file: %s\n%!" msg ; - Lwt.return () + Cli_entries.warning + "Warning: can't create the default configuration file: %s\n%!" msg end) >>= fun () -> begin match dispatch `End with | `Res res -> @@ -161,7 +160,7 @@ let preparse name argv = None with Found s -> Some s -let preparse_args () : Node_rpc_services.Blocks.block = +let preparse_args () : Node_rpc_services.Blocks.block Lwt.t = begin match preparse "-base-dir" Sys.argv with | None -> () @@ -174,11 +173,13 @@ let preparse_args () : Node_rpc_services.Blocks.block = end ; begin if Sys.file_exists config_file#get then try - file_group#read config_file#get ; + (file_group#read config_file#get ; + Lwt.return ()) with Sys_error msg -> - Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg; - exit 1 - end ; + Cli_entries.error + "Error: can't read the configuration file: %s\n%!" msg + else Lwt.return () + end >>= fun () -> begin match preparse "-addr" Sys.argv with | None -> () @@ -186,17 +187,20 @@ let preparse_args () : Node_rpc_services.Blocks.block = end ; begin match preparse "-port" Sys.argv with - | None -> () + | None -> Lwt.return () | Some port -> - try incoming_port#set (int_of_string port) + try + incoming_port#set (int_of_string port) ; + Lwt.return () with _ -> - Printf.eprintf "Error: can't parse the -port option: %S.\n%!" port ; - exit 1 end ; + Cli_entries.error + "Error: can't parse the -port option: %S.\n%!" port + end >>= fun () -> match preparse "-block" Sys.argv with - | None -> `Prevalidation + | None -> Lwt.return `Prevalidation | Some x -> match Node_rpc_services.Blocks.parse_block x with | Error _ -> - Printf.eprintf "Error: can't parse the -block option: %S.\n%!" x ; - exit 1 - | Ok b -> b + Cli_entries.error + "Error: can't parse the -block option: %S.\n%!" x + | Ok b -> Lwt.return b diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 22509b65a..a31473050 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -272,12 +272,12 @@ let list url () = Format.pp_print_list (fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t)) in - Format.printf "@ @[Available services:@ @ %a@]@." - display (args, args, tree) ; + Cli_entries.message "@ @[Available services:@ @ %a@]@." + display (args, args, tree) >>= fun () -> if !collected_args <> [] then - Format.printf "@,@[Dynamic parameter description:@ @ %a@]@." - (Format.pp_print_list display_arg) !collected_args ; - return () + Cli_entries.message "@,@[Dynamic parameter description:@ @ %a@]@." + (Format.pp_print_list display_arg) !collected_args + else Lwt.return () let schema url () = @@ -285,14 +285,12 @@ let schema url () = let open RPC.Description in Client_node_rpcs.describe ~recurse:false args >>= function | Static { service = Some { input ; output } } -> - Printf.printf "Input schema:\n%s\nOutput schema:\n%s\n%!" + Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!" (Data_encoding.Json.to_string (Json_schema.to_json input)) - (Data_encoding.Json.to_string (Json_schema.to_json output)); - return () + (Data_encoding.Json.to_string (Json_schema.to_json output)) | _ -> - Printf.printf - "No service found at this URL (but this is a valid prefix)\n%!" ; - return () + Cli_entries.message + "No service found at this URL (but this is a valid prefix)\n%!" let fill_in schema = let open Json_schema in @@ -311,13 +309,11 @@ let call url () = error "%s" msg | Ok json -> Client_node_rpcs.get_json args json >>= fun json -> - Printf.printf "Output:\n%s\n%!" (Data_encoding.Json.to_string json) ; - return () + Cli_entries.message "Output:\n%s\n%!" (Data_encoding.Json.to_string json) end | _ -> - Printf.printf - "No service found at this URL (but this is a valid prefix)\n%!" ; - return () + Cli_entries.message + "No service found at this URL (but this is a valid prefix)\n%!" let () = let open Cli_entries in diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index d48d540e9..8f496e4cd 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -179,6 +179,5 @@ let commands () = @@ RawContractAlias.alias_param @@ stop) (fun (_, contract) () -> - Format.printf "%a\n%!" Contract.pp contract ; - Lwt.return ()) ; + Cli_entries.message "%a\n%!" Contract.pp contract) ; ] diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index a7cabf824..6edacffa2 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -207,8 +207,7 @@ let commands () = @@ stop) (fun (_, program) () -> Program.to_source program >>= fun source -> - Format.printf "%s\n" source ; - Lwt.return ()) ; + Cli_entries.message "%s\n" source) ; command ~group: "programs" ~desc: "ask the node to run a program" @@ -225,7 +224,7 @@ let commands () = if !trace_stack then Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function | Ok (storage, output, trace) -> - Format.printf "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." + Cli_entries.message "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." (print_ir (fun _ -> false)) storage (print_ir (fun _ -> false)) output (Format.pp_print_list @@ -235,18 +234,16 @@ let commands () = loc gas (Format.pp_print_list (print_ir (fun _ -> false))) stack)) - trace ; - Lwt.return () + trace | Error errs -> pp_print_error Format.err_formatter errs ; error "error running program" else Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function | Ok (storage, output) -> - Format.printf "@[@[storage@,%a@]@,@[output@,%a@]@]@." + Cli_entries.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." (print_ir (fun _ -> false)) storage - (print_ir (fun _ -> false)) output ; - Lwt.return () + (print_ir (fun _ -> false)) output | Error errs -> pp_print_error Format.err_formatter errs ; error "error running program") ; @@ -267,10 +264,10 @@ let commands () = print_program (fun l -> List.mem_assoc l type_map) Format.std_formatter program ; - Format.printf "@." ; - List.iter + Cli_entries.message "@." >>= fun () -> + Lwt_list.iter_s (fun (loc, (before, after)) -> - Format.printf + Cli_entries.message "%3d@[ : [ @[%a ]@]@,-> [ @[%a ]@]@]@." loc (Format.pp_print_list (print_ir (fun _ -> false))) @@ -278,8 +275,8 @@ let commands () = (Format.pp_print_list (print_ir (fun _ -> false))) after) (List.sort compare type_map) - end ; - Lwt.return () + end + else Lwt.return () | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-typed program") ; diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml index 9e8c33156..0236939af 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -68,15 +68,16 @@ let reveal_block_nonces ?force block_hashes = | Error _ -> Lwt.fail Not_found) (fun _ -> - Format.eprintf "Cannot find block %a in the chain. (ignoring)@." - Block_hash.pp_short hash ; + Cli_entries.warning + "Cannot find block %a in the chain. (ignoring)@." + Block_hash.pp_short hash >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> map_filter_s (fun (bi : Client_mining_blocks.block_info) -> Client_proto_nonces.find bi.hash >>= function | None -> - Format.eprintf "Cannot find nonces for block %a (ignoring)@." - Block_hash.pp_short bi.hash ; + Cli_entries.warning "Cannot find nonces for block %a (ignoring)@." + Block_hash.pp_short bi.hash >>= fun () -> return None | Some nonce -> return (Some (bi.hash, (bi.level.level, nonce)))) @@ -93,8 +94,8 @@ let reveal_nonces ?force () = Client_proto_nonces.find bi.hash >>= function | None -> return None | Some nonce -> - Format.eprintf "Found nonce for %a (level: %a)@." - Block_hash.pp_short bi.hash Level.pp bi.level ; + Cli_entries.warning "Found nonce for %a (level: %a)@." + Block_hash.pp_short bi.hash Level.pp bi.level >>= fun () -> return (Some (bi.hash, (bi.level.level, nonce)))) block_infos >>=? fun blocks -> do_reveal ?force block blocks diff --git a/src/client_main.ml b/src/client_main.ml index b74ad2e56..1ab0e9ec3 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -38,7 +38,7 @@ let main () = Sodium.Random.stir () ; catch (fun () -> - let block = Client_config.preparse_args () in + Client_config.preparse_args () >>= fun block -> Lwt.catch (fun () -> Client_node_rpcs.Blocks.protocol block) From 69adc115be117d5152acb6b47ec23cf1e771da09 Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Tue, 22 Nov 2016 17:33:17 +0100 Subject: [PATCH 5/8] Client: fix typo 'litteral' -> 'literal' --- src/client/client_aliases.ml | 4 ++-- src/client/embedded/bootstrap/client_proto_contracts.ml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 19f2c45e7..a7821178f 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -164,8 +164,8 @@ module Alias = functor (Entity : Entity) -> struct let source_param ?(name = "src") ?(desc = "source " ^ name) next = let desc = desc ^ "\n" - ^ "can be an alias, file or litteral (autodetected in this order)\n\ - use 'file:path', 'text:litteral' or 'alias:name' to force" in + ^ "can be an alias, file or literal (autodetected in this order)\n\ + use 'file:path', 'text:literal' or 'alias:name' to force" in param ~name ~desc (fun s -> let read path = diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index 8f496e4cd..a9270b5cb 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -61,8 +61,8 @@ module ContractAlias = struct let destination_param ?(name = "dst") ?(desc = "destination contract") next = let desc = desc ^ "\n" - ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ - use 'text:litteral', 'alias:name', 'key:name' to force" in + ^ "can be an alias, a key alias, or a literal (autodetected in this order)\n\ + use 'text:literal', 'alias:name', 'key:name' to force" in Cli_entries.param ~name ~desc (fun s -> match Utils.split ~limit:1 ':' s with From 5b1244648c7766cdae4c07b4d185c46608083eb9 Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Tue, 22 Nov 2016 17:59:09 +0100 Subject: [PATCH 6/8] Client: remove compilation warnings due to Cli_entries.log returning 'unit Lwt.t' --- src/client/client_keys.ml | 6 ++---- .../bootstrap/mining/client_mining_endorsement.ml | 2 +- .../bootstrap/mining/client_mining_forge.ml | 2 +- .../embedded/bootstrap/mining/client_mining_main.ml | 6 +++--- .../bootstrap/mining/client_mining_revelation.ml | 8 ++++---- src/client/embedded/demo/client_proto_main.ml | 13 +++++++------ 6 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 158434405..2b9d77969 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -46,8 +46,7 @@ let gen_keys name = Secret_key.add name secret_key >>= fun () -> Public_key.add name public_key >>= fun () -> Public_key_hash.add name (Ed25519.hash public_key) >>= fun () -> - Cli_entries.message "I generated a brand new pair of keys under the name '%s'." name ; - Lwt.return () + Cli_entries.message "I generated a brand new pair of keys under the name '%s'." name let check_keys_consistency pk sk = let message = MBytes.of_string "Voulez-vous coucher avec moi, ce soir ?" in @@ -122,8 +121,7 @@ let commands () = Public_key_hash.to_source pkh >>= fun v -> message "%s: %s%s%s" name v (if pkm then " (public key known)" else "") - (if pks then " (secret key known)" else "") ; - Lwt.return ()) + (if pks then " (secret key known)" else "")) l) ; command ~group: "keys" diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index ca31a6219..26361c782 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -292,7 +292,7 @@ let endorse state = Block_hash.pp_short hash Raw_level.pp level slot name - Operation_hash.pp_short oph ; + Operation_hash.pp_short oph >>= fun () -> return ()) to_endorse diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index fb7a274dd..0457252d5 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -374,7 +374,7 @@ let mine state = Block_hash.pp_short bi.hash Raw_level.pp level priority Fitness.pp fitness - (List.length operations.applied) ; + (List.length operations.applied) >>= fun () -> return () end | _ -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml index 0236939af..253b0abd6 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -27,7 +27,7 @@ let mine_block block ?force ?max_priority ?src_sk delegate = ~seed_nonce ~src_sk block delegate >>=? fun block_hash -> Client_mining_forge.State.record_block level block_hash seed_nonce |> trace_exn (Failure "Error while recording block") >>=? fun () -> - message "Injected block %a" Block_hash.pp_short block_hash ; + message "Injected block %a" Block_hash.pp_short block_hash >>= fun () -> return () let endorse_block ?force ?max_priority delegate = @@ -35,8 +35,8 @@ let endorse_block ?force ?max_priority delegate = Client_keys.get_key delegate >>=? fun (_src_name, src_pk, src_sk) -> Client_mining_endorsement.forge_endorsement block ?force ?max_priority ~src_sk src_pk >>=? fun oph -> - answer "Operation successfully injected in the node." ; - answer "Operation hash is '%a'." Operation_hash.pp oph ; + answer "Operation successfully injected in the node." >>= fun () -> + answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () let get_predecessor_cycle cycle = diff --git a/src/client/embedded/bootstrap/mining/client_mining_revelation.ml b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml index 696891d90..72f020fd2 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_revelation.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml @@ -31,11 +31,11 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces = Client_proto_rpcs.Context.Nonce.get block level >>=? function | Forgotten -> message "Too late revelation for level %a" - Raw_level.pp level ; + Raw_level.pp level >>= fun () -> return None | Revealed _ -> message "Ignoring previously-revealed nonce for level %a" - Raw_level.pp level ; + Raw_level.pp level >>= fun () -> return None | Missing nonce_hash -> if Nonce.check_hash nonce nonce_hash then @@ -53,6 +53,6 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces = | _ -> inject_seed_nonce_revelation block ~force ~wait:true nonces >>=? fun oph -> - answer "Operation successfully injected in the node." ; - answer "Operation hash is '%a'." Operation_hash.pp_short oph ; + answer "Operation successfully injected in the node." >>= fun () -> + answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () -> return () diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index d400920aa..2fe562f5e 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -13,24 +13,24 @@ let protocol = let demo () = let block = Client_config.block () in - Cli_entries.message "Calling the 'echo' RPC." ; + Cli_entries.message "Calling the 'echo' RPC." >>= fun () -> let msg = "test" in Client_proto_rpcs.echo block msg >>= fun reply -> fail_unless (reply = msg) (Unclassified "...") >>=? fun () -> begin - Cli_entries.message "Calling the 'failing' RPC." ; + Cli_entries.message "Calling the 'failing' RPC." >>= fun () -> Client_proto_rpcs.failing block 3 >>= function | Error [Ecoproto_error [Error.Demo_error 3]] -> return () | _ -> failwith "..." end >>=? fun () -> - Cli_entries.message "Direct call to `demo_error`." ; + Cli_entries.message "Direct call to `demo_error`." >>= fun () -> begin Error.demo_error 101010 >|= wrap_error >>= function | Error [Ecoproto_error [Error.Demo_error 101010]] -> return () | _ -> failwith "...." end >>=? fun () -> - Cli_entries.answer "All good!" ; + Cli_entries.answer "All good!" >>= fun () -> return () let mine () = @@ -47,13 +47,14 @@ let mine () = MBytes.set_int64 b 0 (Int64.succ f) ; [ v ; b ] | _ -> - Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness ; + Lwt.ignore_result + (Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness); exit 2 in Client_node_rpcs.forge_block ~net:bi.net ~predecessor:bi.hash fitness [] (MBytes.create 0) >>= fun bytes -> Client_node_rpcs.inject_block ~wait:true bytes >>=? fun hash -> - Cli_entries.answer "Injected %a" Block_hash.pp_short hash ; + Cli_entries.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () let handle_error = function From 69f682357f92491242c832639c0d0157dccf6210 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Wed, 23 Nov 2016 17:34:14 +0100 Subject: [PATCH 7/8] Add hooks to the RPC server to handle static files. --- src/node/net/RPC.ml | 130 +++++++++++++++++++++++++++---------------- src/node/net/RPC.mli | 16 ++++-- 2 files changed, 93 insertions(+), 53 deletions(-) diff --git a/src/node/net/RPC.ml b/src/node/net/RPC.ml index 6bde5a48c..1b56982f3 100644 --- a/src/node/net/RPC.ml +++ b/src/node/net/RPC.ml @@ -36,30 +36,53 @@ exception Invalid_method exception Cannot_parse_body of string (* Promise a running RPC server. Takes the port. *) -let launch port root = +let launch port ?pre_hook ?post_hook root = (* launch the worker *) let cancelation, canceler, _ = Lwt_utils.canceler () in let open Cohttp_lwt_unix in - let create_stream, shutdown_stream = - let streams = ref ConnectionMap.empty in - let create _io con (s: _ Answer.stream) = - let running = ref true in - let stream = - Lwt_stream.from - (fun () -> - if not !running then Lwt.return None else - s.next () >|= function - | None -> None - | Some x -> Some (Data_encoding.Json.to_string x)) in - let shutdown () = running := false ; s.shutdown () in - streams := ConnectionMap.add con shutdown !streams ; - stream - in - let shutdown con = - try ConnectionMap.find con !streams () - with Not_found -> () in - create, shutdown + let streams = ref ConnectionMap.empty in + let create_stream _io con to_string (s: _ Answer.stream) = + let running = ref true in + let stream = + Lwt_stream.from + (fun () -> + if not !running then Lwt.return None else + s.next () >|= function + | None -> None + | Some x -> Some (to_string x)) in + let shutdown () = running := false ; s.shutdown () in + streams := ConnectionMap.add con shutdown !streams ; + stream in + let shutdown_stream con = + try ConnectionMap.find con !streams () + with Not_found -> () in + let call_hook (io, con) req ?(answer_404 = false) hook = + match hook with + | None -> Lwt.return None + | Some hook -> + Lwt.catch + (fun () -> + hook (Uri.path (Cohttp.Request.uri req)) + >>= fun { Answer.code ; body } -> + if code = 404 && not answer_404 then + Lwt.return None + else + let body = match body with + | Answer.Empty -> + Cohttp_lwt_body.empty + | Single body -> + Cohttp_lwt_body.of_string body + | Stream s -> + let stream = + create_stream io con (fun s -> s) s in + Cohttp_lwt_body.of_stream stream in + Lwt.return_some + (Response.make ~flush:true ~status:(`Code code) (), + body)) + (function + | Not_found -> Lwt.return None + | exn -> Lwt.fail exn) in let callback (io, con) req body = (* FIXME: check inbound adress *) let path = Utils.split_path (Uri.path (Cohttp.Request.uri req)) in @@ -67,39 +90,48 @@ let launch port root = (Cohttp.Connection.to_string con) (Uri.path (Cohttp.Request.uri req)) >>= fun () -> Lwt.catch (fun () -> - lookup root () path >>= fun handler -> - begin - match req.meth with - | `POST -> begin - Cohttp_lwt_body.to_string body >>= fun body -> - match Data_encoding.Json.from_string body with - | Error msg -> Lwt.fail (Cannot_parse_body msg) - | Ok body -> Lwt.return (Some body) - end - | `GET -> Lwt.return None - | _ -> Lwt.fail Invalid_method - end >>= fun body -> - handler body >>= fun { Answer.code ; body } -> - let body = match body with - | Empty -> - Cohttp_lwt_body.empty - | Single json -> - Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json) - | Stream s -> - let stream = create_stream io con s in - Cohttp_lwt_body.of_stream stream in - lwt_log_info "(%s) RPC %s" - (Cohttp.Connection.to_string con) - (if Cohttp.Code.is_error code - then "failed" - else "success") >>= fun () -> - Lwt.return (Response.make ~flush:true ~status:(`Code code) (), body)) + call_hook (io, con) req pre_hook >>= function + | Some res -> + Lwt.return res + | None -> + lookup root () path >>= fun handler -> + begin + match req.meth with + | `POST -> begin + Cohttp_lwt_body.to_string body >>= fun body -> + match Data_encoding.Json.from_string body with + | Error msg -> Lwt.fail (Cannot_parse_body msg) + | Ok body -> Lwt.return (Some body) + end + | `GET -> Lwt.return None + | _ -> Lwt.fail Invalid_method + end >>= fun body -> + handler body >>= fun { Answer.code ; body } -> + let body = match body with + | Empty -> + Cohttp_lwt_body.empty + | Single json -> + Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json) + | Stream s -> + let stream = + create_stream io con Data_encoding.Json.to_string s in + Cohttp_lwt_body.of_stream stream in + lwt_log_info "(%s) RPC %s" + (Cohttp.Connection.to_string con) + (if Cohttp.Code.is_error code + then "failed" + else "success") >>= fun () -> + Lwt.return (Response.make ~flush:true ~status:(`Code code) (), + body)) (function | Not_found | Cannot_parse _ -> lwt_log_info "(%s) not found" (Cohttp.Connection.to_string con) >>= fun () -> - Lwt.return (Response.make ~flush:true ~status:`Not_found (), - Cohttp_lwt_body.empty) + (call_hook (io, con) req ~answer_404: true post_hook >>= function + | Some res -> Lwt.return res + | None -> + Lwt.return (Response.make ~flush:true ~status:`Not_found (), + Cohttp_lwt_body.empty)) | Invalid_method -> lwt_log_info "(%s) bad method" (Cohttp.Connection.to_string con) >>= fun () -> diff --git a/src/node/net/RPC.mli b/src/node/net/RPC.mli index 77a47182d..0a8c5432b 100644 --- a/src/node/net/RPC.mli +++ b/src/node/net/RPC.mli @@ -272,7 +272,6 @@ val register_custom_lookup3: ('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) -> 'prefix directory - (** Registring a description service. *) val register_describe_directory_service: 'prefix directory -> @@ -283,13 +282,22 @@ val register_describe_directory_service: type server (** Promise a running RPC serve ; takes the port. To call - an RPX at /p/a/t/h/ in the provided service, one must call the URI + an RPC at /p/a/t/h/ in the provided service, one must call the URI /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will describe the input and output of the service, if it is callable. Calling /pipe will read a sequence of services to call in - sequence from the request body, see {!pipe_encoding}. *) -val launch : int -> unit directory -> server Lwt.t + sequence from the request body, see {!pipe_encoding}. + + The optional [pre_hook] is called with the path part of the URL + before resolving each request, to delegate the answering to + another resolution mechanism. Its result is ignored if the return + code is [404]. The optional [post_hook] is called if both the + [pre_hook] and the serviced answered with a [404] code. *) +val launch : int -> + ?pre_hook: (string -> string Answer.answer Lwt.t) -> + ?post_hook: (string -> string Answer.answer Lwt.t) -> + unit directory -> server Lwt.t (** Kill an RPC server. *) val shutdown : server -> unit Lwt.t From e7c39578b4d45a3842cab1b4563e78090a2ef7f0 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 1 Dec 2016 18:27:53 +0100 Subject: [PATCH 8/8] Extract the js_of_ocaml compatible part of utils. --- src/.merlin | 2 + src/Makefile | 82 +++++++++++++------ src/client/client_aliases.ml | 6 +- src/client/client_config.ml | 2 +- src/client/client_generic_rpcs.ml | 10 +-- src/client/client_node_rpcs.ml | 10 +-- src/client/embedded/Makefile.shared | 1 + .../embedded/bootstrap/client_proto_nonces.ml | 6 +- .../mining/client_mining_endorsement.ml | 6 +- .../bootstrap/mining/client_mining_forge.ml | 6 +- src/client_main.ml | 2 +- src/compiler/tezos_compiler.ml | 13 +-- src/minutils/RPC.ml | 24 ++++++ src/{node/net => minutils}/RPC.mli | 47 ++--------- src/{utils => minutils}/compare.ml | 0 src/{utils => minutils}/compare.mli | 0 src/{utils => minutils}/data_encoding.ml | 80 ++++++------------ src/{utils => minutils}/data_encoding.mli | 18 ---- src/{utils => minutils}/hex_encode.ml | 0 src/{utils => minutils}/hex_encode.mli | 0 src/{utils => minutils}/mBytes.ml | 0 src/{utils => minutils}/mBytes.mli | 0 src/{utils => minutils}/utils.ml | 49 ----------- src/{utils => minutils}/utils.mli | 8 -- src/node/db/context.ml | 4 +- src/node/db/store.ml | 4 +- src/node/net/{RPC.ml => RPC_server.ml} | 61 +------------- src/node/net/RPC_server.mli | 40 +++++++++ src/node/net/p2p.ml | 4 +- src/node/shell/node_rpc.ml | 2 +- src/node/shell/node_rpc_services.ml | 56 ++++++++++--- src/node/shell/node_rpc_services.mli | 7 ++ src/node/updater/updater.ml | 8 +- src/node_main.ml | 21 ++--- src/proto/bootstrap/storage.ml | 12 +-- src/proto/environment/data_encoding.mli | 7 -- src/utils/data_encoding_ezjsonm.ml | 56 +++++++++++++ src/utils/data_encoding_ezjsonm.mli | 26 ++++++ src/utils/error_monad.ml | 2 +- src/utils/logging.ml | 2 +- src/utils/lwt_exit.ml | 23 ++++++ src/utils/lwt_exit.mli | 18 ++++ src/utils/lwt_utils.ml | 34 ++++++++ src/utils/lwt_utils.mli | 4 + test/.merlin | 2 + test/Makefile | 8 +- test/test_basic.ml | 12 ++- test/test_data_encoding.ml | 13 +-- 48 files changed, 458 insertions(+), 340 deletions(-) create mode 100644 src/minutils/RPC.ml rename src/{node/net => minutils}/RPC.mli (80%) rename src/{utils => minutils}/compare.ml (100%) rename src/{utils => minutils}/compare.mli (100%) rename src/{utils => minutils}/data_encoding.ml (95%) rename src/{utils => minutils}/data_encoding.mli (91%) rename src/{utils => minutils}/hex_encode.ml (100%) rename src/{utils => minutils}/hex_encode.mli (100%) rename src/{utils => minutils}/mBytes.ml (100%) rename src/{utils => minutils}/mBytes.mli (100%) rename src/{utils => minutils}/utils.ml (71%) rename src/{utils => minutils}/utils.mli (90%) rename src/node/net/{RPC.ml => RPC_server.ml} (78%) create mode 100644 src/node/net/RPC_server.mli create mode 100644 src/utils/data_encoding_ezjsonm.ml create mode 100644 src/utils/data_encoding_ezjsonm.mli create mode 100644 src/utils/lwt_exit.ml create mode 100644 src/utils/lwt_exit.mli diff --git a/src/.merlin b/src/.merlin index b7aa57076..8df5bcee0 100644 --- a/src/.merlin +++ b/src/.merlin @@ -6,6 +6,8 @@ S node/shell B node/shell S node/db B node/db +S minutils +B minutils S utils B utils S proto/environment diff --git a/src/Makefile b/src/Makefile index 003346a14..9082ce468 100644 --- a/src/Makefile +++ b/src/Makefile @@ -92,23 +92,58 @@ clean:: rm -f compiler/embedded_cmis.ml rm -rf tmp +############################################################################ +## Minimal utils library compatible with js_of_ocaml +############################################################################ + +MINUTILS_LIB_INTFS := \ + minutils/mBytes.mli \ + minutils/hex_encode.mli \ + minutils/utils.mli \ + minutils/compare.mli \ + minutils/data_encoding.mli \ + minutils/RPC.mli \ + +MINUTILS_LIB_IMPLS := \ + minutils/mBytes.ml \ + minutils/hex_encode.ml \ + minutils/utils.ml \ + minutils/compare.ml \ + minutils/data_encoding.ml \ + minutils/RPC.ml \ + +MINUTILS_PACKAGES := \ + cstruct \ + lwt \ + ocplib-json-typed.bson \ + ocplib-resto.directory \ + $(COVERAGEPKG) \ + +MINUTILS_OBJS := \ + ${MINUTILS_LIB_IMPLS:.ml=.cmx} ${MINUTILS_LIB_IMPLS:.ml=.ml.deps} \ + ${MINUTILS_LIB_INTFS:.mli=.cmi} ${MINUTILS_LIB_INTFS:.mli=.mli.deps} +${MINUTILS_OBJS}: PACKAGES=${MINUTILS_PACKAGES} +${MINUTILS_OBJS}: SOURCE_DIRECTORIES=minutils +${MINUTILS_OBJS}: TARGET="(minutils.cmxa)" +${MINUTILS_OBJS}: OPENED_MODULES= + +minutils.cmxa: ${MINUTILS_LIB_IMPLS:.ml=.cmx} + @echo LINK $(notdir $@) + @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ ############################################################################ -## Node protocol compiler (also embedded in the main program) +## Utils library ############################################################################ UTILS_LIB_INTFS := \ - utils/mBytes.mli \ - utils/utils.mli \ utils/base48.mli \ - utils/hex_encode.mli \ utils/cli_entries.mli \ - utils/compare.mli \ - utils/data_encoding.mli \ + utils/data_encoding_ezjsonm.mli \ utils/crypto_box.mli \ utils/time.mli \ utils/hash.mli \ utils/error_monad.mli \ + utils/lwt_exit.mli \ utils/logging.mli \ utils/lwt_utils.mli \ utils/lwt_pipe.mli \ @@ -116,18 +151,15 @@ UTILS_LIB_INTFS := \ utils/moving_average.mli \ UTILS_LIB_IMPLS := \ - utils/mBytes.ml \ - utils/utils.ml \ - utils/hex_encode.ml \ utils/base48.ml \ utils/cli_entries.ml \ - utils/compare.ml \ - utils/data_encoding.ml \ + utils/data_encoding_ezjsonm.ml \ utils/time.ml \ utils/hash.ml \ utils/crypto_box.ml \ utils/error_monad_sig.ml \ utils/error_monad.ml \ + utils/lwt_exit.ml \ utils/logging.ml \ utils/lwt_utils.ml \ utils/lwt_pipe.ml \ @@ -135,12 +167,10 @@ UTILS_LIB_IMPLS := \ utils/moving_average.ml \ UTILS_PACKAGES := \ + ${MINUTILS_PACKAGES} \ base64 \ calendar \ - cstruct \ ezjsonm \ - lwt \ - ocplib-json-typed \ sodium \ zarith \ $(COVERAGEPKG) \ @@ -149,7 +179,7 @@ UTILS_OBJS := \ ${UTILS_LIB_IMPLS:.ml=.cmx} ${UTILS_LIB_IMPLS:.ml=.ml.deps} \ ${UTILS_LIB_INTFS:.mli=.cmi} ${UTILS_LIB_INTFS:.mli=.mli.deps} ${UTILS_OBJS}: PACKAGES=${UTILS_PACKAGES} -${UTILS_OBJS}: SOURCE_DIRECTORIES=utils +${UTILS_OBJS}: SOURCE_DIRECTORIES=minutils utils ${UTILS_OBJS}: TARGET="(utils.cmxa)" ${UTILS_OBJS}: OPENED_MODULES= @@ -157,7 +187,6 @@ utils.cmxa: ${UTILS_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ - ############################################################################ ## Node protocol compiler (also embedded in the main program) ############################################################################ @@ -188,7 +217,7 @@ COMPILER_OBJS := \ ${COMPILER_LIB_INTFS:.mli=.cmi} ${COMPILER_LIB_INTFS:.mli=.mli.deps} \ ${TZCOMPILER} ${COMPILER_OBJS}: PACKAGES=${COMPILER_PACKAGES} -${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils compiler +${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils minutils compiler ${COMPILER_OBJS}: TARGET="(compiler.cmxa)" ${COMPILER_OBJS}: \ OPENED_MODULES=Error_monad Hash Utils @@ -197,7 +226,7 @@ compiler.cmxa: ${COMPILER_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ -${TZCOMPILER}: utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx} +${TZCOMPILER}: minutils.cmxa utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @$(OCAMLOPT) -linkpkg $(patsubst %, -package %, $(COMPILER_PACKAGES)) -o $@ $^ @@ -212,7 +241,7 @@ clean:: NODE_LIB_INTFS := \ \ node/net/p2p.mli \ - node/net/RPC.mli \ + node/net/RPC_server.mli \ \ node/updater/fitness.mli \ \ @@ -242,7 +271,7 @@ NODE_LIB_IMPLS := \ compiler/node_compiler_main.ml \ \ node/net/p2p.ml \ - node/net/RPC.ml \ + node/net/RPC_server.ml \ \ node/updater/fitness.ml \ \ @@ -291,7 +320,7 @@ NODE_OBJS := \ ${NODE_LIB_INTFS:.mli=.cmi} ${NODE_LIB_INTFS:.mli=.mli.deps} \ ${TZNODE} ${NODE_OBJS}: PACKAGES=${NODE_PACKAGES} -${NODE_OBJS}: SOURCE_DIRECTORIES=utils compiler node/db node/net node/updater node/shell +${NODE_OBJS}: SOURCE_DIRECTORIES=minutils utils compiler node/db node/net node/updater node/shell ${NODE_OBJS}: TARGET="(node.cmxa)" ${NODE_OBJS}: OPENED_MODULES=Error_monad Hash Utils @@ -300,7 +329,7 @@ node.cmxa: ${NODE_LIB_IMPLS:.ml=.cmx} @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ ${NODE_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS} -${TZNODE}: utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx} +${TZNODE}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ @@ -318,7 +347,7 @@ proto/embedded_proto_%.cmxa: \ @${TZCOMPILER} -static -build-dir proto/$*/_tzbuild $@ proto/$*/ CLIENT_PROTO_INCLUDES := \ - utils node/updater node/db node/net node/shell client \ + minutils utils node/updater node/db node/net node/shell client \ $(shell ocamlfind query lwt ocplib-json-typed sodium) proto/client_embedded_proto_%.cmxa: \ @@ -382,7 +411,7 @@ CLIENT_OBJS := \ ${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \ ${TZCLIENT} ${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES} -${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db compiler +${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded minutils utils node/net node/shell node/updater node/db compiler ${CLIENT_OBJS}: TARGET="(client.cmxa)" ${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils @@ -393,7 +422,7 @@ client.cmxa: ${CLIENT_LIB_IMPLS:.ml=.cmx} ${EMBEDDED_CLIENT_PROTOCOLS}: client.cmxa ${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS} -${TZCLIENT}: utils.cmxa compiler.cmxa node.cmxa \ +${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \ client.cmxa ${EMBEDDED_CLIENT_PROTOCOLS} \ ${CLIENT_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @@ -446,7 +475,8 @@ ifneq ($(MAKECMDGOALS),build-deps) -include .depend endif endif -DEPENDS := $(filter-out $(NO_DEPS), $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \ +DEPENDS := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) \ + $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \ $(COMPILER_LIB_INTFS) $(COMPILER_LIB_IMPLS) \ $(COMPILER_INTFS) $(COMPILER_IMPLS) \ $(NODE_LIB_INTFS) $(NODE_LIB_IMPLS) \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index a7821178f..4d30c3dda 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -61,7 +61,7 @@ module Alias = functor (Entity : Entity) -> struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return [] else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the %s alias file" Entity.name | Some json -> @@ -98,11 +98,11 @@ module Alias = functor (Entity : Entity) -> struct catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding list in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> fail (Failure "Json.write_file") | true -> return ()) (fun exn -> diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 21560a74e..6dd9b287e 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -135,7 +135,7 @@ let parse_args ?version usage dispatcher = (* parse once again with contextual options *) Arg.parse_argv_dynamic ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; - Utils.create_dir (Filename.dirname config_file#get) >>= fun () -> + Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () -> file_group#write config_file#get ; Lwt.return () with Sys_error msg -> diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index a31473050..19d5fa803 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -132,7 +132,7 @@ let editor_fill_in schema = | Error msg -> return (Error msg) | Ok json -> Lwt_io.(with_file Output tmp (fun fp -> - write_line fp (Data_encoding.Json.to_string json))) >>= fun () -> + write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () -> edit () and edit () = (* launch the user's editor on it *) @@ -160,7 +160,7 @@ let editor_fill_in schema = and reread () = (* finally reread the file *) Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text -> - match Data_encoding.Json.from_string text with + match Data_encoding_ezjsonm.from_string text with | Ok r -> return (Ok r) | Error msg -> return (Error (Printf.sprintf "bad input: %s" msg)) and delete () = @@ -286,8 +286,8 @@ let schema url () = Client_node_rpcs.describe ~recurse:false args >>= function | Static { service = Some { input ; output } } -> Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!" - (Data_encoding.Json.to_string (Json_schema.to_json input)) - (Data_encoding.Json.to_string (Json_schema.to_json output)) + (Data_encoding_ezjsonm.to_string (Json_schema.to_json input)) + (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) | _ -> Cli_entries.message "No service found at this URL (but this is a valid prefix)\n%!" @@ -309,7 +309,7 @@ let call url () = error "%s" msg | Ok json -> Client_node_rpcs.get_json args json >>= fun json -> - Cli_entries.message "Output:\n%s\n%!" (Data_encoding.Json.to_string json) + Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) end | _ -> Cli_entries.message diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index def106a08..b3092747a 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -29,7 +29,7 @@ let make_request service json = ^ ":" ^ string_of_int Client_config.incoming_port#get in let string_uri = String.concat "/" (serv :: service) in let uri = Uri.of_string string_uri in - let reqbody = Data_encoding.Json.to_string json in + let reqbody = Data_encoding_ezjsonm.to_string json in let tzero = Unix.gettimeofday () in catch (fun () -> @@ -61,7 +61,7 @@ let get_streamed_json service json = lwt_log_error "Failed to parse json: %s" msg >>= fun () -> Lwt.return None) - (Data_encoding.Json.from_stream ansbody)) + (Data_encoding_ezjsonm.from_stream ansbody)) | err, _ansbody -> (if Client_config.print_timings#get then message "Request to /%s failed in %gs" @@ -83,7 +83,7 @@ let get_json service json = else Lwt.return ()) >>= fun () -> log_response cpt code ansbody >>= fun () -> if ansbody = "" then Lwt.return `Null - else match Data_encoding.Json.from_string ansbody with + else match Data_encoding_ezjsonm.from_string ansbody with | Error _ -> error "the RPC server returned malformed JSON" | Ok res -> Lwt.return res end @@ -103,7 +103,7 @@ let parse_answer service path json = match RPC.read_answer service json with | Error msg -> (* TODO print_error *) error "request to /%s returned wrong JSON (%s)\n%s" - (String.concat "/" path) msg (Data_encoding.Json.to_string json) + (String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json) | Ok v -> return v let call_service0 service arg = @@ -124,7 +124,7 @@ let call_streamed_service0 service arg = Lwt_stream.map_s (parse_answer service path) st module Services = Node_rpc_services -let errors = call_service0 RPC.Error.service +let errors = call_service0 Services.Error.service let forge_block ?net ?predecessor ?timestamp fitness ops header = call_service0 Services.forge_block (net, predecessor, timestamp, fitness, ops, header) diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared index e2aa12c45..083d8cf4a 100644 --- a/src/client/embedded/Makefile.shared +++ b/src/client/embedded/Makefile.shared @@ -5,6 +5,7 @@ include ../../../Makefile.config NODE_DIRECTORIES = \ $(addprefix ../../../, \ + minutils \ utils \ node/updater \ node/db \ diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml index 5e2f3dcf7..526f51fce 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.ml +++ b/src/client/embedded/bootstrap/client_proto_nonces.ml @@ -28,7 +28,7 @@ let load () = if not (Sys.file_exists filename) then Lwt.return [] else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the nonces file" | Some json -> match Data_encoding.Json.destruct encoding json with @@ -39,7 +39,7 @@ let load () = let check_dir dirname = if not (Sys.file_exists dirname) then - Utils.create_dir dirname + Lwt_utils.create_dir dirname else Lwt.return () @@ -50,7 +50,7 @@ let save list = check_dir dirname >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding list in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index 26361c782..425967e60 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -48,7 +48,7 @@ end = struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the endorsement file" | Some json -> @@ -62,11 +62,11 @@ end = struct Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding map in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 0457252d5..7d023ec61 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -168,7 +168,7 @@ end = struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> failwith "couldn't to read the block file" | Some json -> @@ -182,11 +182,11 @@ end = struct Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding map in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client_main.ml b/src/client_main.ml index 1ab0e9ec3..408f60546 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -24,7 +24,7 @@ let () = prerr_endline msg ; Lwt.return () | log -> - Utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> + Lwt_utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> Lwt_io.with_file ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] ~mode: Lwt_io.Output diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 6f868a5cc..e833929ee 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -113,15 +113,16 @@ module Meta = struct (req "modules" ~description:"Modules comprising the protocol" (list string)) let to_file dirname ?hash modules = - let open Data_encoding.Json in - let config_file = construct config_file_encoding (hash, modules) in - Utils.write_file ~bin:false (dirname // name) @@ to_string config_file + let config_file = + Data_encoding.Json.construct config_file_encoding (hash, modules) in + Utils.write_file ~bin:false (dirname // name) @@ + Data_encoding_ezjsonm.to_string config_file let of_file dirname = - let open Data_encoding.Json in - Utils.read_file ~bin:false (dirname // name) |> from_string |> function + Utils.read_file ~bin:false (dirname // name) |> + Data_encoding_ezjsonm.from_string |> function | Error err -> Pervasives.failwith err - | Ok json -> destruct config_file_encoding json + | Ok json -> Data_encoding.Json.destruct config_file_encoding json end module Protocol = struct diff --git a/src/minutils/RPC.ml b/src/minutils/RPC.ml new file mode 100644 index 000000000..313fad0b4 --- /dev/null +++ b/src/minutils/RPC.ml @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Arg = Resto.Arg +module Path = Resto.Path +module Description = Resto.Description +let read_answer = Resto.read_answer +let forge_request = Resto.forge_request +let service ?description ~input ~output path = + Resto.service + ?description + ~input:(Data_encoding.Json.convert input) + ~output:(Data_encoding.Json.convert output) + path +type ('prefix, 'params, 'input, 'output) service = + ('prefix, 'params, 'input, 'output) Resto.service + +include RestoDirectory diff --git a/src/node/net/RPC.mli b/src/minutils/RPC.mli similarity index 80% rename from src/node/net/RPC.mli rename to src/minutils/RPC.mli index 0a8c5432b..d00770358 100644 --- a/src/node/net/RPC.mli +++ b/src/minutils/RPC.mli @@ -7,11 +7,7 @@ (* *) (**************************************************************************) -(** View over the RPC service, restricted to types. A protocol - implementation can define a set of remote procedures which are - registered when the protocol is activated via its [rpcs] - function. However, it cannot register new or update existing - procedures afterwards, neither can it see other procedures. *) +(** Typed RPC services: definition, binding and dispatch. *) (** Typed path argument. *) module Arg : sig @@ -278,40 +274,9 @@ val register_describe_directory_service: ('prefix, 'prefix, bool option, Description.directory_descr) service -> 'prefix directory -(** A handle on the server worker. *) -type server +exception Cannot_parse of Arg.descr * string * string list -(** Promise a running RPC serve ; takes the port. To call - an RPC at /p/a/t/h/ in the provided service, one must call the URI - /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services - prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will - describe the input and output of the service, if it is - callable. Calling /pipe will read a sequence of services to call in - sequence from the request body, see {!pipe_encoding}. - - The optional [pre_hook] is called with the path part of the URL - before resolving each request, to delegate the answering to - another resolution mechanism. Its result is ignored if the return - code is [404]. The optional [post_hook] is called if both the - [pre_hook] and the serviced answered with a [404] code. *) -val launch : int -> - ?pre_hook: (string -> string Answer.answer Lwt.t) -> - ?post_hook: (string -> string Answer.answer Lwt.t) -> - unit directory -> server Lwt.t - -(** Kill an RPC server. *) -val shutdown : server -> unit Lwt.t - -(** Retrieve the root service of the server *) -val root_service : server -> unit directory - -(** Change the root service of the server *) -val set_root_service : server -> unit directory -> unit - -module Error : sig - val service: (unit, unit, unit, Json_schema.schema) service - val encoding: error list Data_encoding.t - val wrap: - 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding - -end +(** Resolve a service. *) +val lookup: + 'prefix directory -> 'prefix -> string list -> + (Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t diff --git a/src/utils/compare.ml b/src/minutils/compare.ml similarity index 100% rename from src/utils/compare.ml rename to src/minutils/compare.ml diff --git a/src/utils/compare.mli b/src/minutils/compare.mli similarity index 100% rename from src/utils/compare.mli rename to src/minutils/compare.mli diff --git a/src/utils/data_encoding.ml b/src/minutils/data_encoding.ml similarity index 95% rename from src/utils/data_encoding.ml rename to src/minutils/data_encoding.ml index f106d869b..3de84af44 100644 --- a/src/utils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -213,54 +213,6 @@ module Json = struct type nonrec json = json - let to_root = function - | `O ctns -> `O ctns - | `A ctns -> `A ctns - | `Null -> `O [] - | oth -> `A [ oth ] - - let to_string j = Ezjsonm.to_string ~minify:false (to_root j) - - let from_string s = - try Ok (Ezjsonm.from_string s :> json) - with Ezjsonm.Parse_error (_, msg) -> Error msg - - let from_stream (stream: string Lwt_stream.t) = - let buffer = ref "" in - Lwt_stream.filter_map - (fun str -> - buffer := !buffer ^ str ; - try - let json = Ezjsonm.from_string !buffer in - buffer := "" ; - Some (Ok json) - with Ezjsonm.Parse_error (_, msg) -> - if String.length str = 32 * 1024 then None - else Some (Error msg)) - stream - - let write_file file json = - let json = to_root json in - let open Lwt in - catch - (fun () -> - Lwt_io.(with_file ~mode:Output file (fun chan -> - let str = to_string json in - write chan str >>= fun _ -> - return true))) - (fun _ -> return false) - - let read_file file = - let open Lwt in - catch - (fun () -> - Lwt_io.(with_file ~mode:Input file (fun chan -> - read chan >>= fun str -> - return (Some (Ezjsonm.from_string str :> json))))) - (fun _ -> - (* TODO log error or use Error_monad. *) - return None) - let wrap_error f = fun str -> try f str @@ -523,19 +475,35 @@ module Encoding = struct let json = Json.convert json in raw_splitted ~binary ~json - let raw_json json = + let json = let binary = conv - (fun v -> Json_encoding.construct json v |> Json.to_string) - (fun s -> - match Json.from_string s with - | Error msg -> raise (Json.Parse_error msg) - | Ok v -> Json_encoding.destruct json v) + (fun json -> + Json_repr.convert + (module Json_repr.Ezjsonm) + (module Json_repr_bson.Repr) + json |> + Json_repr_bson.bson_to_bytes |> + Bytes.to_string) + (fun s -> try + Bytes.of_string s |> + Json_repr_bson.bytes_to_bson ~copy:false |> + Json_repr.convert + (module Json_repr_bson.Repr) + (module Json_repr.Ezjsonm) + with + | Json_repr_bson.Bson_decoding_error (msg, _, _) -> + raise (Json.Parse_error msg)) string in + let json = + Json_encoding.any_ezjson_value in raw_splitted ~binary ~json - let json = raw_json Json_encoding.any_ezjson_value - let json_schema = raw_json Json_encoding.any_schema + let json_schema = + conv + Json_schema.to_json + Json_schema.of_json + json let raw_merge_objs e1 e2 = let kind = Kind.combine "objects" (classify e1) (classify e2) in diff --git a/src/utils/data_encoding.mli b/src/minutils/data_encoding.mli similarity index 91% rename from src/utils/data_encoding.mli rename to src/minutils/data_encoding.mli index 86ba4403f..be410b820 100644 --- a/src/utils/data_encoding.mli +++ b/src/minutils/data_encoding.mli @@ -180,24 +180,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding module Json : sig - (** Read a JSON document from a string. *) - val from_string : string -> (json, string) result - - (** Read a stream of JSON documents from a stream of strings. - A single JSON document may be represented in multiple consecutive - strings. But only the first document of a string is considered. *) - val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t - - (** Write a JSON document to a string. This goes via an intermediate - buffer and so may be slow on large documents. *) - val to_string : json -> string - - (** Loads a JSON file in memory *) - val read_file : string -> json option Lwt.t - - (** (Over)write a JSON file from in memory data *) - val write_file : string -> json -> bool Lwt.t - val convert : 'a encoding -> 'a Json_encoding.encoding val schema : 'a encoding -> json_schema diff --git a/src/utils/hex_encode.ml b/src/minutils/hex_encode.ml similarity index 100% rename from src/utils/hex_encode.ml rename to src/minutils/hex_encode.ml diff --git a/src/utils/hex_encode.mli b/src/minutils/hex_encode.mli similarity index 100% rename from src/utils/hex_encode.mli rename to src/minutils/hex_encode.mli diff --git a/src/utils/mBytes.ml b/src/minutils/mBytes.ml similarity index 100% rename from src/utils/mBytes.ml rename to src/minutils/mBytes.ml diff --git a/src/utils/mBytes.mli b/src/minutils/mBytes.mli similarity index 100% rename from src/utils/mBytes.mli rename to src/minutils/mBytes.mli diff --git a/src/utils/utils.ml b/src/minutils/utils.ml similarity index 71% rename from src/utils/utils.ml rename to src/minutils/utils.ml index b52aab3c9..d083f5cb4 100644 --- a/src/utils/utils.ml +++ b/src/minutils/utils.ml @@ -7,55 +7,6 @@ (* *) (**************************************************************************) -let (>>=) = Lwt.bind - -let remove_dir dir = - let rec remove dir = - let files = Lwt_unix.files_of_directory dir in - Lwt_stream.iter_s - (fun file -> - if file = "." || file = ".." then - Lwt.return () - else begin - let file = Filename.concat dir file in - if Sys.is_directory file - then remove file - else Lwt_unix.unlink file - end) - files >>= fun () -> - Lwt_unix.rmdir dir in - if Sys.file_exists dir && Sys.is_directory dir then - remove dir - else - Lwt.return () - -let rec create_dir ?(perm = 0o755) dir = - if Sys.file_exists dir then - Lwt.return () - else begin - create_dir (Filename.dirname dir) >>= fun () -> - Lwt_unix.mkdir dir perm - end - -let create_file ?(perm = 0o644) name content = - Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> - Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> - Lwt_unix.close fd - - -exception Exit -let termination_thread, exit_wakener = Lwt.wait () -let exit x = Lwt.wakeup exit_wakener x; raise Exit - -let () = - Lwt.async_exception_hook := - (function - | Exit -> () - | exn -> - Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" - (Printexc.to_string exn) (Printexc.get_backtrace ()); - Lwt.wakeup exit_wakener 1) - module StringMap = Map.Make (String) let split delim ?(limit = max_int) path = diff --git a/src/utils/utils.mli b/src/minutils/utils.mli similarity index 90% rename from src/utils/utils.mli rename to src/minutils/utils.mli index e42aaa302..1c5a3f00a 100644 --- a/src/utils/utils.mli +++ b/src/minutils/utils.mli @@ -7,14 +7,6 @@ (* *) (**************************************************************************) -val remove_dir: string -> unit Lwt.t - -val create_dir: ?perm:int -> string -> unit Lwt.t -val create_file: ?perm:int -> string -> string -> unit Lwt.t - -val termination_thread: int Lwt.t -val exit: int -> 'a - module StringMap : Map.S with type key = string (** Splits a string on slashes, grouping multiple slashes, and diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 982623809..0d5eea8ba 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -112,7 +112,7 @@ let checkout ((module GitStore : STORE) as index) key = GitStore.patch_context (pack (module GitStore) store v) >>= fun ctxt -> Lwt.return (Some (Ok ctxt)) | Some bytes -> - match Data_encoding.Json.from_string (MBytes.to_string bytes) with + match Data_encoding_ezjsonm.from_string (MBytes.to_string bytes) with | Ok (`A errors) -> Lwt.return (Some (Error (List.map error_of_json errors))) | Error _ | Ok _-> @@ -166,7 +166,7 @@ let commit_invalid (module GitStore : STORE) block key exns = GitStore.clone Irmin.Task.none store (Block_hash.to_b48check key) >>= function | `Empty_head -> GitStore.update store invalid_context_key - (MBytes.of_string @@ Data_encoding.Json.to_string @@ + (MBytes.of_string @@ Data_encoding_ezjsonm.to_string @@ `A (List.map json_of_error exns)) | `Duplicated_branch | `Ok _ -> Lwt.fail (Preexistent_context (GitStore.path, key)) diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 92a342922..171b1fa54 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -631,7 +631,7 @@ let read_genesis, store_genesis = get t key >>= function | None -> Lwt.return None | Some v -> - match Data_encoding.Json.from_string (MBytes.to_string v) with + match Data_encoding_ezjsonm.from_string (MBytes.to_string v) with | Error _ -> fatal_error "Store.read_genesis: invalid json object." @@ -643,7 +643,7 @@ let read_genesis, store_genesis = "Store.read_genesis: cannot parse json object." in let store t h = set t key ( MBytes.of_string @@ - Data_encoding.Json.to_string @@ + Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.construct genesis_encoding h ) in (read, store) diff --git a/src/node/net/RPC.ml b/src/node/net/RPC_server.ml similarity index 78% rename from src/node/net/RPC.ml rename to src/node/net/RPC_server.ml index 1b56982f3..8d532e411 100644 --- a/src/node/net/RPC.ml +++ b/src/node/net/RPC_server.ml @@ -7,24 +7,9 @@ (* *) (**************************************************************************) +open RPC open Logging.RPC -module Arg = Resto.Arg -module Path = Resto.Path -module Description = Resto.Description -let read_answer = Resto.read_answer -let forge_request = Resto.forge_request -let service ?description ~input ~output path = - Resto.service - ?description - ~input:(Data_encoding.Json.convert input) - ~output:(Data_encoding.Json.convert output) - path -type ('prefix, 'params, 'input, 'output) service = - ('prefix, 'params, 'input, 'output) Resto.service - -include RestoDirectory - (* public types *) type server = (* hidden *) { shutdown : unit -> unit Lwt.t ; @@ -99,7 +84,7 @@ let launch port ?pre_hook ?post_hook root = match req.meth with | `POST -> begin Cohttp_lwt_body.to_string body >>= fun body -> - match Data_encoding.Json.from_string body with + match Data_encoding_ezjsonm.from_string body with | Error msg -> Lwt.fail (Cannot_parse_body msg) | Ok body -> Lwt.return (Some body) end @@ -111,10 +96,10 @@ let launch port ?pre_hook ?post_hook root = | Empty -> Cohttp_lwt_body.empty | Single json -> - Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json) + Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json) | Stream s -> let stream = - create_stream io con Data_encoding.Json.to_string s in + create_stream io con Data_encoding_ezjsonm.to_string s in Cohttp_lwt_body.of_stream stream in lwt_log_info "(%s) RPC %s" (Cohttp.Connection.to_string con) @@ -171,41 +156,3 @@ let set_root_service server root = server.root <- root let shutdown server = server.shutdown () - -module Error = struct - - let service = - service - ~description: "Schema for all the RPC errors from the shell" - ~input: Data_encoding.empty - ~output: Data_encoding.json_schema - Path.(root / "errors") - - let encoding = - let open Data_encoding in - let path, _ = forge_request service () () in - describe - ~description: - (Printf.sprintf - "The full list of error is available with \ - the global RPC `/%s`" (String.concat "/" path)) - (conv - ~schema:Json_schema.any - (fun exn -> `A (List.map json_of_error exn)) - (function `A exns -> List.map error_of_json exns | _ -> []) - json) - - let wrap param_encoding = - let open Data_encoding in - union [ - case - (obj1 (req "ok" param_encoding)) - (function Ok x -> Some x | _ -> None) - (fun x -> Ok x) ; - case - (obj1 (req "error" encoding)) - (function Error x -> Some x | _ -> None) - (fun x -> Error x) ; - ] - -end diff --git a/src/node/net/RPC_server.mli b/src/node/net/RPC_server.mli new file mode 100644 index 000000000..9366b3606 --- /dev/null +++ b/src/node/net/RPC_server.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Typed RPC services: server implementation. *) + +(** A handle on the server worker. *) +type server + +(** Promise a running RPC serve ; takes the port. To call + an RPC at /p/a/t/h/ in the provided service, one must call the URI + /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services + prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will + describe the input and output of the service, if it is + callable. Calling /pipe will read a sequence of services to call in + sequence from the request body, see {!pipe_encoding}. + + The optional [pre_hook] is called with the path part of the URL + before resolving each request, to delegate the answering to + another resolution mechanism. Its result is ignored if the return + code is [404]. The optional [post_hook] is called if both the + [pre_hook] and the serviced answered with a [404] code. *) +val launch : int -> + ?pre_hook: (string -> string RPC.Answer.answer Lwt.t) -> + ?post_hook: (string -> string RPC.Answer.answer Lwt.t) -> + unit RPC.directory -> server Lwt.t + +(** Kill an RPC server. *) +val shutdown : server -> unit Lwt.t + +(** Retrieve the root service of the server *) +val root_service : server -> unit RPC.directory + +(** Change the root service of the server *) +val set_root_service : server -> unit RPC.directory -> unit diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 90bca1bf8..5f28add55 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -773,7 +773,7 @@ module Make (P: PARAMS) = struct (* create the external message pipe *) let messages = Lwt_pipe.create 100 in (* fill the known peers pools from last time *) - Data_encoding.Json.read_file config.peers_file >>= fun res -> + Data_encoding_ezjsonm.read_file config.peers_file >>= fun res -> let known_peers, black_list, my_gid, my_public_key, my_secret_key, my_proof_of_work = let init_peers () = @@ -872,7 +872,7 @@ module Make (P: PARAMS) = struct if source.white_listed then (addr, port) :: w else w)) !known_peers ([], BlackList.bindings !black_list, [])) in - Data_encoding.Json.write_file config.peers_file json >>= fun _ -> + Data_encoding_ezjsonm.write_file config.peers_file json >>= fun _ -> debug "(%a) peer cache saved" pp_gid my_gid ; Lwt.return_unit) ; (* storage of active and not yet active peers *) diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 354187527..d555bcbdd 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -433,7 +433,7 @@ let build_rpc_directory node = let dir = let implementation () = RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in - RPC.register0 dir RPC.Error.service implementation in + RPC.register0 dir Services.Error.service implementation in let dir = RPC.register1 dir Services.complete (fun s () -> diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index c1046755a..ba6be7dcb 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -9,6 +9,42 @@ open Data_encoding +module Error = struct + + let service = + RPC.service + ~description: "Schema for all the RPC errors from the shell" + ~input: Data_encoding.empty + ~output: Data_encoding.json_schema + RPC.Path.(root / "errors") + + let encoding = + let path, _ = RPC.forge_request service () () in + describe + ~description: + (Printf.sprintf + "The full list of error is available with \ + the global RPC `/%s`" (String.concat "/" path)) + (conv + ~schema:Json_schema.any + (fun exn -> `A (List.map json_of_error exn)) + (function `A exns -> List.map error_of_json exns | _ -> []) + json) + + let wrap param_encoding = + union [ + case + (obj1 (req "ok" param_encoding)) + (function Ok x -> Some x | _ -> None) + (fun x -> Ok x) ; + case + (obj1 (req "error" encoding)) + (function Error x -> Some x | _ -> None) + (fun x -> Error x) ; + ] + +end + module Blocks = struct type block = [ @@ -128,7 +164,7 @@ module Blocks = struct (obj3 (req "timestamp" Time.encoding) (req "fitness" Fitness.encoding) - (req "operations" (Updater.preapply_result_encoding RPC.Error.encoding)))) + (req "operations" (Updater.preapply_result_encoding Error.encoding)))) let block_path : (unit, unit * block) RPC.Path.path = RPC.Path.(root / "blocks" /: blocks_arg ) @@ -237,9 +273,9 @@ module Blocks = struct (obj4 (req "applied" (list Operation_hash.encoding)) (req "branch_delayed" - (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (list (tup2 Operation_hash.encoding Error.encoding))) (req "branch_refused" - (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (list (tup2 Operation_hash.encoding Error.encoding))) (req "unprocessed" (list Operation_hash.encoding)))) RPC.Path.(block_path / "pending_operations") @@ -252,7 +288,7 @@ module Blocks = struct "Simulate the validation of a block that would contain \ the given operations and return the resulting fitness." ~input: preapply_param_encoding - ~output: (RPC.Error.wrap preapply_result_encoding) + ~output: (Error.wrap preapply_result_encoding) RPC.Path.(block_path / "preapply") let complete = @@ -365,7 +401,7 @@ module Operations = struct (obj1 (req "data" (describe ~title: "Tezos signed operation (hex encoded)" (Time.timed_encoding @@ - RPC.Error.wrap @@ + Error.wrap @@ Updater.raw_operation_encoding)))) RPC.Path.(root / "operations" /: operations_arg) @@ -416,7 +452,7 @@ module Protocols = struct (obj1 (req "data" (describe ~title: "Tezos protocol" (Time.timed_encoding @@ - RPC.Error.wrap @@ + Error.wrap @@ Store.protocol_encoding)))) RPC.Path.(root / "protocols" /: protocols_arg) @@ -471,7 +507,7 @@ let validate_block = (req "net" Blocks.net_encoding) (req "hash" Block_hash.encoding)) ~output: - (RPC.Error.wrap @@ empty) + (Error.wrap @@ empty) RPC.Path.(root / "validate_block") let inject_block = @@ -504,7 +540,7 @@ let inject_block = the current head. (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ (obj1 (req "block_hash" Block_hash.encoding))) RPC.Path.(root / "inject_block") @@ -539,7 +575,7 @@ let inject_operation = or \"branch_delayed\". (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ describe ~title: "Hash of the injected operation" @@ (obj1 (req "injectedOperation" Operation_hash.encoding))) @@ -592,7 +628,7 @@ let inject_protocol = "Should we inject protocol that is invalid. (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ describe ~title: "Hash of the injected protocol" @@ (obj1 (req "injectedProtocol" Protocol_hash.encoding))) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index bc2e5e86b..5ad9771a9 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -7,6 +7,12 @@ (* *) (**************************************************************************) +module Error : sig + val service: (unit, unit, unit, Json_schema.schema) RPC.service + val encoding: error list Data_encoding.t + val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding +end + module Blocks : sig type block = [ @@ -15,6 +21,7 @@ module Blocks : sig | `Test_head of int | `Test_prevalidation | `Hash of Block_hash.t ] + val blocks_arg : block RPC.Arg.arg val parse_block: string -> (block, string) result type net = Store.net_id = Net of Block_hash.t diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 3ca23c774..608019be4 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -140,18 +140,18 @@ type component = Tezos_compiler.Protocol.component = { } let create_files dir units = - Utils.remove_dir dir >>= fun () -> - Utils.create_dir dir >>= fun () -> + Lwt_utils.remove_dir dir >>= fun () -> + Lwt_utils.create_dir dir >>= fun () -> Lwt_list.map_s (fun { name; interface; implementation } -> let name = String.lowercase_ascii name in let ml = dir // (name ^ ".ml") in let mli = dir // (name ^ ".mli") in - Utils.create_file ml implementation >>= fun () -> + Lwt_utils.create_file ml implementation >>= fun () -> match interface with | None -> Lwt.return [ml] | Some content -> - Utils.create_file mli content >>= fun () -> + Lwt_utils.create_file mli content >>= fun () -> Lwt.return [mli;ml]) units >>= fun files -> let files = List.concat files in diff --git a/src/node_main.ml b/src/node_main.ml index 2134b5c9a..b73e398b2 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -206,14 +206,15 @@ module Cfg_file = struct (req "log" log)) let read fp = - let open Data_encoding.Json in - read_file fp >|= function + Data_encoding_ezjsonm.read_file fp >|= function | None -> None - | Some json -> Some (destruct t json) + | Some json -> Some (Data_encoding.Json.destruct t json) let from_json json = Data_encoding.Json.destruct t json let write out cfg = - Utils.write_file ~bin:false out Data_encoding.Json.(construct t cfg |> to_string) + Utils.write_file ~bin:false out + (Data_encoding.Json.construct t cfg |> + Data_encoding_ezjsonm.to_string) end module Cmdline = struct @@ -289,7 +290,7 @@ module Cmdline = struct default_cfg_of_base_dir base_dir in let cfg = - match Utils.read_file ~bin:false config_file |> Data_encoding.Json.from_string with + match Utils.read_file ~bin:false config_file |> Data_encoding_ezjsonm.from_string with | exception _ -> no_config () | Error msg -> corrupted_config msg | Ok cfg -> try Cfg_file.from_json cfg with @@ -382,7 +383,7 @@ let init_node { sandbox ; sandbox_param ; match sandbox_param with | None -> Lwt.return (Some (patch_context None)) | Some file -> - Data_encoding.Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function | None -> lwt_warn "Can't parse sandbox parameters. (%s)" file >>= fun () -> @@ -427,11 +428,11 @@ let init_rpc { rpc_addr } node = | Some (_addr, port) -> lwt_log_notice "Starting the RPC server listening on port %d." port >>= fun () -> let dir = Node_rpc.build_rpc_directory node in - RPC.(launch port dir) >>= fun server -> + RPC_server.launch port dir >>= fun server -> Lwt.return (Some server) let init_signal () = - let handler id = try Utils.exit id with _ -> () in + let handler id = try Lwt_exit.exit id with _ -> () in ignore (Lwt_unix.on_signal Sys.sigint handler : Lwt_unix.signal_handler_id) let main cfg = @@ -444,11 +445,11 @@ let main cfg = init_rpc cfg node >>= fun rpc -> init_signal (); lwt_log_notice "The Tezos node is now running!" >>= fun () -> - Utils.termination_thread >>= fun x -> + Lwt_exit.termination_thread >>= fun x -> lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> Node.shutdown node >>= fun () -> lwt_log_notice "Shutting down the RPC server..." >>= fun () -> - Lwt_utils.may RPC.shutdown rpc >>= fun () -> + Lwt_utils.may RPC_server.shutdown rpc >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () -> return () diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml index 2a23756f8..8a0c5e189 100644 --- a/src/proto/bootstrap/storage.ml +++ b/src/proto/bootstrap/storage.ml @@ -16,19 +16,19 @@ let prevalidation_key = [ version ; "prevalidation" ] type t = Storage_functors.context -type error += Invalid_sandbox_parameter of string +type error += Invalid_sandbox_parameter let get_sandboxed c = Context.get c sandboxed_key >>= function | None -> return None - | Some json -> - match Data_encoding.Json.from_string (MBytes.to_string json) with - | Error err -> fail (Invalid_sandbox_parameter err) - | Ok json -> return (Some json) + | Some bytes -> + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> fail Invalid_sandbox_parameter + | Some json -> return (Some json) let set_sandboxed c json = Context.set c sandboxed_key - (MBytes.of_string (Data_encoding.Json.to_string json)) + (Data_encoding.Binary.to_bytes Data_encoding.json json) let prepare (c : Context.t) : t tzresult Lwt.t = get_sandboxed c >>=? fun sandbox -> diff --git a/src/proto/environment/data_encoding.mli b/src/proto/environment/data_encoding.mli index b70ef5506..736ff8874 100644 --- a/src/proto/environment/data_encoding.mli +++ b/src/proto/environment/data_encoding.mli @@ -170,13 +170,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding module Json : sig - (** Read a JSON document from a string. *) - val from_string : string -> (json, string) result - - (** Write a JSON document to a string. This goes via an intermediate - buffer and so may be slow on large documents. *) - val to_string : json -> string - val schema : 'a encoding -> json_schema val construct : 't encoding -> 't -> json val destruct : 't encoding -> json -> 't diff --git a/src/utils/data_encoding_ezjsonm.ml b/src/utils/data_encoding_ezjsonm.ml new file mode 100644 index 000000000..0b3c36ebf --- /dev/null +++ b/src/utils/data_encoding_ezjsonm.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let to_root = function + | `O ctns -> `O ctns + | `A ctns -> `A ctns + | `Null -> `O [] + | oth -> `A [ oth ] + +let to_string j = Ezjsonm.to_string ~minify:false (to_root j) + +let from_string s = + try Ok (Ezjsonm.from_string s :> Data_encoding.json) + with Ezjsonm.Parse_error (_, msg) -> Error msg + +let from_stream (stream: string Lwt_stream.t) = + let buffer = ref "" in + Lwt_stream.filter_map + (fun str -> + buffer := !buffer ^ str ; + try + let json = Ezjsonm.from_string !buffer in + buffer := "" ; + Some (Ok json) + with Ezjsonm.Parse_error (_, msg) -> + if String.length str = 32 * 1024 then None + else Some (Error msg)) + stream + +let write_file file json = + let json = to_root json in + let open Lwt in + catch + (fun () -> + Lwt_io.(with_file ~mode:Output file (fun chan -> + let str = to_string json in + write chan str >>= fun _ -> + return true))) + (fun _ -> return false) + +let read_file file = + let open Lwt in + catch + (fun () -> + Lwt_io.(with_file ~mode:Input file (fun chan -> + read chan >>= fun str -> + return (Some (Ezjsonm.from_string str :> Data_encoding.json))))) + (fun _ -> + (* TODO log error or use Error_monad. *) + return None) diff --git a/src/utils/data_encoding_ezjsonm.mli b/src/utils/data_encoding_ezjsonm.mli new file mode 100644 index 000000000..a195f10a0 --- /dev/null +++ b/src/utils/data_encoding_ezjsonm.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Read a JSON document from a string. *) +val from_string : string -> (Data_encoding.json, string) result + +(** Read a stream of JSON documents from a stream of strings. + A single JSON document may be represented in multiple consecutive + strings. But only the first document of a string is considered. *) +val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt_stream.t + +(** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) +val to_string : Data_encoding.json -> string + +(** Loads a JSON file in memory *) +val read_file : string -> Data_encoding.json option Lwt.t + +(** (Over)write a JSON file from in memory data *) +val write_file : string -> Data_encoding.json -> bool Lwt.t diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 4aeaf2cea..f689b8410 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -18,7 +18,7 @@ type 'err full_error_category = let json_pp encoding ppf x = Format.pp_print_string ppf @@ - Data_encoding.Json.to_string @@ + Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.(construct encoding x) module Make() = struct diff --git a/src/utils/logging.ml b/src/utils/logging.ml index dea4cc404..2cad82973 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -54,7 +54,7 @@ module Make(S : sig val name: string end) : LOG = struct let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt let fatal_error fmt = Format.kasprintf - (fun s -> Lwt_log.ign_fatal ~section s; Utils.exit 1) + (fun s -> Lwt_log.ign_fatal ~section s; Lwt_exit.exit 1) fmt let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt diff --git a/src/utils/lwt_exit.ml b/src/utils/lwt_exit.ml new file mode 100644 index 000000000..2e82b1fe8 --- /dev/null +++ b/src/utils/lwt_exit.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +exception Exit + +let termination_thread, exit_wakener = Lwt.wait () +let exit x = Lwt.wakeup exit_wakener x; raise Exit + +let () = + Lwt.async_exception_hook := + (function + | Exit -> () + | exn -> + Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" + (Printexc.to_string exn) (Printexc.get_backtrace ()); + Lwt.wakeup exit_wakener 1) diff --git a/src/utils/lwt_exit.mli b/src/utils/lwt_exit.mli new file mode 100644 index 000000000..2ba38abb9 --- /dev/null +++ b/src/utils/lwt_exit.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** A global thread that resumes the first time {!exit} is called + anywhere in the program. Called by the main to wait for any other + thread in the system to call {!exit}. *) +val termination_thread: int Lwt.t + +(** Awakens the {!termination_thread} with the given return value, and + raises an exception that cannot be caught, except by a + catch-all. Should only be called once. *) +val exit: int -> 'a diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 3e4de7572..d3ad37d5b 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -263,3 +263,37 @@ let write_mbytes ?(pos=0) ?len descr buf = | nb_written -> inner (pos + nb_written) (len - nb_written) in inner pos len +let (>>=) = Lwt.bind + +let remove_dir dir = + let rec remove dir = + let files = Lwt_unix.files_of_directory dir in + Lwt_stream.iter_s + (fun file -> + if file = "." || file = ".." then + Lwt.return () + else begin + let file = Filename.concat dir file in + if Sys.is_directory file + then remove file + else Lwt_unix.unlink file + end) + files >>= fun () -> + Lwt_unix.rmdir dir in + if Sys.file_exists dir && Sys.is_directory dir then + remove dir + else + Lwt.return () + +let rec create_dir ?(perm = 0o755) dir = + if Sys.file_exists dir then + Lwt.return () + else begin + create_dir (Filename.dirname dir) >>= fun () -> + Lwt_unix.mkdir dir perm + end + +let create_file ?(perm = 0o644) name content = + Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> + Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> + Lwt_unix.close fd diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli index 2b3df7ac8..0fd73d6cd 100644 --- a/src/utils/lwt_utils.mli +++ b/src/utils/lwt_utils.mli @@ -35,3 +35,7 @@ val read_mbytes: val write_mbytes: ?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t + +val remove_dir: string -> unit Lwt.t +val create_dir: ?perm:int -> string -> unit Lwt.t +val create_file: ?perm:int -> string -> string -> unit Lwt.t diff --git a/test/.merlin b/test/.merlin index c283d6621..ce4f056ca 100644 --- a/test/.merlin +++ b/test/.merlin @@ -1,6 +1,8 @@ REC S . B . +S ../src/minutils +B ../src/minutils S ../src/utils B ../src/utils S ../src/node/db diff --git a/test/Makefile b/test/Makefile index a58b5abdd..45cf2e67d 100644 --- a/test/Makefile +++ b/test/Makefile @@ -13,6 +13,7 @@ OCAMLFLAGS = \ SOURCE_DIRECTORIES := \ lib \ $(addprefix ../src/, \ + minutils \ utils \ compiler \ node/db \ @@ -37,7 +38,7 @@ PACKAGES := \ lwt.unix \ ocplib-endian \ ocplib-ocamlres \ - ocplib-json-typed \ + ocplib-json-typed.bson \ ocplib-resto.directory \ sodium \ unix \ @@ -47,7 +48,9 @@ PACKAGES := \ ############################################################################ ## External packages -NODELIB := ../src/utils.cmxa ../src/compiler.cmxa ../src/node.cmxa +NODELIB := \ + ../src/minutils.cmxa ../src/utils.cmxa \ + ../src/compiler.cmxa ../src/node.cmxa CLIENTLIB := ../src/client.cmxa \ $(patsubst ../src/client/embedded/%/, \ ../src/proto/client_embedded_proto_%.cmxa, \ @@ -221,6 +224,7 @@ COVERAGESRCDIR= \ -I ../src/proto \ -I ../src/proto/bootstrap \ -I ../src/proto/demo \ + -I ../src/minutils \ -I ../src/utils bisect: diff --git a/test/test_basic.ml b/test/test_basic.ml index 682f56d88..44434f60f 100644 --- a/test/test_basic.ml +++ b/test/test_basic.ml @@ -13,7 +13,17 @@ open Tezos_context open Error_monad open Hash -let () = Random.self_init () +let () = + Random.self_init () ; + let log channel msg = match channel with + | "stdout" -> + print_endline msg ; + Lwt.return () + | "stderr" -> + prerr_endline msg ; + Lwt.return () + | _ -> Lwt.return () in + Cli_entries.log_hook := Some log let should_fail f t = t >>= function diff --git a/test/test_data_encoding.ml b/test/test_data_encoding.ml index 8a7b187ed..848419be9 100644 --- a/test/test_data_encoding.ml +++ b/test/test_data_encoding.ml @@ -104,15 +104,16 @@ let test_simple_values _ = Lwt.return_unit let test_json testdir = + let open Data_encoding_ezjsonm in let file = testdir // "testing_data_encoding.tezos" in let v = `Float 42. in - let f_str = Json.to_string v in + let f_str = to_string v in Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]"; - Json.read_file (testdir // "NONEXISTINGFILE") >>= fun rf -> + read_file (testdir // "NONEXISTINGFILE") >>= fun rf -> Assert.is_none ~msg:__LOC__ rf; - Json.write_file file v >>= fun success -> + write_file file v >>= fun success -> Assert.is_true ~msg:__LOC__ success; - Json.read_file file >>= fun opt -> + read_file file >>= fun opt -> Assert.is_some ~msg:__LOC__ opt; Lwt.return () @@ -267,7 +268,7 @@ let test_json_input testdir = } |} in - Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function None -> Assert.fail_msg "Cannot parse \"good.json\"." | Some json -> let (id, value, popup) = Json.destruct enc json in @@ -293,7 +294,7 @@ let test_json_input testdir = } |} in - Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function None -> Assert.fail_msg "Cannot parse \"unknown.json\"." | Some json -> Assert.test_fail ~msg:__LOC__