(**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) (* Dynamic Ledger Solutions, Inc. *) (* *) (* 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))