201 lines
7.2 KiB
OCaml
201 lines
7.2 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* Copyright (c) 2014 - 2016. *)
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* *)
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
(* Tezos Command line interface - Main Program *)
|
|
|
|
open Lwt.Infix
|
|
open Logging.Webclient
|
|
|
|
let make_context () =
|
|
let buffers = Hashtbl.create 50 in
|
|
Hashtbl.add buffers "stdout" (Buffer.create 1000) ;
|
|
Hashtbl.add buffers "stderr" (Buffer.create 1000) ;
|
|
let log channel msg =
|
|
let buffer =
|
|
try Hashtbl.find buffers channel with
|
|
Not_found ->
|
|
let buffer = Buffer.create 1000 in
|
|
Hashtbl.add buffers channel buffer ;
|
|
buffer in
|
|
Buffer.add_string buffer msg ;
|
|
Buffer.add_char buffer '\n' ;
|
|
Lwt.return () in
|
|
Client_commands.make_context log,
|
|
(fun () ->
|
|
Hashtbl.fold
|
|
(fun channel buffer acc ->
|
|
(channel, Buffer.contents buffer) :: acc)
|
|
buffers [])
|
|
|
|
let block_protocol cctxt block =
|
|
Lwt.catch
|
|
(fun () ->
|
|
Client_node_rpcs.Blocks.protocol cctxt block)
|
|
(fun _ ->
|
|
cctxt.Client_commands.message
|
|
"\n\
|
|
The connection to the RPC server failed, \
|
|
using the default protocol version.\n" >>= fun () ->
|
|
Lwt.return Client_bootstrap.Client_proto_main.protocol)
|
|
|
|
let eval_command argv =
|
|
let cctxt, result = make_context () in
|
|
Lwt.catch
|
|
(fun () ->
|
|
Client_config.preparse_args argv cctxt >>= fun block ->
|
|
block_protocol cctxt block >>= fun version ->
|
|
let commands =
|
|
Client_generic_rpcs.commands @
|
|
Client_keys.commands () @
|
|
Client_protocols.commands () @
|
|
Client_helpers.commands () @
|
|
Client_commands.commands_for_version version in
|
|
Client_config.parse_args ~version
|
|
(Cli_entries.usage ~commands)
|
|
(Cli_entries.inline_dispatch commands)
|
|
argv cctxt >>= fun command ->
|
|
command cctxt >>= fun () ->
|
|
Lwt.return (Ok (result ())))
|
|
(fun exn ->
|
|
let msg = match exn with
|
|
| Arg.Help help ->
|
|
Format.asprintf "%s%!" help
|
|
| Arg.Bad help ->
|
|
Format.asprintf "%s%!" help
|
|
| Cli_entries.Command_not_found ->
|
|
Format.asprintf "Unkonwn command, try `-help`.\n%!"
|
|
| Client_commands.Version_not_found ->
|
|
Format.asprintf "Unkonwn protocol version, try `list versions`.\n%!"
|
|
| Cli_entries.Bad_argument (idx, _n, v) ->
|
|
Format.asprintf "There's a problem with argument %d, %s.\n%!" idx v
|
|
| Cli_entries.Command_failed message ->
|
|
Format.asprintf "Command failed, %s.\n%!" message
|
|
| Failure msg ->
|
|
Format.asprintf "Fatal error: %s\n%!" msg
|
|
| exn ->
|
|
Format.asprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) in
|
|
let result =
|
|
result () in
|
|
let stderr =
|
|
List.assoc "stderr" result in
|
|
let stderr =
|
|
if stderr = ""
|
|
|| String.get stderr (String.length stderr - 1) = '\n' then
|
|
msg
|
|
else
|
|
stderr ^ "\n" ^ msg in
|
|
let result =
|
|
("stderr", stderr)::
|
|
List.filter (fun (n, _) -> n <> "stderr") result in
|
|
Lwt.return (Error result))
|
|
|
|
module ConnectionMap = Map.Make(Cohttp.Connection)
|
|
|
|
exception Invalid_method
|
|
exception Cannot_parse_body of string
|
|
|
|
let root =
|
|
let input, output =
|
|
let open Data_encoding in
|
|
(obj1 (req "command" string)),
|
|
(obj1 (req "outputs" (assoc string))) in
|
|
let root =
|
|
RPC.empty in
|
|
let root =
|
|
RPC.register0 root
|
|
(RPC.service ~input ~output RPC.Path.(root / "command"))
|
|
(fun command ->
|
|
let argv = Array.of_list (Utils.split ' ' command) in
|
|
eval_command argv >>= function
|
|
| Ok output | Error output ->
|
|
RPC.Answer.return output) in
|
|
let root =
|
|
RPC.register_dynamic_directory1 root
|
|
RPC.Path.(root / "block" /: Node_rpc_services.Blocks.blocks_arg)
|
|
(fun block ->
|
|
Client_node_rpcs.Blocks.protocol Client_commands.ignore_context block >>= fun version ->
|
|
let directory = Webclient_version.find_contextual_services version in
|
|
let directory = RPC.map (fun ((), block) -> block) directory in
|
|
Lwt.return directory) in
|
|
root
|
|
|
|
let find_static_file path =
|
|
let path = OCamlRes.Path.of_string path in
|
|
let index path = match path with
|
|
| ([], None) -> ([], Some ("index", Some "html"))
|
|
| oth -> oth in
|
|
match path with
|
|
| ("block" :: block :: path, file) ->
|
|
let path = index (path, file) in
|
|
(match Node_rpc_services.Blocks.parse_block block with
|
|
| Ok block ->
|
|
block_protocol Client_commands.ignore_context block >>= fun version ->
|
|
Lwt.return
|
|
(try
|
|
let root =
|
|
Webclient_version.find_contextual_static_files version in
|
|
Some (OCamlRes.Res.find path root)
|
|
with Not_found -> None)
|
|
| Error _ -> Lwt.return None)
|
|
| _ ->
|
|
Lwt.return
|
|
(try
|
|
Some (OCamlRes.Res.find (index path) Webclient_static.root)
|
|
with Not_found -> None)
|
|
|
|
let http_proxy mode =
|
|
let pre_hook path =
|
|
find_static_file path >>= function
|
|
| Some body ->
|
|
Lwt.return { RPC.Answer.code = 200 ; body = RPC.Answer.Single body }
|
|
| None ->
|
|
Lwt.return { RPC.Answer.code = 404 ; body = RPC.Answer.Empty } in
|
|
let post_hook _ =
|
|
(find_static_file "not_found.html" >>= function
|
|
| Some body ->
|
|
Lwt.return (RPC.Answer.Single body)
|
|
| None ->
|
|
Lwt.return (RPC.Answer.Empty)) >>= fun body ->
|
|
Lwt.return { RPC.Answer.code = 404 ; body } in
|
|
RPC_server.launch ~pre_hook ~post_hook mode root [] []
|
|
|
|
let web_port = Client_config.in_both_groups @@
|
|
new Config_file.int_cp [ "web" ; "port" ] 8080
|
|
"The TCP port to point the web browser to."
|
|
|
|
(* Where all the user friendliness starts *)
|
|
let () =
|
|
Pervasives.exit @@ Lwt_main.run
|
|
(Lwt.catch
|
|
(fun () ->
|
|
Client_config.parse_args
|
|
(Cli_entries.usage ~commands: [])
|
|
(fun () -> function
|
|
| `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg))
|
|
| `End -> `Res (fun () -> Lwt.return ()))
|
|
Sys.argv Client_commands.ignore_context>>= fun _no_command ->
|
|
Random.self_init () ;
|
|
Sodium.Random.stir () ;
|
|
(* TODO: add TLS? *)
|
|
http_proxy (`TCP (`Port web_port#get)) >>= fun _server ->
|
|
fst (Lwt.wait ()))
|
|
(function
|
|
| Arg.Help help ->
|
|
Format.eprintf "%s%!" help ;
|
|
Lwt.return 0
|
|
| Arg.Bad help ->
|
|
Format.eprintf "%s%!" help ;
|
|
Lwt.return 1
|
|
| Failure msg ->
|
|
Format.eprintf "Fatal error: %s\n%!" msg ;
|
|
Lwt.return 1
|
|
| exn ->
|
|
Format.eprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) ;
|
|
Lwt.return 1))
|