Everywhere: return_unit

This commit is contained in:
Raphaël Proust 2018-06-26 17:07:12 +08:00 committed by Grégoire Henry
parent 7fcd986b93
commit 103d5355f2
93 changed files with 413 additions and 406 deletions

View File

@ -123,7 +123,7 @@ let try_action addr port action =
| Ok conn -> | Ok conn ->
action conn >>=? fun () -> action conn >>=? fun () ->
P2p_connection.close conn >>= fun () -> P2p_connection.close conn >>= fun () ->
return () return_unit
let replicate n x = let replicate n x =
let rec replicate_acc acc n x = let rec replicate_acc acc n x =
@ -226,7 +226,7 @@ let long_chain n conn =
let prev_ref = ref genesis_block_hashed in let prev_ref = ref genesis_block_hashed in
let rec loop k = let rec loop k =
if k < 1 then if k < 1 then
return () return_unit
else else
let block = signed (block_forged ~prev:!prev_ref []) in let block = signed (block_forged ~prev:!prev_ref []) in
prev_ref := Block_hash.hash_bytes [block] ; prev_ref := Block_hash.hash_bytes [block] ;
@ -238,7 +238,7 @@ let lots_transactions amount fee n conn =
let signed_op = signed (tx_forged amount fee) in let signed_op = signed (tx_forged amount fee) in
let rec loop k = let rec loop k =
if k < 1 then if k < 1 then
return () return_unit
else else
send conn (Operation signed_op) >>=? fun () -> send conn (Operation signed_op) >>=? fun () ->
loop (k-1) in loop (k-1) in

View File

@ -27,7 +27,7 @@ let commands () =
(fun () (cctxt : #Client_context.full) -> (fun () (cctxt : #Client_context.full) ->
Shell_services.Protocol.list cctxt >>=? fun protos -> Shell_services.Protocol.list cctxt >>=? fun protos ->
Lwt_list.iter_s (fun ph -> cctxt#message "%a" Protocol_hash.pp ph) protos >>= fun () -> Lwt_list.iter_s (fun ph -> cctxt#message "%a" Protocol_hash.pp ph) protos >>= fun () ->
return () return_unit
); );
command ~group ~desc: "Inject a new protocol into the node." command ~group ~desc: "Inject a new protocol into the node."
@ -42,15 +42,15 @@ let commands () =
Shell_services.Injection.protocol cctxt proto >>= function Shell_services.Injection.protocol cctxt proto >>= function
| Ok hash -> | Ok hash ->
cctxt#message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> cctxt#message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () ->
return () return_unit
| Error err -> | Error err ->
cctxt#error "Error while injecting protocol from %s: %a" cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err >>= fun () -> dirname Error_monad.pp_print_error err >>= fun () ->
return ()) return_unit)
(fun exn -> (fun exn ->
cctxt#error "Error while injecting protocol from %s: %a" cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () -> dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () ->
return ()) return_unit)
); );
command ~group ~desc: "Dump a protocol from the node's record of protocol." command ~group ~desc: "Dump a protocol from the node's record of protocol."
@ -62,6 +62,6 @@ let commands () =
Shell_services.Protocol.contents cctxt ph >>=? fun proto -> Shell_services.Protocol.contents cctxt ph >>=? fun proto ->
Lwt_utils_unix.Protocol.write_dir (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>=? fun () -> Lwt_utils_unix.Protocol.write_dir (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>=? fun () ->
cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->
return () return_unit
) ; ) ;
] ]

View File

@ -106,7 +106,7 @@ let fill_in ?(show_optionals=true) input schema =
element [] (Json_schema.root schema) element [] (Json_schema.root schema)
let random_fill_in ?(show_optionals=true) schema = let random_fill_in ?(show_optionals=true) schema =
let display _ = Lwt.return () in let display _ = Lwt.return_unit in
let int min max _ _ = let int min max _ _ =
let max = Int64.of_int max let max = Int64.of_int max
and min = Int64.of_int min in and min = Int64.of_int min in
@ -286,8 +286,8 @@ let list url (cctxt : #Client_context.full) =
if !collected_args <> [] then begin if !collected_args <> [] then begin
cctxt#message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@." cctxt#message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg) !collected_args >>= fun () -> (Format.pp_print_list display_arg) !collected_args >>= fun () ->
return () return_unit
end else return () end else return_unit
let schema meth url (cctxt : #Client_context.full) = let schema meth url (cctxt : #Client_context.full) =
@ -299,21 +299,21 @@ let schema meth url (cctxt : #Client_context.full) =
| exception Not_found -> | exception Not_found ->
cctxt#message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return_unit
| { input = Some input ; output } -> | { input = Some input ; output } ->
let json = `O [ "input", Json_schema.to_json (fst input) ; let json = `O [ "input", Json_schema.to_json (fst input) ;
"output", Json_schema.to_json (fst output) ] in "output", Json_schema.to_json (fst output) ] in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return_unit
| { input = None ; output } -> | { input = None ; output } ->
let json = `O [ "output", Json_schema.to_json (fst output) ] in let json = `O [ "output", Json_schema.to_json (fst output) ] in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return_unit
end end
| _ -> | _ ->
cctxt#message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return_unit
let format binary meth url (cctxt : #Client_context.io_rpcs) = let format binary meth url (cctxt : #Client_context.io_rpcs) =
let args = String.split '/' url in let args = String.split '/' url in
@ -329,7 +329,7 @@ let format binary meth url (cctxt : #Client_context.io_rpcs) =
| exception Not_found -> | exception Not_found ->
cctxt#message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return_unit
| { input = Some input ; output } -> | { input = Some input ; output } ->
cctxt#message cctxt#message
"@[<v 0>\ "@[<v 0>\
@ -338,19 +338,19 @@ let format binary meth url (cctxt : #Client_context.io_rpcs) =
@]" @]"
pp input pp input
pp output >>= fun () -> pp output >>= fun () ->
return () return_unit
| { input = None ; output } -> | { input = None ; output } ->
cctxt#message cctxt#message
"@[<v 0>\ "@[<v 0>\
@[<v 2>Output format:@,%a@]@,\ @[<v 2>Output format:@,%a@]@,\
@]" @]"
pp output >>= fun () -> pp output >>= fun () ->
return () return_unit
end end
| _ -> | _ ->
cctxt#message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return_unit
let fill_in ?(show_optionals=true) schema = let fill_in ?(show_optionals=true) schema =
let open Json_schema in let open Json_schema in
@ -363,13 +363,13 @@ let display_answer (cctxt : #Client_context.full) = function
| `Ok json -> | `Ok json ->
cctxt#message "%a" cctxt#message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () -> Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return_unit
| `Not_found _ -> | `Not_found _ ->
cctxt#message "No service found at this URL\n%!" >>= fun () -> cctxt#message "No service found at this URL\n%!" >>= fun () ->
return () return_unit
| `Unauthorized _ | `Error _ | `Forbidden _ | `Conflict _ -> | `Unauthorized _ | `Error _ | `Forbidden _ | `Conflict _ ->
cctxt#message "Unexpected server answer\n%!" >>= fun () -> cctxt#message "Unexpected server answer\n%!" >>= fun () ->
return () return_unit
let call meth raw_url (cctxt : #Client_context.full) = let call meth raw_url (cctxt : #Client_context.full) =
let uri = Uri.of_string raw_url in let uri = Uri.of_string raw_url in
@ -381,7 +381,7 @@ let call meth raw_url (cctxt : #Client_context.full) =
cctxt#message cctxt#message
"No service found at this URL with this method \ "No service found at this URL with this method \
(but this is a valid prefix)\n%!" >>= fun () -> (but this is a valid prefix)\n%!" >>= fun () ->
return () return_unit
| { input = None } -> | { input = None } ->
cctxt#generic_json_call meth uri >>=? cctxt#generic_json_call meth uri >>=?
display_answer cctxt display_answer cctxt
@ -389,14 +389,14 @@ let call meth raw_url (cctxt : #Client_context.full) =
fill_in ~show_optionals:false (fst input) >>= function fill_in ~show_optionals:false (fst input) >>= function
| Error msg -> | Error msg ->
cctxt#error "%s" msg >>= fun () -> cctxt#error "%s" msg >>= fun () ->
return () return_unit
| Ok json -> | Ok json ->
cctxt#generic_json_call meth ~body:json uri >>=? cctxt#generic_json_call meth ~body:json uri >>=?
display_answer cctxt display_answer cctxt
end end
| _ -> | _ ->
cctxt#message "No service found at this URL\n%!" >>= fun () -> cctxt#message "No service found at this URL\n%!" >>= fun () ->
return () return_unit
let call_with_json meth raw_url json (cctxt: #Client_context.full) = let call_with_json meth raw_url json (cctxt: #Client_context.full) =
let uri = Uri.of_string raw_url in let uri = Uri.of_string raw_url in

View File

@ -19,7 +19,7 @@ let display_warning_banner ctxt =
\ Use your fundraiser keys @{<warning>AT YOUR OWN RISK@}.@,\ \ Use your fundraiser keys @{<warning>AT YOUR OWN RISK@}.@,\
All transactions happening on the Betanet @{<warning>are expected to be valid in the Mainnet@}.@,\ All transactions happening on the Betanet @{<warning>are expected to be valid in the Mainnet@}.@,\
\ In doubt, we recommend that you wait for the lunch of the Mainnet.@]@\n@." ; \ In doubt, we recommend that you wait for the lunch of the Mainnet.@]@\n@." ;
Lwt.return () in Lwt.return_unit in
Shell_services.P2p.versions ctxt >>= function Shell_services.P2p.versions ctxt >>= function
| Error _ -> default () | Error _ -> default ()
| Ok versions -> | Ok versions ->
@ -34,7 +34,7 @@ let display_warning_banner ctxt =
\ @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\ \ @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\ \ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
Zeronet is a testing network, with free tokens and frequent resets.@]@\n@." ; Zeronet is a testing network, with free tokens and frequent resets.@]@\n@." ;
Lwt.return () Lwt.return_unit
| "TEZOS" :: "ALPHANET" :: _date :: [] -> | "TEZOS" :: "ALPHANET" :: _date :: [] ->
Format.eprintf Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\ "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\
@ -45,7 +45,7 @@ let display_warning_banner ctxt =
\ @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\ \ @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\ \ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
\ Alphanet is a testing network, with free tokens.@]@\n@." ; \ Alphanet is a testing network, with free tokens.@]@\n@." ;
Lwt.return () Lwt.return_unit
| "TEZOS" :: "BETANET" :: _date :: [] -> | "TEZOS" :: "BETANET" :: _date :: [] ->
Format.eprintf Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\ "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\
@ -58,7 +58,7 @@ let display_warning_banner ctxt =
\ Use your fundraiser keys on this network @{<warning>AT YOUR OWN RISK@}.@,\ \ Use your fundraiser keys on this network @{<warning>AT YOUR OWN RISK@}.@,\
\ All transactions happening on the Betanet @{<warning>are expected to be valid in the Mainnet@}.@,\ \ All transactions happening on the Betanet @{<warning>are expected to be valid in the Mainnet@}.@,\
\ If in doubt, we recommend that you wait for the Mainnet lunch.@]@\n@." ; \ If in doubt, we recommend that you wait for the Mainnet lunch.@]@\n@." ;
Lwt.return () Lwt.return_unit
| "TEZOS" :: _date :: [] -> | "TEZOS" :: _date :: [] ->
Format.eprintf Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\ "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,\
@ -69,7 +69,7 @@ let display_warning_banner ctxt =
\ @{<warning>Tezos TEST SANDBOX@}.@,\ \ @{<warning>Tezos TEST SANDBOX@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\ \ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
You should not see this message if you are not a developer.@]@\n@." ; You should not see this message if you are not a developer.@]@\n@." ;
Lwt.return () Lwt.return_unit
| _ -> default () | _ -> default ()
let get_commands_for_version ctxt block protocol = let get_commands_for_version ctxt block protocol =

View File

@ -83,7 +83,7 @@ let precheck_block
~ancestor_timestamp:_ ~ancestor_timestamp:_
(raw_block: block_header) = (raw_block: block_header) =
Fitness.to_int64 raw_block.shell.fitness >>=? fun _ -> Fitness.to_int64 raw_block.shell.fitness >>=? fun _ ->
return () return_unit
let begin_application let begin_application
~predecessor_context:context ~predecessor_context:context

View File

@ -19,7 +19,7 @@ let show (args : Node_shared_arg.t) =
Node_shared_arg.read_and_patch_config_file args >>=? fun cfg -> Node_shared_arg.read_and_patch_config_file args >>=? fun cfg ->
Node_config_file.check cfg >>= fun () -> Node_config_file.check cfg >>= fun () ->
print_endline @@ Node_config_file.to_string cfg ; print_endline @@ Node_config_file.to_string cfg ;
return () return_unit
let reset (args : Node_shared_arg.t) = let reset (args : Node_shared_arg.t) =
if Sys.file_exists args.config_file then if Sys.file_exists args.config_file then

View File

@ -100,7 +100,7 @@ let check_data_dir_version data_dir =
fail_unless fail_unless
(String.equal data_version version) (String.equal data_version version)
(Invalid_data_dir_version (data_version, version)) >>=? fun () -> (Invalid_data_dir_version (data_version, version)) >>=? fun () ->
return () return_unit
let ensure_data_dir data_dir = let ensure_data_dir data_dir =
let write_version () = let write_version () =

View File

@ -16,7 +16,7 @@ let identity_file data_dir = data_dir // Node_data_version.default_identity_file
let show { Node_config_file.data_dir } = let show { Node_config_file.data_dir } =
Node_identity_file.read (identity_file data_dir) >>=? fun id -> Node_identity_file.read (identity_file data_dir) >>=? fun id ->
Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ; Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
return () return_unit
let generate { Node_config_file.data_dir ; p2p } = let generate { Node_config_file.data_dir ; p2p } =
let identity_file = identity_file data_dir in let identity_file = identity_file data_dir in
@ -31,7 +31,7 @@ let generate { Node_config_file.data_dir ; p2p } =
Format.eprintf Format.eprintf
"Stored the new identity (%a) into '%s'.@." "Stored the new identity (%a) into '%s'.@."
P2p_peer.Id.pp id.peer_id identity_file ; P2p_peer.Id.pp id.peer_id identity_file ;
return () return_unit
let check { Node_config_file.data_dir ; p2p = { expected_pow } } = let check { Node_config_file.data_dir ; p2p = { expected_pow } } =
Node_identity_file.read Node_identity_file.read
@ -39,7 +39,7 @@ let check { Node_config_file.data_dir ; p2p = { expected_pow } } =
Format.printf Format.printf
"Peer_id: %a. Proof of work is higher than %.2f.@." "Peer_id: %a. Proof of work is higher than %.2f.@."
P2p_peer.Id.pp id.peer_id expected_pow ; P2p_peer.Id.pp id.peer_id expected_pow ;
return () return_unit
(** Main *) (** Main *)

View File

@ -261,7 +261,7 @@ let run ?verbosity ?sandbox ?checkpoint (config : Node_config_file.t) =
Lwt_utils.may ~f:RPC_server.shutdown rpc >>= fun () -> Lwt_utils.may ~f:RPC_server.shutdown rpc >>= fun () ->
lwt_log_notice "BYE (%d)" x >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () ->
Logging_unix.close () >>= fun () -> Logging_unix.close () >>= fun () ->
return () return_unit
let process sandbox verbosity checkpoint args = let process sandbox verbosity checkpoint args =
let verbosity = let verbosity =
@ -279,8 +279,8 @@ let process sandbox verbosity checkpoint args =
| Some _ -> | Some _ ->
if config.data_dir = Node_config_file.default_data_dir if config.data_dir = Node_config_file.default_data_dir
then failwith "Cannot use default data directory while in sandbox mode" then failwith "Cannot use default data directory while in sandbox mode"
else return () else return_unit
| None -> return () | None -> return_unit
end >>=? fun () -> end >>=? fun () ->
begin begin
match checkpoint with match checkpoint with

View File

@ -19,12 +19,12 @@ module Authorized_key =
let check_magic_byte magic_bytes data = let check_magic_byte magic_bytes data =
match magic_bytes with match magic_bytes with
| None -> return () | None -> return_unit
| Some magic_bytes -> | Some magic_bytes ->
let byte = MBytes.get_uint8 data 0 in let byte = MBytes.get_uint8 data 0 in
if MBytes.length data > 1 if MBytes.length data > 1
&& (List.mem byte magic_bytes) then && (List.mem byte magic_bytes) then
return () return_unit
else else
failwith "magic byte 0x%02X not allowed" byte failwith "magic byte 0x%02X not allowed" byte
@ -38,7 +38,7 @@ let sign
(MBytes.get_uint8 data 0) >>= fun () -> (MBytes.get_uint8 data 0) >>= fun () ->
check_magic_byte magic_bytes data >>=? fun () -> check_magic_byte magic_bytes data >>=? fun () ->
begin match require_auth, signature with begin match require_auth, signature with
| false, _ -> return () | false, _ -> return_unit
| true, None -> failwith "missing authentication signature field" | true, None -> failwith "missing authentication signature field"
| true, Some signature -> | true, Some signature ->
let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in
@ -47,7 +47,7 @@ let sign
(fun acc (_, key) -> acc || Signature.check key signature to_sign) (fun acc (_, key) -> acc || Signature.check key signature to_sign)
false keys false keys
then then
return () return_unit
else else
failwith "invalid authentication signature" failwith "invalid authentication signature"
end >>=? fun () -> end >>=? fun () ->

View File

@ -282,7 +282,7 @@ let main () =
~global_options:(global_options ()) ~global_options:(global_options ())
commands cctxt >>=? fun completions -> commands cctxt >>=? fun completions ->
List.iter print_endline completions ; List.iter print_endline completions ;
return () return_unit
| None -> | None ->
Clic.dispatch commands cctxt remaining Clic.dispatch commands cctxt remaining
end end

View File

@ -22,13 +22,13 @@ let run (cctxt : #Client_context.wallet) path ?magic_bytes ~require_auth =
Handler.sign cctxt req ?magic_bytes ~require_auth >>= fun res -> Handler.sign cctxt req ?magic_bytes ~require_auth >>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res >>= fun _ -> Lwt_utils_unix.Socket.send fd encoding res >>= fun _ ->
Lwt_unix.close fd >>= fun () -> Lwt_unix.close fd >>= fun () ->
return () return_unit
| Public_key pkh -> | Public_key pkh ->
let encoding = result_encoding Public_key.Response.encoding in let encoding = result_encoding Public_key.Response.encoding in
Handler.public_key cctxt pkh >>= fun res -> Handler.public_key cctxt pkh >>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res >>= fun _ -> Lwt_utils_unix.Socket.send fd encoding res >>= fun _ ->
Lwt_unix.close fd >>= fun () -> Lwt_unix.close fd >>= fun () ->
return () return_unit
| Authorized_keys -> | Authorized_keys ->
let encoding = result_encoding Authorized_keys.Response.encoding in let encoding = result_encoding Authorized_keys.Response.encoding in
begin if require_auth then begin if require_auth then
@ -39,7 +39,7 @@ let run (cctxt : #Client_context.wallet) path ?magic_bytes ~require_auth =
end >>= fun res -> end >>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res >>= fun _ -> Lwt_utils_unix.Socket.send fd encoding res >>= fun _ ->
Lwt_unix.close fd >>= fun () -> Lwt_unix.close fd >>= fun () ->
return () return_unit
end ; end ;
loop () loop ()
in in

View File

@ -607,7 +607,7 @@ let rec parse_args :
type a ctx. ?command:_ command -> (a, ctx) args -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t = type a ctx. ?command:_ command -> (a, ctx) args -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t =
fun ?command spec args_dict ctx -> fun ?command spec args_dict ctx ->
match spec with match spec with
| NoArgs -> return () | NoArgs -> return_unit
| AddArg (arg, rest) -> | AddArg (arg, rest) ->
parse_arg ?command arg args_dict ctx >>=? fun arg -> parse_arg ?command arg args_dict ctx >>=? fun arg ->
parse_args ?command rest args_dict ctx >>|? fun rest -> parse_args ?command rest args_dict ctx >>|? fun rest ->
@ -637,7 +637,7 @@ type error += Help : 'a command option -> error
let check_help_flag ?command = function let check_help_flag ?command = function
| ("-help" | "--help") :: _ -> fail (Help command) | ("-help" | "--help") :: _ -> fail (Help command)
| _ -> return () | _ -> return_unit
let add_occurrence long value acc = let add_occurrence long value acc =
try TzString.Map.add long (TzString.Map.find long acc) acc try TzString.Map.add long (TzString.Map.find long acc) acc
@ -1196,7 +1196,7 @@ let add_manual ~executable_name ~global_options format ppf commands =
let commands = List.map (fun c -> Ex c) commands in let commands = List.map (fun c -> Ex c) commands in
usage_internal ppf ~executable_name ~global_options ~highlights:keywords commands ; usage_internal ppf ~executable_name ~global_options ~highlights:keywords commands ;
restore_formatter ppf state ; restore_formatter ppf state ;
return ()) ]) in return_unit) ]) in
Lazy.force with_manual Lazy.force with_manual
let pp_cli_errors ppf ~executable_name ~global_options ~default errs = let pp_cli_errors ppf ~executable_name ~global_options ~default errs =

View File

@ -138,12 +138,12 @@ module Alias = functor (Entity : Entity) -> struct
load wallet >>=? fun list -> load wallet >>=? fun list ->
begin begin
if force then if force then
return () return_unit
else else
iter_s (fun (n, v) -> iter_s (fun (n, v) ->
if n = name && v = value then begin if n = name && v = value then begin
keep := true ; keep := true ;
return () return_unit
end else if n = name && v <> value then begin end else if n = name && v <> value then begin
failwith failwith
"another %s is already aliased as %s, \ "another %s is already aliased as %s, \
@ -155,14 +155,14 @@ module Alias = functor (Entity : Entity) -> struct
use --force to insert duplicate" use --force to insert duplicate"
Entity.name n Entity.name n
end else begin end else begin
return () return_unit
end) end)
list list
end >>=? fun () -> end >>=? fun () ->
let list = List.filter (fun (n, _) -> n <> name) list in let list = List.filter (fun (n, _) -> n <> name) list in
let list = (name, value) :: list in let list = (name, value) :: list in
if !keep then if !keep then
return () return_unit
else else
wallet#write Entity.name list wallet_encoding wallet#write Entity.name list wallet_encoding
@ -199,7 +199,7 @@ module Alias = functor (Entity : Entity) -> struct
let of_fresh (wallet : #wallet) force (Fresh s) = let of_fresh (wallet : #wallet) force (Fresh s) =
load wallet >>=? fun list -> load wallet >>=? fun list ->
begin if force then begin if force then
return () return_unit
else else
iter_s iter_s
(fun (n, v) -> (fun (n, v) ->
@ -212,7 +212,7 @@ module Alias = functor (Entity : Entity) -> struct
Entity.name n Entity.name n
value value
else else
return ()) return_unit)
list list
end >>=? fun () -> end >>=? fun () ->
return s return s

View File

@ -14,9 +14,9 @@ let wait_for_bootstrapped (ctxt : #Client_context.full) =
if not !display then if not !display then
ctxt#answer "Waiting for the node to be bootstrapped before injection..." >>= fun () -> ctxt#answer "Waiting for the node to be bootstrapped before injection..." >>= fun () ->
display := true ; display := true ;
Lwt.return () Lwt.return_unit
else else
Lwt.return () Lwt.return_unit
end ; end ;
Monitor_services.bootstrapped ctxt >>=? fun (stream, _stop) -> Monitor_services.bootstrapped ctxt >>=? fun (stream, _stop) ->
Lwt_stream.iter_s Lwt_stream.iter_s
@ -26,10 +26,10 @@ let wait_for_bootstrapped (ctxt : #Client_context.full) =
Block_hash.pp_short hash Block_hash.pp_short hash
Time.pp_hum time Time.pp_hum time
Time.pp_hum (Time.now ()) Time.pp_hum (Time.now ())
else Lwt.return ()) stream >>= fun () -> else Lwt.return_unit) stream >>= fun () ->
display := true ; display := true ;
ctxt#answer "Node is bootstrapped, ready for injecting operations." >>= fun () -> ctxt#answer "Node is bootstrapped, ready for injecting operations." >>= fun () ->
return () return_unit
let wait_for_operation_inclusion let wait_for_operation_inclusion
(ctxt : #Client_context.full) (ctxt : #Client_context.full)

View File

@ -210,7 +210,7 @@ let register_key cctxt ?(force=false) (public_key_hash, pk_uri, sk_uri) ?public_
Public_key.add ~force cctxt name (pk_uri, public_key) >>=? fun () -> Public_key.add ~force cctxt name (pk_uri, public_key) >>=? fun () ->
Secret_key.add ~force cctxt name sk_uri >>=? fun () -> Secret_key.add ~force cctxt name sk_uri >>=? fun () ->
Public_key_hash.add ~force cctxt name public_key_hash >>=? fun () -> Public_key_hash.add ~force cctxt name public_key_hash >>=? fun () ->
return () return_unit
let raw_get_key (cctxt : #Client_context.wallet) pkh = let raw_get_key (cctxt : #Client_context.wallet) pkh =
begin begin

View File

@ -91,10 +91,10 @@ class unix_logger ~base_dir =
let log channel msg = match channel with let log channel msg = match channel with
| "stdout" -> | "stdout" ->
print_endline msg ; print_endline msg ;
Lwt.return () Lwt.return_unit
| "stderr" -> | "stderr" ->
prerr_endline msg ; prerr_endline msg ;
Lwt.return () Lwt.return_unit
| log -> | log ->
let (//) = Filename.concat in let (//) = Filename.concat in
Lwt_utils_unix.create_dir (base_dir // "logs" // log) >>= fun () -> Lwt_utils_unix.create_dir (base_dir // "logs" // log) >>= fun () ->

View File

@ -22,7 +22,7 @@ let builtin_commands =
Lwt_list.iter_s Lwt_list.iter_s
(fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver) (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () -> (Client_commands.get_versions ()) >>= fun () ->
return ()) ; return_unit) ;
] ]
(* Duplicated from the node, here for now since the client still (* Duplicated from the node, here for now since the client still
@ -156,7 +156,7 @@ let main select_commands =
~script ~cur_arg ~prev_arg ~args:original_args ~global_options ~script ~cur_arg ~prev_arg ~args:original_args ~global_options
commands client_config >>=? fun completions -> commands client_config >>=? fun completions ->
List.iter print_endline completions ; List.iter print_endline completions ;
return () return_unit
| None -> | None ->
Clic.dispatch commands client_config remaining Clic.dispatch commands client_config remaining
end end

View File

@ -24,6 +24,6 @@ let commands () =
cctxt#message cctxt#message
"Block %a no longer marked invalid." "Block %a no longer marked invalid."
Block_hash.pp block >>= fun () -> Block_hash.pp block >>= fun () ->
return ()) return_unit)
blocks) ; blocks) ;
] ]

View File

@ -33,7 +33,7 @@ let commands () = Clic.[
| _ :: _ :: _ when unique -> Pervasives.exit 3 | _ :: _ :: _ when unique -> Pervasives.exit 3
| completions -> | completions ->
List.iter print_endline completions ; List.iter print_endline completions ;
return ()) ; return_unit) ;
command command
~desc: "Wait for the node to be bootstrapped." ~desc: "Wait for the node to be bootstrapped."
no_options no_options
@ -48,6 +48,6 @@ let commands () = Clic.[
Time.pp_hum time Time.pp_hum time
Time.pp_hum (Time.now ())) stream >>= fun () -> Time.pp_hum (Time.now ())) stream >>= fun () ->
cctxt#answer "Bootstrapped." >>= fun () -> cctxt#answer "Bootstrapped." >>= fun () ->
return () return_unit
) )
] ]

View File

@ -109,12 +109,12 @@ let gen_keys_containing
else begin if attempts mod 25_000 = 0 else begin if attempts mod 25_000 = 0
then then
cctxt#message "Tried %d keys without finding a match" attempts cctxt#message "Tried %d keys without finding a match" attempts
else Lwt.return () end >>= fun () -> else Lwt.return_unit end >>= fun () ->
loop (attempts + 1) in loop (attempts + 1) in
loop 1 >>=? fun key_hash -> loop 1 >>=? fun key_hash ->
cctxt#message cctxt#message
"Generated '%s' under the name '%s'." key_hash name >>= fun () -> "Generated '%s' under the name '%s'." key_hash name >>= fun () ->
return () return_unit
end end
let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) = let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) =
@ -234,7 +234,7 @@ let commands () : Client_context.io_wallet Clic.command list =
Client_keys.neuterize sk_uri >>=? fun pk_uri -> Client_keys.neuterize sk_uri >>=? fun pk_uri ->
begin begin
Public_key.find_opt cctxt name >>=? function Public_key.find_opt cctxt name >>=? function
| None -> return () | None -> return_unit
| Some (pk_uri_found, _) -> | Some (pk_uri_found, _) ->
fail_unless (pk_uri = pk_uri_found || force) fail_unless (pk_uri = pk_uri_found || force)
(failure (failure
@ -260,7 +260,7 @@ let commands () : Client_context.io_wallet Clic.command list =
Client_keys.neuterize sk_uri >>=? fun pk_uri -> Client_keys.neuterize sk_uri >>=? fun pk_uri ->
begin begin
Public_key.find_opt cctxt name >>=? function Public_key.find_opt cctxt name >>=? function
| None -> return () | None -> return_unit
| Some (pk_uri_found, _) -> | Some (pk_uri_found, _) ->
fail_unless (pk_uri = pk_uri_found || force) fail_unless (pk_uri = pk_uri_found || force)
(failure (failure
@ -313,7 +313,7 @@ let commands () : Client_context.io_wallet Clic.command list =
cctxt#message "%s: %s (%s sk known)" name v scheme cctxt#message "%s: %s (%s sk known)" name v scheme
| Some _, _ -> | Some _, _ ->
cctxt#message "%s: %s (pk known)" name v cctxt#message "%s: %s (pk known)" name v
end >>= fun () -> return () end >>= fun () -> return_unit
end l) ; end l) ;
command ~group ~desc: "Show the keys associated with an implicit account." command ~group ~desc: "Show the keys associated with an implicit account."
@ -326,24 +326,24 @@ let commands () : Client_context.io_wallet Clic.command list =
match key_info with match key_info with
| None -> | None ->
cctxt#message "No keys found for address" >>= fun () -> cctxt#message "No keys found for address" >>= fun () ->
return () return_unit
| Some (pkh, pk, skloc) -> | Some (pkh, pk, skloc) ->
cctxt#message "Hash: %a" cctxt#message "Hash: %a"
Signature.Public_key_hash.pp pkh >>= fun () -> Signature.Public_key_hash.pp pkh >>= fun () ->
match pk with match pk with
| None -> return () | None -> return_unit
| Some pk -> | Some pk ->
cctxt#message "Public Key: %a" cctxt#message "Public Key: %a"
Signature.Public_key.pp pk >>= fun () -> Signature.Public_key.pp pk >>= fun () ->
if show_private then if show_private then
match skloc with match skloc with
| None -> return () | None -> return_unit
| Some skloc -> | Some skloc ->
Secret_key.to_source skloc >>=? fun skloc -> Secret_key.to_source skloc >>=? fun skloc ->
cctxt#message "Secret Key: %s" skloc >>= fun () -> cctxt#message "Secret Key: %s" skloc >>= fun () ->
return () return_unit
else else
return ()) ; return_unit) ;
command ~group ~desc: "Forget one address." command ~group ~desc: "Forget one address."
(args1 (Clic.switch (args1 (Clic.switch

View File

@ -84,7 +84,7 @@ let commands () =
P2p_point.Id.pp p P2p_point.Id.pp p
(if pi.trusted then "" else " ") (if pi.trusted then "" else " ")
end points >>= fun () -> end points >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Connect to a new point." command ~group ~desc: "Connect to a new point."
@ -133,7 +133,7 @@ let commands () =
cctxt#message cctxt#message
"The given ip address is %s" "The given ip address is %s"
(if banned then "banned" else "not banned") >>= fun () -> (if banned then "banned" else "not banned") >>= fun () ->
return () return_unit
) ; ) ;
command ~group ~desc: "Remove a peer ID from the blacklist and whitelist." command ~group ~desc: "Remove a peer ID from the blacklist and whitelist."
@ -173,7 +173,7 @@ let commands () =
cctxt#message cctxt#message
"The given peer ID is %s" "The given peer ID is %s"
(if banned then "banned" else "not banned") >>= fun () -> (if banned then "banned" else "not banned") >>= fun () ->
return () return_unit
) ; ) ;
command ~group ~desc: "Clear all ACLs." command ~group ~desc: "Clear all ACLs."

View File

@ -49,7 +49,7 @@ let commands () =
Format.fprintf ppf "@[<v>%a@]@." Format.fprintf ppf "@[<v>%a@]@."
(Format.pp_print_list Block_hash.pp) (Format.pp_print_list Block_hash.pp)
(List.concat heads) ; (List.concat heads) ;
return ()) ; return_unit) ;
command ~group ~desc: "The blocks that have been marked invalid by the node." command ~group ~desc: "The blocks that have been marked invalid by the node."
(args1 output_arg) (args1 output_arg)
(fixed [ "list" ; "rejected" ; "blocks" ]) (fixed [ "list" ; "rejected" ; "blocks" ])
@ -57,10 +57,10 @@ let commands () =
Shell_services.Invalid_blocks.list cctxt () >>=? function Shell_services.Invalid_blocks.list cctxt () >>=? function
| [] -> | [] ->
Format.fprintf ppf "No invalid blocks." ; Format.fprintf ppf "No invalid blocks." ;
return () return_unit
| _ :: _ as invalid -> | _ :: _ as invalid ->
Format.fprintf ppf "@[<v>%a@]@." Format.fprintf ppf "@[<v>%a@]@."
(Format.pp_print_list print_invalid_blocks) (Format.pp_print_list print_invalid_blocks)
invalid ; invalid ;
return ()) ; return_unit) ;
] ]

View File

@ -317,6 +317,8 @@ module Make(Prefix : sig val id : string end) = struct
let return v = Lwt.return (Ok v) let return v = Lwt.return (Ok v)
let return_unit = Lwt.return (Ok ())
let error s = Error [ s ] let error s = Error [ s ]
let ok v = Ok v let ok v = Ok v
@ -462,14 +464,14 @@ module Make(Prefix : sig val id : string end) = struct
let rec iter_s f l = let rec iter_s f l =
match l with match l with
| [] -> return () | [] -> return_unit
| h :: t -> | h :: t ->
f h >>=? fun () -> f h >>=? fun () ->
iter_s f t iter_s f t
let rec iter_p f l = let rec iter_p f l =
match l with match l with
| [] -> return () | [] -> return_unit
| x :: l -> | x :: l ->
let tx = f x and tl = iter_p f l in let tx = f x and tl = iter_p f l in
tx >>= fun tx_res -> tx >>= fun tx_res ->
@ -482,7 +484,7 @@ module Make(Prefix : sig val id : string end) = struct
let rec iter2_p f l1 l2 = let rec iter2_p f l1 l2 =
match l1, l2 with match l1, l2 with
| [], [] -> return () | [], [] -> return_unit
| [], _ | _, [] -> invalid_arg "Error_monad.iter2_p" | [], _ | _, [] -> invalid_arg "Error_monad.iter2_p"
| x1 :: l1 , x2 :: l2 -> | x1 :: l1 , x2 :: l2 ->
let tx = f x1 x2 and tl = iter2_p f l1 l2 in let tx = f x1 x2 and tl = iter2_p f l1 l2 in
@ -497,7 +499,7 @@ module Make(Prefix : sig val id : string end) = struct
let iteri2_p f l1 l2 = let iteri2_p f l1 l2 =
let rec iteri2_p i f l1 l2 = let rec iteri2_p i f l1 l2 =
match l1, l2 with match l1, l2 with
| [], [] -> return () | [], [] -> return_unit
| [], _ | _, [] -> invalid_arg "Error_monad.iteri2_p" | [], _ | _, [] -> invalid_arg "Error_monad.iteri2_p"
| x1 :: l1 , x2 :: l2 -> | x1 :: l1 , x2 :: l2 ->
let tx = f i x1 x2 and tl = iteri2_p (i+1) f l1 l2 in let tx = f i x1 x2 and tl = iteri2_p (i+1) f l1 l2 in
@ -526,7 +528,7 @@ module Make(Prefix : sig val id : string end) = struct
f h acc f h acc
let rec join = function let rec join = function
| [] -> return () | [] -> return_unit
| t :: ts -> | t :: ts ->
t >>= function t >>= function
| Error _ as err -> | Error _ as err ->
@ -546,16 +548,16 @@ module Make(Prefix : sig val id : string end) = struct
| ok -> Lwt.return ok | ok -> Lwt.return ok
let fail_unless cond exn = let fail_unless cond exn =
if cond then return () else fail exn if cond then return_unit else fail exn
let fail_when cond exn = let fail_when cond exn =
if cond then fail exn else return () if cond then fail exn else return_unit
let unless cond f = let unless cond f =
if cond then return () else f () if cond then return_unit else f ()
let _when cond f = let _when cond f =
if cond then f () else return () if cond then f () else return_unit
let pp_print_error ppf errors = let pp_print_error ppf errors =
match errors with match errors with
@ -599,7 +601,7 @@ module Make(Prefix : sig val id : string end) = struct
let _assert b loc fmt = let _assert b loc fmt =
if b then if b then
Format.ikfprintf (fun _ -> return ()) Format.str_formatter fmt Format.ikfprintf (fun _ -> return_unit) Format.str_formatter fmt
else else
Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt

View File

@ -80,6 +80,9 @@ module type S = sig
(** Sucessful return *) (** Sucessful return *)
val return : 'a -> 'a tzresult Lwt.t val return : 'a -> 'a tzresult Lwt.t
(** Sucessful return of [()] *)
val return_unit : unit tzresult Lwt.t
(** Erroneous result *) (** Erroneous result *)
val error : error -> 'a tzresult val error : error -> 'a tzresult

View File

@ -261,7 +261,7 @@ module Real = struct
lwt_debug "message sent to %a" lwt_debug "message sent to %a"
P2p_peer.Id.pp P2p_peer.Id.pp
(P2p_pool.Connection.info conn).peer_id >>= fun () -> (P2p_pool.Connection.info conn).peer_id >>= fun () ->
return () return_unit
| Error err -> | Error err ->
lwt_debug "error sending message from %a: %a" lwt_debug "error sending message from %a: %a"
P2p_peer.Id.pp P2p_peer.Id.pp
@ -366,13 +366,13 @@ type ('msg, 'peer_meta, 'conn_meta) net = ('msg, 'peer_meta, 'conn_meta) t
let check_limits = let check_limits =
let fail_1 v orig = let fail_1 v orig =
if not (v <= 0.) then return () if not (v <= 0.) then return_unit
else else
Error_monad.failwith "value of option %S cannot be negative or null@." Error_monad.failwith "value of option %S cannot be negative or null@."
orig orig
in in
let fail_2 v orig = let fail_2 v orig =
if not (v < 0) then return () if not (v < 0) then return_unit
else else
Error_monad.failwith "value of option %S cannot be negative@." orig Error_monad.failwith "value of option %S cannot be negative@." orig
in in
@ -397,10 +397,10 @@ let check_limits =
"swap-linger" >>=? fun () -> "swap-linger" >>=? fun () ->
begin begin
match c.binary_chunks_size with match c.binary_chunks_size with
| None -> return () | None -> return_unit
| Some size -> P2p_socket.check_binary_chunks_size size | Some size -> P2p_socket.check_binary_chunks_size size
end >>=? fun () -> end >>=? fun () ->
return () return_unit
let create ~config ~limits peer_cfg conn_cfg msg_cfg = let create ~config ~limits peer_cfg conn_cfg msg_cfg =
check_limits limits >>=? fun () -> check_limits limits >>=? fun () ->
@ -586,7 +586,7 @@ let build_rpc_directory net =
| None -> failwith "The P2P layer is disabled." | None -> failwith "The P2P layer is disabled."
| Some pool -> | Some pool ->
P2p_pool.connect ~timeout:q#timeout pool point >>=? fun _conn -> P2p_pool.connect ~timeout:q#timeout pool point >>=? fun _conn ->
return () return_unit
end in end in
(* Network : Connection *) (* Network : Connection *)
@ -821,10 +821,10 @@ let build_rpc_directory net =
RPC_directory.register dir P2p_services.ACL.S.clear RPC_directory.register dir P2p_services.ACL.S.clear
begin fun () () () -> begin fun () () () ->
match net.pool with match net.pool with
| None -> return () | None -> return_unit
| Some pool -> | Some pool ->
P2p_pool.acl_clear pool ; P2p_pool.acl_clear pool ;
return () return_unit
end in end in
dir dir

View File

@ -139,14 +139,14 @@ module Scheduler(IO : IO) = struct
IO.push conn.out_param msg >>= function IO.push conn.out_param msg >>= function
| Ok () | Ok ()
| Error [ Canceled ] -> | Error [ Canceled ] ->
return () return_unit
| Error ([P2p_errors.Connection_closed | | Error ([P2p_errors.Connection_closed |
Exn (Unix.Unix_error (EBADF, _, _) | Exn (Unix.Unix_error (EBADF, _, _) |
Lwt_pipe.Closed)] as err) -> Lwt_pipe.Closed)] as err) ->
lwt_debug "Connection closed (push: %d, %s)" lwt_debug "Connection closed (push: %d, %s)"
conn.id IO.name >>= fun () -> conn.id IO.name >>= fun () ->
cancel conn err >>= fun () -> cancel conn err >>= fun () ->
return () return_unit
| Error err -> | Error err ->
lwt_log_error lwt_log_error
"@[Unexpected error in connection (push: %d, %s):@ %a@]" "@[Unexpected error in connection (push: %d, %s):@ %a@]"
@ -187,7 +187,7 @@ module Scheduler(IO : IO) = struct
canceler ; canceler ;
in_param ; out_param ; in_param ; out_param ;
current_pop = Lwt.fail Not_found (* dummy *) ; current_pop = Lwt.fail Not_found (* dummy *) ;
current_push = return () ; current_push = return_unit ;
counter = Moving_average.create ~init:0 ~alpha ; counter = Moving_average.create ~init:0 ~alpha ;
quota = 0 ; last_quota = 0 ; quota = 0 ; last_quota = 0 ;
} in } in
@ -447,7 +447,7 @@ let read_full conn ?pos ?len buf =
assert (len <= maxlen - pos) ; assert (len <= maxlen - pos) ;
let rec loop pos len = let rec loop pos len =
if len = 0 then if len = 0 then
return () return_unit
else else
read conn ~pos ~len buf >>=? fun read_len -> read conn ~pos ~len buf >>=? fun read_len ->
loop (pos + read_len) (len - read_len) in loop (pos + read_len) (len - read_len) in

View File

@ -124,7 +124,7 @@ let rec maintain st =
(* end of maintenance when enough users have been reached *) (* end of maintenance when enough users have been reached *)
Lwt_condition.broadcast st.just_maintained () ; Lwt_condition.broadcast st.just_maintained () ;
lwt_debug "Maintenance step ended" >>= fun () -> lwt_debug "Maintenance step ended" >>= fun () ->
return () return_unit
end end
and too_few_connections st n_connected = and too_few_connections st n_connected =
@ -175,7 +175,7 @@ let rec worker_loop st =
P2p_pool.Pool_event.wait_too_few_connections pool ; (* limits *) P2p_pool.Pool_event.wait_too_few_connections pool ; (* limits *)
P2p_pool.Pool_event.wait_too_many_connections pool P2p_pool.Pool_event.wait_too_many_connections pool
] >>= fun () -> ] >>= fun () ->
return () return_unit
end >>=? fun () -> end >>=? fun () ->
let n_connected = P2p_pool.active_connections pool in let n_connected = P2p_pool.active_connections pool in
if n_connected < st.bounds.min_threshold if n_connected < st.bounds.min_threshold
@ -183,7 +183,7 @@ let rec worker_loop st =
maintain st maintain st
else begin else begin
P2p_pool.send_swap_request pool ; P2p_pool.send_swap_request pool ;
return () return_unit
end end
end >>= function end >>= function
| Ok () -> worker_loop st | Ok () -> worker_loop st

View File

@ -647,13 +647,13 @@ let config { config } = config
let fail_unless_disconnected_point point_info = let fail_unless_disconnected_point point_info =
match P2p_point_state.get point_info with match P2p_point_state.get point_info with
| Disconnected -> return () | Disconnected -> return_unit
| Requested _ | Accepted _ -> fail P2p_errors.Pending_connection | Requested _ | Accepted _ -> fail P2p_errors.Pending_connection
| Running _ -> fail P2p_errors.Connected | Running _ -> fail P2p_errors.Connected
let fail_unless_disconnected_peer_id peer_info = let fail_unless_disconnected_peer_id peer_info =
match P2p_peer_state.get peer_info with match P2p_peer_state.get peer_info with
| Disconnected -> return () | Disconnected -> return_unit
| Accepted _ -> fail P2p_errors.Pending_connection | Accepted _ -> fail P2p_errors.Pending_connection
| Running _ -> fail P2p_errors.Connected | Running _ -> fail P2p_errors.Connected
@ -702,7 +702,7 @@ let rec connect ?timeout pool point =
protect ~canceler begin fun () -> protect ~canceler begin fun () ->
log pool (Outgoing_connection point) ; log pool (Outgoing_connection point) ;
Lwt_unix.connect fd uaddr >>= fun () -> Lwt_unix.connect fd uaddr >>= fun () ->
return () return_unit
end ~on_error: begin fun err -> end ~on_error: begin fun err ->
lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point >>= fun () -> lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point >>= fun () ->
P2p_point_state.set_disconnected point_info ; P2p_point_state.set_disconnected point_info ;

View File

@ -403,7 +403,7 @@ module Writer = struct
let send_message st buf = let send_message st buf =
let rec loop = function let rec loop = function
| [] -> return () | [] -> return_unit
| buf :: l -> | buf :: l ->
protect ~canceler:st.canceler begin fun () -> protect ~canceler:st.canceler begin fun () ->
Crypto.write_chunk st.conn.fd st.conn.cryptobox_data buf Crypto.write_chunk st.conn.fd st.conn.cryptobox_data buf

View File

@ -25,7 +25,7 @@ let test_empty _ =
List.iter (fun (_peer,addr) -> List.iter (fun (_peer,addr) ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr empty addr) assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr empty addr)
) peers ; ) peers ;
Lwt.return () Lwt.return_unit
;; ;;
let test_ban _ = let test_ban _ =
@ -34,7 +34,7 @@ let test_ban _ =
List.iter (fun (_,addr) -> List.iter (fun (_,addr) ->
assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr) assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr)
) peers ; ) peers ;
Lwt.return () Lwt.return_unit
;; ;;
let test_gc _ = let test_gc _ =
@ -48,7 +48,7 @@ let test_gc _ =
List.iter (fun (_peer,addr) -> List.iter (fun (_peer,addr) ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr set addr) assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr set addr)
) peers ; ) peers ;
Lwt.return () Lwt.return_unit
let () = let () =
let wrap (n, f) = let wrap (n, f) =

View File

@ -72,7 +72,7 @@ let receive conn =
P2p_io_scheduler.read conn buf >>= function P2p_io_scheduler.read conn buf >>= function
| Ok _ -> loop () | Ok _ -> loop ()
| Error [P2p_errors.Connection_closed] -> | Error [P2p_errors.Connection_closed] ->
Lwt.return () Lwt.return_unit
| Error err -> Lwt.fail (Error err) | Error err -> Lwt.fail (Error err)
in in
loop () loop ()
@ -100,7 +100,7 @@ let server
Lwt.join (List.map receive conns) >>= fun () -> Lwt.join (List.map receive conns) >>= fun () ->
iter_p P2p_io_scheduler.close conns >>=? fun () -> iter_p P2p_io_scheduler.close conns >>=? fun () ->
log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ; log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
return () return_unit
let max_size ?max_upload_speed () = let max_size ?max_upload_speed () =
match max_upload_speed with match max_upload_speed with
@ -131,7 +131,7 @@ let client ?max_upload_speed ?write_queue_size addr port time _n =
P2p_io_scheduler.close conn >>=? fun () -> P2p_io_scheduler.close conn >>=? fun () ->
let stat = P2p_io_scheduler.stat conn in let stat = P2p_io_scheduler.stat conn in
lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () -> lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () ->
return () return_unit
let run let run
?display_client_stat ?display_client_stat

View File

@ -43,7 +43,7 @@ let conn_meta_config : metadata P2p_socket.metadata_config = {
let sync ch = let sync ch =
Process.Channel.push ch () >>=? fun () -> Process.Channel.push ch () >>=? fun () ->
Process.Channel.pop ch >>=? fun () -> Process.Channel.pop ch >>=? fun () ->
return () return_unit
let rec sync_nodes nodes = let rec sync_nodes nodes =
iter_p iter_p
@ -57,7 +57,7 @@ let rec sync_nodes nodes =
let sync_nodes nodes = let sync_nodes nodes =
sync_nodes nodes >>= function sync_nodes nodes >>= function
| Ok () | Error (Exn End_of_file :: _) -> | Ok () | Error (Exn End_of_file :: _) ->
return () return_unit
| Error _ as err -> | Error _ as err ->
Lwt.return err Lwt.return err
@ -104,7 +104,7 @@ let detach_node f points n =
P2p_pool.destroy pool >>= fun () -> P2p_pool.destroy pool >>= fun () ->
P2p_io_scheduler.shutdown sched >>= fun () -> P2p_io_scheduler.shutdown sched >>= fun () ->
lwt_log_info "Bye." >>= fun () -> lwt_log_info "Bye." >>= fun () ->
return () return_unit
end end
let detach_nodes run_node points = let detach_nodes run_node points =
@ -165,7 +165,7 @@ module Simple = struct
iter_p iter_p
(fun conn -> (fun conn ->
trace Read @@ P2p_pool.read conn >>=? fun Ping -> trace Read @@ P2p_pool.read conn >>=? fun Ping ->
return ()) return_unit)
conns conns
let close_all conns = let close_all conns =
@ -183,7 +183,7 @@ module Simple = struct
sync channel >>=? fun () -> sync channel >>=? fun () ->
close_all conns >>= fun () -> close_all conns >>= fun () ->
lwt_log_info "All connections successfully closed." >>= fun () -> lwt_log_info "All connections successfully closed." >>= fun () ->
return () return_unit
let run points = detach_nodes node points let run points = detach_nodes node points
@ -203,12 +203,12 @@ module Random_connections = struct
if !rem mod total = 0 then if !rem mod total = 0 then
lwt_log_info "Remaining: %d." (!rem / total) lwt_log_info "Remaining: %d." (!rem / total)
else else
Lwt.return () Lwt.return_unit
end >>= fun () -> end >>= fun () ->
if n > 1 then if n > 1 then
connect_random pool total rem point (pred n) connect_random pool total rem point (pred n)
else else
return () return_unit
let connect_random_all pool points n = let connect_random_all pool points n =
let total = List.length points in let total = List.length points in
@ -219,7 +219,7 @@ module Random_connections = struct
lwt_log_info "Begin random connections." >>= fun () -> lwt_log_info "Begin random connections." >>= fun () ->
connect_random_all pool points repeat >>=? fun () -> connect_random_all pool points repeat >>=? fun () ->
lwt_log_info "Random connections OK." >>= fun () -> lwt_log_info "Random connections OK." >>= fun () ->
return () return_unit
let run points repeat = detach_nodes (node repeat) points let run points repeat = detach_nodes (node repeat) points

View File

@ -51,7 +51,7 @@ let rec listen ?port addr =
let sync ch = let sync ch =
Process.Channel.push ch () >>=? fun () -> Process.Channel.push ch () >>=? fun () ->
Process.Channel.pop ch >>=? fun () -> Process.Channel.pop ch >>=? fun () ->
return () return_unit
let rec sync_nodes nodes = let rec sync_nodes nodes =
iter_p iter_p
@ -65,7 +65,7 @@ let rec sync_nodes nodes =
let sync_nodes nodes = let sync_nodes nodes =
sync_nodes nodes >>= function sync_nodes nodes >>= function
| Ok () | Error (Exn End_of_file :: _) -> | Ok () | Error (Exn End_of_file :: _) ->
return () return_unit
| Error _ as err -> | Error _ as err ->
Lwt.return err Lwt.return err
@ -75,14 +75,14 @@ let run_nodes client server =
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
server channel sched main_socket >>=? fun () -> server channel sched main_socket >>=? fun () ->
P2p_io_scheduler.shutdown sched >>= fun () -> P2p_io_scheduler.shutdown sched >>= fun () ->
return () return_unit
end >>= fun server_node -> end >>= fun server_node ->
Process.detach ~prefix:"client: " begin fun channel -> Process.detach ~prefix:"client: " begin fun channel ->
Lwt_utils_unix.safe_close main_socket >>= fun () -> Lwt_utils_unix.safe_close main_socket >>= fun () ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
client channel sched default_addr port >>=? fun () -> client channel sched default_addr port >>=? fun () ->
P2p_io_scheduler.shutdown sched >>= fun () -> P2p_io_scheduler.shutdown sched >>= fun () ->
return () return_unit
end >>= fun client_node -> end >>= fun client_node ->
let nodes = [ server_node ; client_node ] in let nodes = [ server_node ; client_node ] in
Lwt.ignore_result (sync_nodes nodes) ; Lwt.ignore_result (sync_nodes nodes) ;
@ -148,13 +148,13 @@ module Low_level = struct
P2p_io_scheduler.read_full fd msg >>=? fun () -> P2p_io_scheduler.read_full fd msg >>=? fun () ->
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
P2p_io_scheduler.close fd >>=? fun () -> P2p_io_scheduler.close fd >>=? fun () ->
return () return_unit
let server _ch sched socket = let server _ch sched socket =
raw_accept sched socket >>= fun (fd, _point) -> raw_accept sched socket >>= fun (fd, _point) ->
P2p_io_scheduler.write fd simple_msg >>=? fun () -> P2p_io_scheduler.write fd simple_msg >>=? fun () ->
P2p_io_scheduler.close fd >>=? fun _ -> P2p_io_scheduler.close fd >>=? fun _ ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -177,13 +177,13 @@ module Kick = struct
_assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0) _assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0)
__LOC__ "" >>=? fun () -> __LOC__ "" >>=? fun () ->
P2p_socket.kick auth_fd >>= fun () -> P2p_socket.kick auth_fd >>= fun () ->
return () return_unit
let client _ch sched addr port = let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
P2p_socket.accept auth_fd encoding >>= fun conn -> P2p_socket.accept auth_fd encoding >>= fun conn ->
_assert (is_rejected conn) __LOC__ "" >>=? fun () -> _assert (is_rejected conn) __LOC__ "" >>=? fun () ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -197,12 +197,12 @@ module Kicked = struct
accept sched socket >>=? fun (_info, auth_fd) -> accept sched socket >>=? fun (_info, auth_fd) ->
P2p_socket.accept auth_fd encoding >>= fun conn -> P2p_socket.accept auth_fd encoding >>= fun conn ->
_assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () -> _assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () ->
return () return_unit
let client _ch sched addr port = let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
P2p_socket.kick auth_fd >>= fun () -> P2p_socket.kick auth_fd >>= fun () ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -223,7 +223,7 @@ module Simple_message = struct
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let client ch sched addr port = let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -233,7 +233,7 @@ module Simple_message = struct
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -255,7 +255,7 @@ module Chunked_message = struct
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let client ch sched addr port = let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -266,7 +266,7 @@ module Chunked_message = struct
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -287,7 +287,7 @@ module Oversized_message = struct
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let client ch sched addr port = let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -297,7 +297,7 @@ module Oversized_message = struct
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () -> _assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -314,7 +314,7 @@ module Close_on_read = struct
P2p_socket.accept auth_fd encoding >>=? fun conn -> P2p_socket.accept auth_fd encoding >>=? fun conn ->
sync ch >>=? fun () -> sync ch >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let client ch sched addr port = let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -323,7 +323,7 @@ module Close_on_read = struct
P2p_socket.read conn >>= fun err -> P2p_socket.read conn >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () -> _assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -340,7 +340,7 @@ module Close_on_write = struct
P2p_socket.accept auth_fd encoding >>=? fun conn -> P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
sync ch >>=? fun ()-> sync ch >>=? fun ()->
return () return_unit
let client ch sched addr port = let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -350,7 +350,7 @@ module Close_on_write = struct
P2p_socket.write_sync conn simple_msg >>= fun err -> P2p_socket.write_sync conn simple_msg >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () -> _assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server
@ -379,7 +379,7 @@ module Garbled_data = struct
P2p_socket.read conn >>= fun err -> P2p_socket.read conn >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () -> _assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let client _ch sched addr port = let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd -> connect sched addr port id2 >>=? fun auth_fd ->
@ -387,7 +387,7 @@ module Garbled_data = struct
P2p_socket.read conn >>= fun err -> P2p_socket.read conn >>= fun err ->
_assert (is_decoding_error err) __LOC__ "" >>=? fun () -> _assert (is_decoding_error err) __LOC__ "" >>=? fun () ->
P2p_socket.close conn >>= fun _stat -> P2p_socket.close conn >>= fun _stat ->
return () return_unit
let run _dir = run_nodes client server let run _dir = run_nodes client server

View File

@ -72,6 +72,9 @@ val ok : 'a -> 'a tzresult
(** Sucessful return *) (** Sucessful return *)
val return : 'a -> 'a tzresult Lwt.t val return : 'a -> 'a tzresult Lwt.t
(** Sucessful return of [()] *)
val return_unit : unit tzresult Lwt.t
(** Erroneous result *) (** Erroneous result *)
val error : error -> 'a tzresult val error : error -> 'a tzresult

View File

@ -55,7 +55,7 @@ let test_simple { block2 = ctxt } =
Assert.equal_string_option (Some "Novembre") (c novembre) ; Assert.equal_string_option (Some "Novembre") (c novembre) ;
Context.get ctxt ["a";"c"] >>= fun juin -> Context.get ctxt ["a";"c"] >>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Lwt.return () Lwt.return_unit
let test_continuation { block3a = ctxt } = let test_continuation { block3a = ctxt } =
Context.get ctxt ["version"] >>= fun version -> Context.get ctxt ["version"] >>= fun version ->
@ -66,7 +66,7 @@ let test_continuation { block3a = ctxt } =
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Context.get ctxt ["a";"d"] >>= fun mars -> Context.get ctxt ["a";"d"] >>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ; Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
Lwt.return () Lwt.return_unit
let test_fork { block3b = ctxt } = let test_fork { block3b = ctxt } =
Context.get ctxt ["version"] >>= fun version -> Context.get ctxt ["version"] >>= fun version ->
@ -77,7 +77,7 @@ let test_fork { block3b = ctxt } =
Assert.is_none ~msg:__LOC__ (c juin) ; Assert.is_none ~msg:__LOC__ (c juin) ;
Context.get ctxt ["a";"d"] >>= fun mars -> Context.get ctxt ["a";"d"] >>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ; Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
Lwt.return () Lwt.return_unit
let test_replay { genesis = ctxt0 } = let test_replay { genesis = ctxt0 } =
Context.set ctxt0 ["version"] (MBytes.of_string "0.0") >>= fun ctxt1 -> Context.set ctxt0 ["version"] (MBytes.of_string "0.0") >>= fun ctxt1 ->
@ -96,7 +96,7 @@ let test_replay { genesis = ctxt0 } =
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
Context.get ctxt4b ["a";"d"] >>= fun juillet -> Context.get ctxt4b ["a";"d"] >>= fun juillet ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return () Lwt.return_unit
let fold_keys s k ~init ~f = let fold_keys s k ~init ~f =
let rec loop k acc = let rec loop k acc =
@ -131,7 +131,7 @@ let test_fold { genesis = ctxt } =
Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ; Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ;
keys ctxt ["i"] >>= fun l -> keys ctxt ["i"] >>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ; Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return () Lwt.return_unit
(******************************************************************************) (******************************************************************************)

View File

@ -79,7 +79,7 @@ let check_header
(invalid_block hash (invalid_block hash
(Unexpected_number_of_validation_passes header.shell.validation_passes) (Unexpected_number_of_validation_passes header.shell.validation_passes)
) >>=? fun () -> ) >>=? fun () ->
return () return_unit
let assert_no_duplicate_operations block live_operations operation_hashes = let assert_no_duplicate_operations block live_operations operation_hashes =
fold_left_s (fold_left_s (fun live_operations oph -> fold_left_s (fold_left_s (fun live_operations oph ->
@ -87,7 +87,7 @@ let assert_no_duplicate_operations block live_operations operation_hashes =
(invalid_block block @@ Replayed_operation oph) >>=? fun () -> (invalid_block block @@ Replayed_operation oph) >>=? fun () ->
return (Operation_hash.Set.add oph live_operations))) return (Operation_hash.Set.add oph live_operations)))
live_operations operation_hashes >>=? fun _ -> live_operations operation_hashes >>=? fun _ ->
return () return_unit
let assert_operation_liveness block live_blocks operations = let assert_operation_liveness block live_blocks operations =
iter_s (iter_s (fun op -> iter_s (iter_s (fun op ->
@ -110,7 +110,7 @@ let check_liveness chain_state pred hash operations_hashes operations =
assert_no_duplicate_operations assert_no_duplicate_operations
hash live_operations operations_hashes >>=? fun () -> hash live_operations operations_hashes >>=? fun () ->
assert_operation_liveness hash live_blocks operations >>=? fun () -> assert_operation_liveness hash live_blocks operations >>=? fun () ->
return () return_unit
let may_patch_protocol let may_patch_protocol
~level ~level
@ -147,7 +147,7 @@ let apply_block
Oversized_operation Oversized_operation
{ operation = Operation.hash op ; { operation = Operation.hash op ;
size ; max = Proto.max_operation_data_length })) ops >>=? fun () -> size ; max = Proto.max_operation_data_length })) ops >>=? fun () ->
return ()) return_unit)
operations Proto.validation_passes >>=? fun () -> operations Proto.validation_passes >>=? fun () ->
let operation_hashes = List.map (List.map Operation.hash) operations in let operation_hashes = List.map (List.map Operation.hash) operations in
check_liveness chain_state pred hash operation_hashes operations >>=? fun () -> check_liveness chain_state pred hash operation_hashes operations >>=? fun () ->
@ -254,7 +254,7 @@ let check_chain_liveness chain_db hash (header: Block_header.t) =
Expired_chain { chain_id = State.Chain.id chain_state ; Expired_chain { chain_id = State.Chain.id chain_state ;
expiration = eol ; expiration = eol ;
timestamp = header.shell.timestamp } timestamp = header.shell.timestamp }
| None | Some _ -> return () | None | Some _ -> return_unit
let get_proto pred hash = let get_proto pred hash =
State.Block.context pred >>= fun pred_context -> State.Block.context pred >>= fun pred_context ->
@ -340,13 +340,13 @@ let on_completion
| Ok (Some _) -> | Ok (Some _) ->
Worker.record_event w Worker.record_event w
(Event.Validation_success (Request.view r, st)) ; (Event.Validation_success (Request.view r, st)) ;
Lwt.return () Lwt.return_unit
| Ok None -> | Ok None ->
Lwt.return () Lwt.return_unit
| Error errs -> | Error errs ->
Worker.record_event w Worker.record_event w
(Event.Validation_failure (Request.view r, st, errs)) ; (Event.Validation_failure (Request.view r, st, errs)) ;
Lwt.return () Lwt.return_unit
let table = Worker.create_table Queue let table = Worker.create_table Queue
@ -355,10 +355,10 @@ let create limits db =
type self = t type self = t
let on_launch = on_launch let on_launch = on_launch
let on_request = on_request let on_request = on_request
let on_close _ = Lwt.return () let on_close _ = Lwt.return_unit
let on_error = on_error let on_error = on_error
let on_completion = on_completion let on_completion = on_completion
let on_no_request _ = return () let on_no_request _ = return_unit
end in end in
Worker.launch Worker.launch
table table

View File

@ -53,11 +53,11 @@ let assert_acceptable_header pipeline
Chain.mem chain_state hash >>= fun in_chain -> Chain.mem chain_state hash >>= fun in_chain ->
fail_unless in_chain fail_unless in_chain
(Checkpoint_error (hash, Some pipeline.peer_id)) >>=? fun () -> (Checkpoint_error (hash, Some pipeline.peer_id)) >>=? fun () ->
return () return_unit
else else
return () return_unit
else else
return () return_unit
let fetch_step pipeline (step : Block_locator.step) = let fetch_step pipeline (step : Block_locator.step) =
lwt_log_info "fetching step %a -> %a (%d%s) from peer %a." lwt_log_info "fetching step %a -> %a (%d%s) from peer %a."
@ -103,7 +103,7 @@ let fetch_step pipeline (step : Block_locator.step) =
end end
end end
headers >>=? fun () -> headers >>=? fun () ->
return () return_unit
let headers_fetch_worker_loop pipeline = let headers_fetch_worker_loop pipeline =
begin begin
@ -113,7 +113,7 @@ let headers_fetch_worker_loop pipeline =
let seed = {Block_locator.sender_id=pipeline.peer_id; receiver_id=sender_id } in let seed = {Block_locator.sender_id=pipeline.peer_id; receiver_id=sender_id } in
let steps = Block_locator.to_steps seed pipeline.locator in let steps = Block_locator.to_steps seed pipeline.locator in
iter_s (fetch_step pipeline) steps >>=? fun () -> iter_s (fetch_step pipeline) steps >>=? fun () ->
return () return_unit
end >>= function end >>= function
| Ok () -> | Ok () ->
lwt_log_info "fetched all step from peer %a." lwt_log_info "fetched all step from peer %a."
@ -210,7 +210,7 @@ let rec validation_worker_loop pipeline =
lwt_log_info "validated block %a from peer %a." lwt_log_info "validated block %a from peer %a."
Block_hash.pp_short hash Block_hash.pp_short hash
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () -> P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
return () return_unit
end >>= function end >>= function
| Ok () -> validation_worker_loop pipeline | Ok () -> validation_worker_loop pipeline
| Error [Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed] -> | Error [Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed] ->
@ -286,7 +286,7 @@ let wait_workers pipeline =
let wait pipeline = let wait pipeline =
wait_workers pipeline >>= fun () -> wait_workers pipeline >>= fun () ->
match pipeline.errors with match pipeline.errors with
| [] -> return () | [] -> return_unit
| errors -> Lwt.return_error errors | errors -> Lwt.return_error errors
let cancel pipeline = let cancel pipeline =

View File

@ -87,7 +87,7 @@ let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
(fun b -> Time.(min_date <= Block.timestamp b)) in (fun b -> Time.(min_date <= Block.timestamp b)) in
let rec loop () = let rec loop () =
match pop () with match pop () with
| None -> Lwt.return () | None -> Lwt.return_unit
| Some b -> | Some b ->
check_count () ; check_count () ;
f b >>= fun () -> f b >>= fun () ->
@ -97,7 +97,7 @@ let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
if check_fitness p && check_date p then push p ; if check_fitness p && check_date p then push p ;
loop () in loop () in
List.iter push heads ; List.iter push heads ;
try loop () with Local.Exit -> Lwt.return () try loop () with Local.Exit -> Lwt.return_unit
let iter_predecessors ?max ?min_fitness ?min_date heads ~f = let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
match heads with match heads with

View File

@ -167,10 +167,10 @@ let may_switch_test_chain w spawn_child block =
nv.parameters.db chain_state nv.parameters.db chain_state
nv.parameters.limits (* TODO: different limits main/test ? *) >>= fun child -> nv.parameters.limits (* TODO: different limits main/test ? *) >>= fun child ->
nv.child <- Some child ; nv.child <- Some child ;
return () return_unit
end else begin end else begin
(* Ignoring request... *) (* Ignoring request... *)
return () return_unit
end in end in
let check_child genesis protocol expiration current_time = let check_child genesis protocol expiration current_time =
@ -196,7 +196,7 @@ let may_switch_test_chain w spawn_child block =
else if not activated && not expired then else if not activated && not expired then
create_child genesis protocol expiration create_child genesis protocol expiration
else else
return () in return_unit in
begin begin
let block_header = State.Block.header block in let block_header = State.Block.header block in
@ -252,7 +252,7 @@ let on_request (type a) w spawn_child (req : a Request.t) : a tzresult Lwt.t =
begin match nv.prevalidator with begin match nv.prevalidator with
| Some prevalidator -> | Some prevalidator ->
Prevalidator.flush prevalidator block_hash Prevalidator.flush prevalidator block_hash
| None -> return () | None -> return_unit
end >>=? fun () -> end >>=? fun () ->
may_switch_test_chain w spawn_child block >>= fun () -> may_switch_test_chain w spawn_child block >>= fun () ->
Lwt_watcher.notify nv.new_head_input block ; Lwt_watcher.notify nv.new_head_input block ;
@ -267,7 +267,7 @@ let on_completion (type a) w (req : a Request.t) (update : a) request_status =
let fitness = State.Block.fitness block in let fitness = State.Block.fitness block in
let request = State.Block.hash block in let request = State.Block.hash block in
Worker.record_event w (Processed_block { request ; request_status ; update ; fitness }) ; Worker.record_event w (Processed_block { request ; request_status ; update ; fitness }) ;
Lwt.return () Lwt.return_unit
let on_close w = let on_close w =
let nv = Worker.state w in let nv = Worker.state w in
@ -352,7 +352,7 @@ let rec create
let on_close = on_close let on_close = on_close
let on_error _ _ _ errs = Lwt.return (Error errs) let on_error _ _ _ errs = Lwt.return (Error errs)
let on_completion = on_completion let on_completion = on_completion
let on_no_request _ = return () let on_no_request _ = return_unit
end in end in
let parameters = let parameters =
{ max_child_ttl ; { max_child_ttl ;

View File

@ -21,7 +21,7 @@ let inject_block validator ?force ?chain bytes operations =
read_chain_id validator chain >>= fun chain_id -> read_chain_id validator chain >>= fun chain_id ->
Validator.validate_block Validator.validate_block
validator ?force ?chain_id bytes operations >>=? fun (hash, block) -> validator ?force ?chain_id bytes operations >>=? fun (hash, block) ->
return (hash, (block >>=? fun _ -> return ())) return (hash, (block >>=? fun _ -> return_unit))
let inject_operation validator ?chain bytes = let inject_operation validator ?chain bytes =
read_chain_id validator chain >>= fun chain_id -> read_chain_id validator chain >>= fun chain_id ->
@ -49,7 +49,7 @@ let inject_protocol state ?force:_ proto =
failwith failwith
"Previously registered protocol (%a)" "Previously registered protocol (%a)"
Protocol_hash.pp_short hash Protocol_hash.pp_short hash
| Some _ -> return () | Some _ -> return_unit
in in
Lwt.return (hash, validation) Lwt.return (hash, validation)
@ -65,19 +65,19 @@ let build_rpc_directory validator =
register0 Injection_services.S.block begin fun q (raw, operations) -> register0 Injection_services.S.block begin fun q (raw, operations) ->
inject_block validator inject_block validator
?chain:q#chain ~force:q#force raw operations >>=? fun (hash, wait) -> ?chain:q#chain ~force:q#force raw operations >>=? fun (hash, wait) ->
(if q#async then return () else wait) >>=? fun () -> (if q#async then return_unit else wait) >>=? fun () ->
return hash return hash
end ; end ;
register0 Injection_services.S.operation begin fun q contents -> register0 Injection_services.S.operation begin fun q contents ->
inject_operation validator ?chain:q#chain contents >>= fun (hash, wait) -> inject_operation validator ?chain:q#chain contents >>= fun (hash, wait) ->
(if q#async then return () else wait) >>=? fun () -> (if q#async then return_unit else wait) >>=? fun () ->
return hash return hash
end ; end ;
register0 Injection_services.S.protocol begin fun q protocol -> register0 Injection_services.S.protocol begin fun q protocol ->
inject_protocol state ~force:q#force protocol >>= fun (hash, wait) -> inject_protocol state ~force:q#force protocol >>= fun (hash, wait) ->
(if q#async then return () else wait) >>=? fun () -> (if q#async then return_unit else wait) >>=? fun () ->
return hash return hash
end ; end ;

View File

@ -119,7 +119,7 @@ let bootstrap_new_branch w _ancestor _head unknown_prefix =
debug w debug w
"done validating new branch from peer %a." "done validating new branch from peer %a."
P2p_peer.Id.pp_short pv.peer_id ; P2p_peer.Id.pp_short pv.peer_id ;
return () return_unit
let validate_new_head w hash (header : Block_header.t) = let validate_new_head w hash (header : Block_header.t) =
let pv = Worker.state w in let pv = Worker.state w in
@ -149,7 +149,7 @@ let validate_new_head w hash (header : Block_header.t) =
Block_hash.pp_short hash Block_hash.pp_short hash
P2p_peer.Id.pp_short pv.peer_id ; P2p_peer.Id.pp_short pv.peer_id ;
set_bootstrapped pv ; set_bootstrapped pv ;
return () return_unit
let only_if_fitness_increases w distant_header cont = let only_if_fitness_increases w distant_header cont =
let pv = Worker.state w in let pv = Worker.state w in
@ -164,7 +164,7 @@ let only_if_fitness_increases w distant_header cont =
Block_hash.pp_short (Block_header.hash distant_header) Block_hash.pp_short (Block_header.hash distant_header)
P2p_peer.Id.pp_short pv.peer_id ; P2p_peer.Id.pp_short pv.peer_id ;
(* Don't download a branch that cannot beat the current head. *) (* Don't download a branch that cannot beat the current head. *)
return () return_unit
end else cont () end else cont ()
let assert_acceptable_head w hash (header: Block_header.t) = let assert_acceptable_head w hash (header: Block_header.t) =
@ -190,7 +190,7 @@ let may_validate_new_head w hash (header : Block_header.t) =
P2p_peer.Id.pp_short pv.peer_id ; P2p_peer.Id.pp_short pv.peer_id ;
set_bootstrapped pv ; set_bootstrapped pv ;
pv.last_validated_head <- header ; pv.last_validated_head <- header ;
return () return_unit
end else if invalid_block then begin end else if invalid_block then begin
debug w debug w
"ignoring known invalid block %a from peer %a" "ignoring known invalid block %a from peer %a"
@ -212,7 +212,7 @@ let may_validate_new_head w hash (header : Block_header.t) =
P2p_peer.Id.pp_short pv.peer_id ; P2p_peer.Id.pp_short pv.peer_id ;
Distributed_db.Request.current_branch Distributed_db.Request.current_branch
pv.parameters.chain_db ~peer:pv.peer_id () ; pv.parameters.chain_db ~peer:pv.peer_id () ;
return () return_unit
end else begin end else begin
only_if_fitness_increases w header @@ fun () -> only_if_fitness_increases w header @@ fun () ->
assert_acceptable_head w hash header >>=? fun () -> assert_acceptable_head w hash header >>=? fun () ->
@ -242,7 +242,7 @@ let on_no_request w =
P2p_peer.Id.pp_short pv.peer_id P2p_peer.Id.pp_short pv.peer_id
pv.parameters.limits.new_head_request_timeout ; pv.parameters.limits.new_head_request_timeout ;
Distributed_db.Request.current_head pv.parameters.chain_db ~peer:pv.peer_id () ; Distributed_db.Request.current_head pv.parameters.chain_db ~peer:pv.peer_id () ;
return () return_unit
let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t = let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
let pv = Worker.state w in let pv = Worker.state w in
@ -262,7 +262,7 @@ let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
let on_completion w r _ st = let on_completion w r _ st =
Worker.record_event w (Event.Request (Request.view r, st, None )) ; Worker.record_event w (Event.Request (Request.view r, st, None )) ;
Lwt.return () Lwt.return_unit
let on_error w r st errs = let on_error w r st errs =
let pv = Worker.state w in let pv = Worker.state w in
@ -287,7 +287,7 @@ let on_error w r st errs =
| Ok _ -> | Ok _ ->
Distributed_db.Request.current_head Distributed_db.Request.current_head
pv.parameters.chain_db ~peer:pv.peer_id () ; pv.parameters.chain_db ~peer:pv.peer_id () ;
return () return_unit
| Error _ -> | Error _ ->
(* TODO: punish *) (* TODO: punish *)
debug w debug w
@ -306,7 +306,7 @@ let on_close w =
let pv = Worker.state w in let pv = Worker.state w in
Distributed_db.disconnect pv.parameters.chain_db pv.peer_id >>= fun () -> Distributed_db.disconnect pv.parameters.chain_db pv.peer_id >>= fun () ->
pv.parameters.notify_termination () ; pv.parameters.notify_termination () ;
Lwt.return () Lwt.return_unit
let on_launch _ name parameters = let on_launch _ name parameters =
let chain_state = Distributed_db.chain_state parameters.chain_db in let chain_state = Distributed_db.chain_state parameters.chain_db in
@ -365,7 +365,7 @@ let create
let on_close = on_close let on_close = on_close
let on_error = on_error let on_error = on_error
let on_completion = on_completion let on_completion = on_completion
let on_no_request _ = return () let on_no_request _ = return_unit
end in end in
Worker.launch table ~timeout: limits.new_head_request_timeout limits.worker_limits Worker.launch table ~timeout: limits.new_head_request_timeout limits.worker_limits
name parameters name parameters

View File

@ -250,10 +250,10 @@ let handle_unprocessed w pv =
pv.pending Operation_hash.Map.empty } ; pv.pending Operation_hash.Map.empty } ;
pv.pending <- pv.pending <-
Operation_hash.Map.empty ; Operation_hash.Map.empty ;
Lwt.return () Lwt.return_unit
| Ok validation_state -> | Ok validation_state ->
match Operation_hash.Map.cardinal pv.pending with match Operation_hash.Map.cardinal pv.pending with
| 0 -> Lwt.return () | 0 -> Lwt.return_unit
| n -> debug w "processing %d operations" n ; | n -> debug w "processing %d operations" n ;
Prevalidation.prevalidate validation_state ~sort:true Prevalidation.prevalidate validation_state ~sort:true
(Operation_hash.Map.bindings pv.pending) (Operation_hash.Map.bindings pv.pending)
@ -286,7 +286,7 @@ let handle_unprocessed w pv =
Operation_hash.Map.empty ; Operation_hash.Map.empty ;
advertise w pv advertise w pv
(mempool_of_prevalidation_result validation_result) ; (mempool_of_prevalidation_result validation_result) ;
Lwt.return () Lwt.return_unit
end >>= fun () -> end >>= fun () ->
pv.mempool <- pv.mempool <-
{ Mempool.known_valid = { Mempool.known_valid =
@ -301,7 +301,7 @@ let handle_unprocessed w pv =
Operation_hash.Set.empty } ; Operation_hash.Set.empty } ;
State.Current_mempool.set (Distributed_db.chain_state pv.chain_db) State.Current_mempool.set (Distributed_db.chain_state pv.chain_db)
~head:(State.Block.hash pv.predecessor) pv.mempool >>= fun () -> ~head:(State.Block.hash pv.predecessor) pv.mempool >>= fun () ->
Lwt.return () Lwt.return_unit
let fetch_operation w pv ?peer oph = let fetch_operation w pv ?peer oph =
debug w debug w
@ -348,7 +348,7 @@ let on_inject pv op =
return result return result
end >>=? fun result -> end >>=? fun result ->
if List.mem_assoc oph result.applied then if List.mem_assoc oph result.applied then
return () return_unit
else else
let try_in_map map proj or_else = let try_in_map map proj or_else =
try try
@ -413,7 +413,7 @@ let on_flush w pv predecessor =
pv.validation_state <- validation_state ; pv.validation_state <- validation_state ;
if not (Protocol_hash.equal old_protocol new_protocol) then if not (Protocol_hash.equal old_protocol new_protocol) then
pv.rpc_directory <- lazy (rpc_directory new_protocol) ; pv.rpc_directory <- lazy (rpc_directory new_protocol) ;
return () return_unit
let on_advertise pv = let on_advertise pv =
match pv.advertisement with match pv.advertisement with
@ -436,15 +436,15 @@ let on_request
return (() : r) return (() : r)
| Request.Notify (peer, mempool) -> | Request.Notify (peer, mempool) ->
on_notify w pv peer mempool ; on_notify w pv peer mempool ;
return () return_unit
| Request.Inject op -> | Request.Inject op ->
on_inject pv op on_inject pv op
| Request.Arrived (oph, op) -> | Request.Arrived (oph, op) ->
on_operation_arrived pv oph op ; on_operation_arrived pv oph op ;
return () return_unit
| Request.Advertise -> | Request.Advertise ->
on_advertise pv ; on_advertise pv ;
return () return_unit
end >>=? fun r -> end >>=? fun r ->
handle_unprocessed w pv >>= fun () -> handle_unprocessed w pv >>= fun () ->
return r return r
@ -498,12 +498,12 @@ let on_launch w _ (limits, chain_db) =
let on_error w r st errs = let on_error w r st errs =
Worker.record_event w (Event.Request (r, st, Some errs)) ; Worker.record_event w (Event.Request (r, st, Some errs)) ;
match r with match r with
| Request.(View (Inject _)) -> return () | Request.(View (Inject _)) -> return_unit
| _ -> Lwt.return (Error errs) | _ -> Lwt.return (Error errs)
let on_completion w r _ st = let on_completion w r _ st =
Worker.record_event w (Event.Request (Request.view r, st, None )) ; Worker.record_event w (Event.Request (Request.view r, st, None)) ;
Lwt.return () Lwt.return_unit
let table = Worker.create_table Queue let table = Worker.create_table Queue
@ -516,7 +516,7 @@ let create limits chain_db =
let on_close = on_close let on_close = on_close
let on_error = on_error let on_error = on_error
let on_completion = on_completion let on_completion = on_completion
let on_no_request _ = return () let on_no_request _ = return_unit
end in end in
Worker.launch table limits.worker_limits Worker.launch table limits.worker_limits
(State.Chain.id chain_state) (State.Chain.id chain_state)

View File

@ -47,7 +47,7 @@ let rec worker_loop bv =
end >>=? fun _ -> end >>=? fun _ ->
match wakener with match wakener with
| None -> | None ->
return () return_unit
| Some wakener -> | Some wakener ->
if valid then if valid then
match Registered_protocol.get hash with match Registered_protocol.get hash with
@ -63,7 +63,7 @@ let rec worker_loop bv =
(Error (Error
[Invalid_protocol { hash ; [Invalid_protocol { hash ;
error = Compilation_failed }]) ; error = Compilation_failed }]) ;
return () return_unit
end >>= function end >>= function
| Ok () -> | Ok () ->
worker_loop bv worker_loop bv
@ -137,17 +137,17 @@ let fetch_and_compile_protocols pv ?peer ?timeout (block: State.Block.t) =
let protocol = let protocol =
Context.get_protocol context >>= fun protocol_hash -> Context.get_protocol context >>= fun protocol_hash ->
fetch_and_compile_protocol pv ?peer ?timeout protocol_hash >>=? fun _ -> fetch_and_compile_protocol pv ?peer ?timeout protocol_hash >>=? fun _ ->
return () return_unit
and test_protocol = and test_protocol =
Context.get_test_chain context >>= function Context.get_test_chain context >>= function
| Not_running -> return () | Not_running -> return_unit
| Forking { protocol } | Forking { protocol }
| Running { protocol } -> | Running { protocol } ->
fetch_and_compile_protocol pv ?peer ?timeout protocol >>=? fun _ -> fetch_and_compile_protocol pv ?peer ?timeout protocol >>=? fun _ ->
return () in return_unit in
protocol >>=? fun () -> protocol >>=? fun () ->
test_protocol >>=? fun () -> test_protocol >>=? fun () ->
return () return_unit
let prefetch_and_compile_protocols pv ?peer ?timeout block = let prefetch_and_compile_protocols pv ?peer ?timeout block =
try ignore (fetch_and_compile_protocols pv ?peer ?timeout block) with _ -> () try ignore (fetch_and_compile_protocols pv ?peer ?timeout block) with _ -> ()

View File

@ -489,7 +489,7 @@ module Chain = struct
(fun id -> (fun id ->
locked_read global_state data id >>=? fun chain -> locked_read global_state data id >>=? fun chain ->
Chain_id.Table.add data.chains id chain ; Chain_id.Table.add data.chains id chain ;
return ()) return_unit)
ids ids
let read_all state = let read_all state =

View File

@ -306,7 +306,7 @@ let test_locator base_dir =
then then
Assert.fail_msg "Invalid locator %i" size) Assert.fail_msg "Invalid locator %i" size)
l_exp l_lin; l_exp l_lin;
return () return_unit
in in
let stop = locator_limit + 20 in let stop = locator_limit + 20 in
let rec loop size = let rec loop size =
@ -314,7 +314,7 @@ let test_locator base_dir =
check_locator size >>=? fun _ -> check_locator size >>=? fun _ ->
loop (size+5) loop (size+5)
) )
else return () else return_unit
in in
loop 1 loop 1

View File

@ -120,7 +120,7 @@ let build_valid_chain state vtbl pred names =
attempt None) attempt None)
pred pred
names >>= fun _ -> names >>= fun _ ->
Lwt.return () Lwt.return_unit
let build_example_tree chain = let build_example_tree chain =
let vtbl = Hashtbl.create 23 in let vtbl = Hashtbl.create 23 in
@ -159,11 +159,11 @@ let wrap_state_init f base_dir =
genesis >>=? fun (state, chain) -> genesis >>=? fun (state, chain) ->
build_example_tree chain >>= fun vblock -> build_example_tree chain >>= fun vblock ->
f { state ; chain ; vblock } >>=? fun () -> f { state ; chain ; vblock } >>=? fun () ->
return () return_unit
end end
let test_init (_ : state) = let test_init (_ : state) =
return () return_unit
@ -181,7 +181,7 @@ let test_read_block (s: state) =
(* FIXME COMPARE read operations ??? *) (* FIXME COMPARE read operations ??? *)
Lwt.return_unit Lwt.return_unit
) (vblocks s) >>= fun () -> ) (vblocks s) >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -209,7 +209,7 @@ let test_path (s: state) =
check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () -> check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () ->
check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () -> check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () ->
check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -237,7 +237,7 @@ let test_ancestor s =
check_ancestor "B1" "A3" (vblock s "A3") >>= fun () -> check_ancestor "B1" "A3" (vblock s "A3") >>= fun () ->
check_ancestor "A2" "B1" (vblock s "A2") >>= fun () -> check_ancestor "A2" "B1" (vblock s "A2") >>= fun () ->
check_ancestor "B1" "A2" (vblock s "A2") >>= fun () -> check_ancestor "B1" "A2" (vblock s "A2") >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -269,7 +269,7 @@ let test_locator s =
check_locator 4 "B8" ["B7";"B6";"B5";"B4"] >>= fun () -> check_locator 4 "B8" ["B7";"B6";"B5";"B4"] >>= fun () ->
check_locator 0 "A5" [] >>= fun () -> check_locator 0 "A5" [] >>= fun () ->
check_locator 100 "A5" ["A4";"A3";"A2";"A1";"Genesis"] >>= fun () -> check_locator 100 "A5" ["A4";"A3";"A2";"A1";"Genesis"] >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -291,7 +291,7 @@ let compare s name heads l =
let test_known_heads s = let test_known_heads s =
Chain.known_heads s.chain >>= fun heads -> Chain.known_heads s.chain >>= fun heads ->
compare s "initial" heads ["A8";"B8"] ; compare s "initial" heads ["A8";"B8"] ;
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -306,7 +306,7 @@ let test_head s =
Chain.head s.chain >>= fun head -> Chain.head s.chain >>= fun head ->
if not (Block_hash.equal (State.Block.hash head) (State.Block.hash @@ vblock s "A6")) then if not (Block_hash.equal (State.Block.hash head) (State.Block.hash @@ vblock s "A6")) then
Assert.fail_msg "unexpected head" ; Assert.fail_msg "unexpected head" ;
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -360,7 +360,7 @@ let test_mem s =
test_mem s "B1" >>= fun () -> test_mem s "B1" >>= fun () ->
test_mem s "B6" >>= fun () -> test_mem s "B6" >>= fun () ->
test_mem s "B8" >>= fun () -> test_mem s "B8" >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)
@ -388,7 +388,7 @@ let test_new_blocks s =
test s "A6" "A6" "A6" [] >>= fun () -> test s "A6" "A6" "A6" [] >>= fun () ->
test s "A8" "A6" "A6" ["A7";"A8"] >>= fun () -> test s "A8" "A6" "A6" ["A7";"A8"] >>= fun () ->
test s "A8" "B7" "A3" ["A4";"A5";"A6";"A7";"A8"] >>= fun () -> test s "A8" "B7" "A3" ["A4";"A5";"A6";"A7";"A8"] >>= fun () ->
return () return_unit
(****************************************************************************) (****************************************************************************)

View File

@ -265,7 +265,7 @@ module Make
List.iter (fun (_, ring) -> Ring.clear ring) w.event_log ; List.iter (fun (_, ring) -> Ring.clear ring) w.event_log ;
Lwt_unix.sleep (w.limits.zombie_lifetime -. w.limits.zombie_memory) >>= fun () -> Lwt_unix.sleep (w.limits.zombie_lifetime -. w.limits.zombie_memory) >>= fun () ->
Hashtbl.remove w.table.zombies w.id ; Hashtbl.remove w.table.zombies w.id ;
Lwt.return ()) ; Lwt.return_unit) ;
Lwt.return_unit in Lwt.return_unit in
let rec loop () = let rec loop () =
begin begin
@ -286,7 +286,7 @@ module Make
w.current_request <- None ; w.current_request <- None ;
Handlers.on_completion w Handlers.on_completion w
request res Worker_types.{ pushed ; treated ; completed } >>= fun () -> request res Worker_types.{ pushed ; treated ; completed } >>= fun () ->
return () return_unit
| Some u -> | Some u ->
Handlers.on_request w request >>= fun res -> Handlers.on_request w request >>= fun res ->
Lwt.wakeup_later u res ; Lwt.wakeup_later u res ;
@ -295,7 +295,7 @@ module Make
w.current_request <- None ; w.current_request <- None ;
Handlers.on_completion w Handlers.on_completion w
request res Worker_types.{ pushed ; treated ; completed } >>= fun () -> request res Worker_types.{ pushed ; treated ; completed } >>= fun () ->
return () return_unit
end >>= function end >>= function
| Ok () -> | Ok () ->
loop () loop ()

View File

@ -94,10 +94,10 @@ let decrypt_all (cctxt : #Client_context.io_wallet) =
Secret_key.load cctxt >>=? fun sks -> Secret_key.load cctxt >>=? fun sks ->
iter_s begin fun (name, sk_uri) -> iter_s begin fun (name, sk_uri) ->
if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then
return () return_unit
else else
decrypt cctxt ~name sk_uri >>=? fun _ -> decrypt cctxt ~name sk_uri >>=? fun _ ->
return () return_unit
end sks end sks
let rec read_passphrase (cctxt : #Client_context.io) = let rec read_passphrase (cctxt : #Client_context.io) =

View File

@ -254,7 +254,7 @@ let commands =
| [] -> | [] ->
cctxt#message "No device found." >>= fun () -> cctxt#message "No device found." >>= fun () ->
cctxt#message "Make sure a Ledger Nano S is connected and in the Tezos Wallet app." >>= fun () -> cctxt#message "Make sure a Ledger Nano S is connected and in the Tezos Wallet app." >>= fun () ->
return () return_unit
| ledgers -> | ledgers ->
iter_s begin fun { Ledger.device_info = { Hidapi.path ; iter_s begin fun { Ledger.device_info = { Hidapi.path ;
manufacturer_string ; manufacturer_string ;
@ -303,7 +303,7 @@ let commands =
| Ledgerwallet_tezos.Secp256r1 -> "p2") | Ledgerwallet_tezos.Secp256r1 -> "p2")
Signature.Public_key_hash.pp pkh)) Signature.Public_key_hash.pp pkh))
of_curve >>= fun () -> of_curve >>= fun () ->
return () return_unit
end ledgers) ; end ledgers) ;
Clic.command ~group Clic.command ~group
@ -341,7 +341,7 @@ let commands =
Corresponding full public key: %a@]" Corresponding full public key: %a@]"
Signature.Public_key_hash.pp pkh Signature.Public_key_hash.pp pkh
Signature.Public_key.pp pk >>= fun () -> Signature.Public_key.pp pk >>= fun () ->
return () return_unit
) )
] ]

View File

@ -21,14 +21,14 @@ let create () =
let cancelation = Lwt_condition.create () in let cancelation = Lwt_condition.create () in
let cancelation_complete = Lwt_condition.create () in let cancelation_complete = Lwt_condition.create () in
{ cancelation ; cancelation_complete ; { cancelation ; cancelation_complete ;
cancel_hook = (fun () -> Lwt.return ()) ; cancel_hook = (fun () -> Lwt.return_unit) ;
canceling = false ; canceling = false ;
canceled = false ; canceled = false ;
} }
let cancel st = let cancel st =
if st.canceled then if st.canceled then
Lwt.return () Lwt.return_unit
else if st.canceling then else if st.canceling then
Lwt_condition.wait st.cancelation_complete Lwt_condition.wait st.cancelation_complete
else begin else begin
@ -39,7 +39,7 @@ let cancel st =
(fun () -> (fun () ->
st.canceled <- true ; st.canceled <- true ;
Lwt_condition.broadcast st.cancelation_complete () ; Lwt_condition.broadcast st.cancelation_complete () ;
Lwt.return ()) Lwt.return_unit)
end end
let on_cancel st cb = let on_cancel st cb =
@ -47,7 +47,7 @@ let on_cancel st cb =
st.cancel_hook <- (fun () -> hook () >>= cb) st.cancel_hook <- (fun () -> hook () >>= cb)
let cancelation st = let cancelation st =
if st.canceling then Lwt.return () if st.canceling then Lwt.return_unit
else Lwt_condition.wait st.cancelation else Lwt_condition.wait st.cancelation
let canceled st = st.canceling let canceled st = st.canceling

View File

@ -39,7 +39,7 @@ let rec may_run_idle_tasks w =
w.pending_tasks <- [] ; w.pending_tasks <- [] ;
List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ; List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ;
may_run_idle_tasks w ; may_run_idle_tasks w ;
Lwt.return ()) Lwt.return_unit)
let wrap_error f = let wrap_error f =
Lwt.catch Lwt.catch
@ -73,11 +73,11 @@ let when_idle w f =
Lwt.on_cancel t (fun () -> canceled := true) ; Lwt.on_cancel t (fun () -> canceled := true) ;
let f () = let f () =
if !canceled then if !canceled then
Lwt.return () Lwt.return_unit
else else
wrap_error f >>= fun res -> wrap_error f >>= fun res ->
wakeup_error u res ; wakeup_error u res ;
Lwt.return () in Lwt.return_unit in
w.pending_idle <- f :: w.pending_idle ; w.pending_idle <- f :: w.pending_idle ;
may_run_idle_tasks w ; may_run_idle_tasks w ;
t t

View File

@ -60,10 +60,10 @@ let worker name ~run ~cancel =
(fun () -> (fun () ->
Lwt.catch run fail >>= fun () -> Lwt.catch run fail >>= fun () ->
LC.signal stop (); LC.signal stop ();
Lwt.return ()) ; Lwt.return_unit) ;
waiter >>= fun () -> waiter >>= fun () ->
log_info "%s worker ended" name ; log_info "%s worker ended" name ;
Lwt.return () Lwt.return_unit
let rec chop k l = let rec chop k l =
@ -162,6 +162,6 @@ let stable_sort cmp l =
let sort = stable_sort let sort = stable_sort
let unless cond f = let unless cond f =
if cond then Lwt.return () else f () if cond then Lwt.return_unit else f ()

View File

@ -21,7 +21,7 @@ let create_inner
Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ; Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ;
let pid_str = string_of_int @@ Unix.getpid () in let pid_str = string_of_int @@ Unix.getpid () in
Lwt_unix.write_string fd pid_str 0 (String.length pid_str) >>= fun _ -> Lwt_unix.write_string fd pid_str 0 (String.length pid_str) >>= fun _ ->
return () return_unit
end end
let create = create_inner Unix.F_TLOCK let create = create_inner Unix.F_TLOCK

View File

@ -75,7 +75,7 @@ let remove_dir dir =
Lwt_stream.iter_s Lwt_stream.iter_s
(fun file -> (fun file ->
if file = "." || file = ".." then if file = "." || file = ".." then
Lwt.return () Lwt.return_unit
else begin else begin
let file = Filename.concat dir file in let file = Filename.concat dir file in
if Sys.is_directory file if Sys.is_directory file
@ -87,7 +87,7 @@ let remove_dir dir =
if Sys.file_exists dir && Sys.is_directory dir then if Sys.file_exists dir && Sys.is_directory dir then
remove dir remove dir
else else
Lwt.return () Lwt.return_unit
let rec create_dir ?(perm = 0o755) dir = let rec create_dir ?(perm = 0o755) dir =
Lwt_unix.file_exists dir >>= function Lwt_unix.file_exists dir >>= function
@ -167,7 +167,7 @@ module Json = struct
Lwt_io.with_file ~mode:Output file begin fun chan -> Lwt_io.with_file ~mode:Output file begin fun chan ->
let str = Data_encoding.Json.to_string ~minify:false json in let str = Data_encoding.Json.to_string ~minify:false json in
Lwt_io.write chan str >>= fun _ -> Lwt_io.write chan str >>= fun _ ->
return () return_unit
end end
end end
@ -363,7 +363,7 @@ module Socket = struct
(* we set the beginning of the buf with the length of what is next *) (* we set the beginning of the buf with the length of what is next *)
MBytes.set_int16 buf 0 encoded_message_len ; MBytes.set_int16 buf 0 encoded_message_len ;
write_mbytes fd buf >>= fun () -> write_mbytes fd buf >>= fun () ->
return () return_unit
let recv fd encoding = let recv fd encoding =
let header_buf = MBytes.create message_len_size in let header_buf = MBytes.create message_len_size in
@ -383,7 +383,7 @@ module Socket = struct
end end
let rec retry ?(log=(fun _ -> Lwt.return ())) ?(n=5) ?(sleep=1.) f = let rec retry ?(log=(fun _ -> Lwt.return_unit)) ?(n=5) ?(sleep=1.) f =
f () >>= function f () >>= function
| Ok r -> Lwt.return (Ok r) | Ok r -> Lwt.return (Ok r)
| (Error error) as x -> | (Error error) as x ->

View File

@ -116,7 +116,7 @@ let test_simple { idx ; block2 } =
Assert.equal_string_option (Some "Novembre") (c novembre) ; Assert.equal_string_option (Some "Novembre") (c novembre) ;
get ctxt ["a";"c"] >>= fun juin -> get ctxt ["a";"c"] >>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Lwt.return () Lwt.return_unit
let test_continuation { idx ; block3a } = let test_continuation { idx ; block3a } =
checkout idx block3a >>= function checkout idx block3a >>= function
@ -131,7 +131,7 @@ let test_continuation { idx ; block3a } =
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
get ctxt ["a";"d"] >>= fun mars -> get ctxt ["a";"d"] >>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ; Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
Lwt.return () Lwt.return_unit
let test_fork { idx ; block3b } = let test_fork { idx ; block3b } =
checkout idx block3b >>= function checkout idx block3b >>= function
@ -146,7 +146,7 @@ let test_fork { idx ; block3b } =
Assert.is_none ~msg:__LOC__ (c juin) ; Assert.is_none ~msg:__LOC__ (c juin) ;
get ctxt ["a";"d"] >>= fun mars -> get ctxt ["a";"d"] >>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ; Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
Lwt.return () Lwt.return_unit
let test_replay { idx ; genesis } = let test_replay { idx ; genesis } =
checkout idx genesis >>= function checkout idx genesis >>= function
@ -169,7 +169,7 @@ let test_replay { idx ; genesis } =
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt4b ["a";"d"] >>= fun juillet -> get ctxt4b ["a";"d"] >>= fun juillet ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return () Lwt.return_unit
let fold_keys s k ~init ~f = let fold_keys s k ~init ~f =
let rec loop k acc = let rec loop k acc =
@ -208,7 +208,7 @@ let test_fold { idx ; genesis } =
Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ; Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ;
keys ctxt ["i"] >>= fun l -> keys ctxt ["i"] >>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ; Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return () Lwt.return_unit
(******************************************************************************) (******************************************************************************)

View File

@ -189,7 +189,7 @@ let source_to_keys (wallet : #Proto_alpha.full) ~chain ~block source =
let save_contract ~force cctxt alias_name contract = let save_contract ~force cctxt alias_name contract =
RawContractAlias.add ~force cctxt alias_name contract >>=? fun () -> RawContractAlias.add ~force cctxt alias_name contract >>=? fun () ->
message_added_contract cctxt alias_name >>= fun () -> message_added_contract cctxt alias_name >>= fun () ->
return () return_unit
let originate_contract let originate_contract
(cctxt : #Proto_alpha.full) (cctxt : #Proto_alpha.full)
@ -305,7 +305,7 @@ let inject_activate_operation
begin begin
match confirmations with match confirmations with
| None -> | None ->
return () return_unit
| Some _confirmations -> | Some _confirmations ->
Alpha_services.Contract.balance Alpha_services.Contract.balance
cctxt (`Main, `Head 0) cctxt (`Main, `Head 0)
@ -315,7 +315,7 @@ let inject_activate_operation
Ed25519.Public_key_hash.pp pkh Ed25519.Public_key_hash.pp pkh
Client_proto_args.tez_sym Client_proto_args.tez_sym
Tez.pp balance >>= fun () -> Tez.pp balance >>= fun () ->
return () return_unit
end >>=? fun () -> end >>=? fun () ->
match Apply_operation_result.pack_contents_list op result with match Apply_operation_result.pack_contents_list op result with
| Apply_operation_result.Single_and_result | Apply_operation_result.Single_and_result

View File

@ -141,4 +141,4 @@ let may_check_key sourcePubKey sourcePubKeyHash =
(Ed25519.Public_key.hash sourcePubKey) sourcePubKeyHash) (Ed25519.Public_key.hash sourcePubKey) sourcePubKeyHash)
(failure "Invalid public key in `client_proto_endorsement`") (failure "Invalid public key in `client_proto_endorsement`")
| None -> | None ->
return () return_unit

View File

@ -33,7 +33,7 @@ let print_errors (cctxt : #Client_context.printer) errs ~show_source ~parsed =
~show_source ~show_source
~parsed) errs >>= fun () -> ~parsed) errs >>= fun () ->
cctxt#error "error running script" >>= fun () -> cctxt#error "error running script" >>= fun () ->
return () return_unit
let print_big_map_diff ppf = function let print_big_map_diff ppf = function
| None -> () | None -> ()
@ -60,7 +60,7 @@ let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed = fu
print_expr storage print_expr storage
(Format.pp_print_list Operation_result.pp_internal_operation) operations (Format.pp_print_list Operation_result.pp_internal_operation) operations
print_big_map_diff maybe_diff >>= fun () -> print_big_map_diff maybe_diff >>= fun () ->
return () return_unit
| Error errs -> | Error errs ->
print_errors cctxt errs ~show_source ~parsed print_errors cctxt errs ~show_source ~parsed
@ -74,7 +74,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
(Format.pp_print_list Operation_result.pp_internal_operation) operations (Format.pp_print_list Operation_result.pp_internal_operation) operations
print_big_map_diff maybe_big_map_diff print_big_map_diff maybe_big_map_diff
print_execution_trace trace >>= fun () -> print_execution_trace trace >>= fun () ->
return () return_unit
| Error errs -> | Error errs ->
print_errors cctxt errs ~show_source ~parsed print_errors cctxt errs ~show_source ~parsed
@ -140,7 +140,7 @@ let print_typecheck_result
"(@[<v 0>(types . %a)@ (errors . %a)@])" "(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map) Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs) >>= fun () -> Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
return () return_unit
else else
match res with match res with
| Ok (type_map, gas) -> | Ok (type_map, gas) ->
@ -149,8 +149,8 @@ let print_typecheck_result
Gas.pp gas >>= fun () -> Gas.pp gas >>= fun () ->
if show_types then if show_types then
cctxt#message "%a" Micheline_printer.print_expr program >>= fun () -> cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->
return () return_unit
else return () else return_unit
| Error errs -> | Error errs ->
cctxt#warning "%a" cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors (Michelson_v1_error_reporter.report_errors

View File

@ -321,13 +321,13 @@ let may_patch_limits
| Some contents -> | Some contents ->
simulate cctxt ~chain ~block ?branch contents >>=? fun (_, _, result) -> simulate cctxt ~chain ~block ?branch contents >>=? fun (_, _, result) ->
begin match detect_script_failure result with begin match detect_script_failure result with
| Ok () -> return () | Ok () -> return_unit
| Error _ -> | Error _ ->
cctxt#message cctxt#message
"@[<v 2>This simulation failed:@,%a@]" "@[<v 2>This simulation failed:@,%a@]"
Operation_result.pp_operation_result Operation_result.pp_operation_result
(contents, result.contents) >>= fun () -> (contents, result.contents) >>= fun () ->
return () return_unit
end >>=? fun () -> end >>=? fun () ->
let res = pack_contents_list contents result.contents in let res = pack_contents_list contents result.contents in
patch_list res patch_list res
@ -345,7 +345,7 @@ let inject_operation
preapply cctxt ~chain ~block preapply cctxt ~chain ~block
?branch ?src_sk contents >>=? fun (_oph, op, result) -> ?branch ?src_sk contents >>=? fun (_oph, op, result) ->
begin match detect_script_failure result with begin match detect_script_failure result with
| Ok () -> return () | Ok () -> return_unit
| Error _ as res -> | Error _ as res ->
cctxt#message cctxt#message
"@[<v 2>This simulation failed:@,%a@]" "@[<v 2>This simulation failed:@,%a@]"

View File

@ -73,7 +73,7 @@ let commands () =
then cctxt#message "%Ld" (Time.to_seconds v) then cctxt#message "%Ld" (Time.to_seconds v)
else cctxt#message "%s" (Time.to_notation v) else cctxt#message "%s" (Time.to_notation v)
end >>= fun () -> end >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Lists all non empty contracts of the block." command ~group ~desc: "Lists all non empty contracts of the block."
@ -85,7 +85,7 @@ let commands () =
Lwt_list.iter_s Lwt_list.iter_s
(fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias)
contracts >>= fun () -> contracts >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Get the balance of a contract." command ~group ~desc: "Get the balance of a contract."
@ -98,7 +98,7 @@ let commands () =
~chain:`Main ~block:cctxt#block ~chain:`Main ~block:cctxt#block
contract >>=? fun amount -> contract >>=? fun amount ->
cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () -> cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Get the storage of a contract." command ~group ~desc: "Get the storage of a contract."
@ -114,7 +114,7 @@ let commands () =
cctxt#error "This is not a smart contract." cctxt#error "This is not a smart contract."
| Some storage -> | Some storage ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () -> cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Get the manager of a contract." command ~group ~desc: "Get the manager of a contract."
@ -130,7 +130,7 @@ let commands () =
Public_key_hash.to_source manager >>=? fun m -> Public_key_hash.to_source manager >>=? fun m ->
cctxt#message "%s (%s)" m cctxt#message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () -> (match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Get the delegate of a contract." command ~group ~desc: "Get the delegate of a contract."
@ -144,13 +144,13 @@ let commands () =
contract >>=? function contract >>=? function
| None -> | None ->
cctxt#message "none" >>= fun () -> cctxt#message "none" >>= fun () ->
return () return_unit
| Some delegate -> | Some delegate ->
Public_key_hash.rev_find cctxt delegate >>=? fun mn -> Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
Public_key_hash.to_source delegate >>=? fun m -> Public_key_hash.to_source delegate >>=? fun m ->
cctxt#message "%s (%s)" m cctxt#message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () -> (match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Set the delegate of a contract." command ~group ~desc: "Set the delegate of a contract."
@ -169,7 +169,7 @@ let commands () =
~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations
~dry_run ~dry_run
contract (Some delegate) ~fee ~src_pk ~manager_sk >>=? fun _ -> contract (Some delegate) ~fee ~src_pk ~manager_sk >>=? fun _ ->
return () return_unit
end ; end ;
command ~group ~desc: "Withdraw the delegate from a contract." command ~group ~desc: "Withdraw the delegate from a contract."
@ -185,7 +185,7 @@ let commands () =
~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations
~dry_run ~dry_run
contract None ~fee ~src_pk ~manager_sk >>=? fun _ -> contract None ~fee ~src_pk ~manager_sk >>=? fun _ ->
return () return_unit
end ; end ;
command ~group ~desc:"Open a new account." command ~group ~desc:"Open a new account."
@ -215,10 +215,10 @@ let commands () =
~fee ?delegate ~delegatable ~manager_pkh ~balance ~fee ?delegate ~delegatable ~manager_pkh ~balance
~source ~src_pk ~src_sk () >>=? fun (_res, contract) -> ~source ~src_pk ~src_sk () >>=? fun (_res, contract) ->
if dry_run then if dry_run then
return () return_unit
else else
save_contract ~force cctxt alias_name contract >>=? fun () -> save_contract ~force cctxt alias_name contract >>=? fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Launch a smart contract on the blockchain." command ~group ~desc: "Launch a smart contract on the blockchain."
@ -256,13 +256,13 @@ let commands () =
~fee ?gas_limit ?storage_limit ~delegate ~delegatable ~spendable ~initial_storage ~fee ?gas_limit ?storage_limit ~delegate ~delegatable ~spendable ~initial_storage
~manager ~balance ~source ~src_pk ~src_sk ~code () >>= fun errors -> ~manager ~balance ~source ~src_pk ~src_sk ~code () >>= fun errors ->
report_michelson_errors ~no_print_source ~msg:"origination simulation failed" cctxt errors >>= function report_michelson_errors ~no_print_source ~msg:"origination simulation failed" cctxt errors >>= function
| None -> return () | None -> return_unit
| Some (_res, contract) -> | Some (_res, contract) ->
if dry_run then if dry_run then
return () return_unit
else else
save_contract ~force cctxt alias_name contract >>=? fun () -> save_contract ~force cctxt alias_name contract >>=? fun () ->
return () return_unit
end ; end ;
command ~group ~desc: "Transfer tokens / call a smart contract." command ~group ~desc: "Transfer tokens / call a smart contract."
@ -286,9 +286,9 @@ let commands () =
~dry_run ~dry_run
~source ~fee ~src_pk ~src_sk ~destination ~arg ~amount ?gas_limit ?storage_limit () >>= ~source ~fee ~src_pk ~src_sk ~destination ~arg ~amount ?gas_limit ?storage_limit () >>=
report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt >>= function report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt >>= function
| None -> return () | None -> return_unit
| Some (_res, _contracts) -> | Some (_res, _contracts) ->
return () return_unit
end; end;
command ~group ~desc: "Reveal the public key of the contract manager." command ~group ~desc: "Reveal the public key of the contract manager."
@ -304,7 +304,7 @@ let commands () =
reveal cctxt reveal cctxt
~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations
~source ~fee ~src_pk ~src_sk () >>=? fun _res -> ~source ~fee ~src_pk ~src_sk () >>=? fun _res ->
return () return_unit
end; end;
command ~group ~desc: "Register the public key hash as a delegate." command ~group ~desc: "Register the public key hash as a delegate."
@ -320,7 +320,7 @@ let commands () =
~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations
~dry_run ~dry_run
~fee ~manager_sk:src_sk src_pk >>=? fun _res -> ~fee ~manager_sk:src_sk src_pk >>=? fun _res ->
return () return_unit
end; end;
command ~group ~desc:"Register and activate an Alphanet/Zeronet faucet account." command ~group ~desc:"Register and activate an Alphanet/Zeronet faucet account."
@ -349,7 +349,7 @@ let commands () =
activate_account cctxt activate_account cctxt
~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations ~chain:`Main ~block:cctxt#block ?confirmations:cctxt#confirmations
~encrypted ~force key name >>=? fun _res -> ~encrypted ~force key name >>=? fun _res ->
return () return_unit
); );
command ~group ~desc:"Activate a fundraiser account." command ~group ~desc:"Activate a fundraiser account."
@ -368,7 +368,7 @@ let commands () =
~block:cctxt#block ?confirmations:cctxt#confirmations ~block:cctxt#block ?confirmations:cctxt#confirmations
~dry_run ~dry_run
name code >>=? fun _res -> name code >>=? fun _res ->
return () return_unit
); );
command ~desc:"Wait until an operation is included in a block" command ~desc:"Wait until an operation is included in a block"
@ -408,7 +408,7 @@ let commands () =
(failure "check-previous cannot be negative") >>=? fun () -> (failure "check-previous cannot be negative") >>=? fun () ->
Client_confirmations.wait_for_operation_inclusion ctxt Client_confirmations.wait_for_operation_inclusion ctxt
~chain:`Main ~confirmations ~predecessors operation_hash >>=? fun _ -> ~chain:`Main ~confirmations ~predecessors operation_hash >>=? fun _ ->
return () return_unit
end ; end ;
command ~group:binary_description ~desc:"Describe unsigned block header" command ~group:binary_description ~desc:"Describe unsigned block header"
@ -419,7 +419,7 @@ let commands () =
Data_encoding.Binary_schema.pp Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe (Data_encoding.Binary.describe
(Alpha_context.Block_header.unsigned_encoding)) >>= fun () -> (Alpha_context.Block_header.unsigned_encoding)) >>= fun () ->
return () return_unit
end ; end ;
command ~group:binary_description ~desc:"Describe unsigned block header" command ~group:binary_description ~desc:"Describe unsigned block header"
@ -430,7 +430,7 @@ let commands () =
Data_encoding.Binary_schema.pp Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe (Data_encoding.Binary.describe
Alpha_context.Operation.unsigned_encoding) >>= fun () -> Alpha_context.Operation.unsigned_encoding) >>= fun () ->
return () return_unit
end end
] ]

View File

@ -64,6 +64,6 @@ let commands () =
@@ stop) @@ stop)
(fun () (_, contract) (cctxt : Proto_alpha.full) -> (fun () (_, contract) (cctxt : Proto_alpha.full) ->
cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> cctxt#message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ; return_unit) ;
] ]

View File

@ -91,7 +91,7 @@ let commands () =
(fun () (cctxt : Proto_alpha.full) -> (fun () (cctxt : Proto_alpha.full) ->
Program.load cctxt >>=? fun list -> Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () ->
return ()) ; return_unit) ;
command ~group ~desc: "Add a script to the library." command ~group ~desc: "Add a script to the library."
(args1 (Program.force_switch ())) (args1 (Program.force_switch ()))
@ -118,7 +118,7 @@ let commands () =
(fun () (_, program) (cctxt : Proto_alpha.full) -> (fun () (_, program) (cctxt : Proto_alpha.full) ->
Program.to_source program >>=? fun source -> Program.to_source program >>=? fun source ->
cctxt#message "%s\n" source >>= fun () -> cctxt#message "%s\n" source >>= fun () ->
return ()) ; return_unit) ;
command ~group ~desc: "Ask the node to run a script." command ~group ~desc: "Ask the node to run a script."
(args3 trace_stack_switch amount_arg no_print_source_flag) (args3 trace_stack_switch amount_arg no_print_source_flag)
@ -161,7 +161,7 @@ let commands () =
cctxt#message cctxt#message
"(@[<v 0>(types . ())@ (errors . %a)@])" "(@[<v 0>(types . ())@ (errors . %a)@])"
Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> Michelson_v1_emacs.report_errors res_with_errors >>= fun () ->
return () return_unit
| (parsed, errors) -> | (parsed, errors) ->
cctxt#message "%a" cctxt#message "%a"
(fun ppf () -> (fun ppf () ->
@ -188,7 +188,7 @@ let commands () =
| Ok gas -> | Ok gas ->
cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]" cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]"
Proto_alpha.Alpha_context.Gas.pp gas >>= fun () -> Proto_alpha.Alpha_context.Gas.pp gas >>= fun () ->
return () return_unit
| Error errs -> | Error errs ->
cctxt#warning "%a" cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors (Michelson_v1_error_reporter.report_errors
@ -230,7 +230,7 @@ let commands () =
MBytes.pp_hex (Alpha_environment.Raw_hashes.sha256 bytes) MBytes.pp_hex (Alpha_environment.Raw_hashes.sha256 bytes)
MBytes.pp_hex (Alpha_environment.Raw_hashes.sha512 bytes) MBytes.pp_hex (Alpha_environment.Raw_hashes.sha512 bytes)
Proto_alpha.Alpha_context.Gas.pp remaining_gas >>= fun () -> Proto_alpha.Alpha_context.Gas.pp remaining_gas >>= fun () ->
return () return_unit
| Error errs -> | Error errs ->
cctxt#warning "%a" cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors (Michelson_v1_error_reporter.report_errors
@ -253,7 +253,7 @@ let commands () =
(fun () bytes sk cctxt -> (fun () bytes sk cctxt ->
Client_keys.sign cctxt sk bytes >>=? fun signature -> Client_keys.sign cctxt sk bytes >>=? fun signature ->
cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () ->
return ()) ; return_unit) ;
command ~group command ~group
~desc: "Check the signature of a byte sequence as per Michelson \ ~desc: "Check the signature of a byte sequence as per Michelson \
@ -273,10 +273,10 @@ let commands () =
| false -> cctxt#error "invalid signature" | false -> cctxt#error "invalid signature"
| true -> | true ->
if quiet then if quiet then
return () return_unit
else else
cctxt#message "Signature check successfull." >>= fun () -> cctxt#message "Signature check successfull." >>= fun () ->
return () return_unit
) ; ) ;
] ]

View File

@ -94,9 +94,9 @@ let process_endorsements (cctxt : #Proto_alpha.full) state ~chain
| _ -> | _ ->
lwt_log_error "Inconsistent endorsement found %a" lwt_log_error "Inconsistent endorsement found %a"
Operation_hash.pp hash >>= fun () -> Operation_hash.pp hash >>= fun () ->
return () return_unit
) endorsements >>=? fun () -> ) endorsements >>=? fun () ->
return () return_unit
let process_block (cctxt : #Proto_alpha.full) state ~chain (header : Alpha_block_services.block_info) = let process_block (cctxt : #Proto_alpha.full) state ~chain (header : Alpha_block_services.block_info) =
let { Alpha_block_services.hash ; metadata = { protocol_data = { baker ; level = { level } } } } = header in let { Alpha_block_services.hash ; metadata = { protocol_data = { baker ; level = { level } } } } = header in
@ -167,7 +167,7 @@ let endorsements_index = 0
let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; level ; protocol ; next_protocol } = let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; level ; protocol ; next_protocol } =
if Protocol_hash.(protocol <> next_protocol) then if Protocol_hash.(protocol <> next_protocol) then
lwt_log_error "Protocol changing detected. Skipping the block." >>= fun () -> lwt_log_error "Protocol changing detected. Skipping the block." >>= fun () ->
return () return_unit
else else
lwt_debug "Block level : %a" Raw_level.pp level >>= fun () -> lwt_debug "Block level : %a" Raw_level.pp level >>= fun () ->
let chain = `Hash chain_id in let chain = `Hash chain_id in
@ -182,7 +182,7 @@ let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; leve
lwt_log_error "Error while fetching operations in block %a@\n%a" lwt_log_error "Error while fetching operations in block %a@\n%a"
Block_hash.pp_short hash Block_hash.pp_short hash
pp_print_error errs >>= fun () -> pp_print_error errs >>= fun () ->
return () return_unit
end >>=? fun () -> end >>=? fun () ->
(* Processing endorsements *) (* Processing endorsements *)
begin Alpha_block_services.Operations.operations cctxt ~chain ~block () >>= function begin Alpha_block_services.Operations.operations cctxt ~chain ~block () >>= function
@ -190,15 +190,15 @@ let process_new_block (cctxt : #Proto_alpha.full) state { hash ; chain_id ; leve
if List.length operations > endorsements_index then if List.length operations > endorsements_index then
let endorsements = List.nth operations endorsements_index in let endorsements = List.nth operations endorsements_index in
process_endorsements cctxt state ~chain endorsements level process_endorsements cctxt state ~chain endorsements level
else return () else return_unit
| Error errs -> | Error errs ->
lwt_log_error "Error while fetching operations in block %a@\n%a" lwt_log_error "Error while fetching operations in block %a@\n%a"
Block_hash.pp_short hash Block_hash.pp_short hash
pp_print_error errs >>= fun () -> pp_print_error errs >>= fun () ->
return () return_unit
end >>=? fun () -> end >>=? fun () ->
cleanup_old_operations state ; cleanup_old_operations state ;
return () return_unit
let create (cctxt : #Proto_alpha.full) ~preserved_levels valid_blocks_stream = let create (cctxt : #Proto_alpha.full) ~preserved_levels valid_blocks_stream =
@ -225,7 +225,7 @@ let create (cctxt : #Proto_alpha.full) ~preserved_levels valid_blocks_stream =
~cctxt ~cctxt
~stream:valid_blocks_stream ~stream:valid_blocks_stream
~state_maker ~state_maker
~pre_loop:(fun _ _ _ -> return ()) ~pre_loop:(fun _ _ _ -> return_unit)
~compute_timeout:(fun _ -> Lwt_utils.never_ending ()) ~compute_timeout:(fun _ -> Lwt_utils.never_ending ())
~timeout_k:(fun _ _ () -> return ()) ~timeout_k:(fun _ _ () -> return_unit)
~event_k:process_block ~event_k:process_block

View File

@ -39,12 +39,12 @@ let inject_endorsement
let check_endorsement cctxt level pkh = let check_endorsement cctxt level pkh =
State.get cctxt pkh >>=? function State.get cctxt pkh >>=? function
| None -> return () | None -> return_unit
| Some recorded_level -> | Some recorded_level ->
if Raw_level.(level = recorded_level) then if Raw_level.(level = recorded_level) then
Error_monad.failwith "Level %a already endorsed" Raw_level.pp recorded_level Error_monad.failwith "Level %a already endorsed" Raw_level.pp recorded_level
else else
return () return_unit
let previously_endorsed_level cctxt pkh new_lvl = let previously_endorsed_level cctxt pkh new_lvl =
State.get cctxt pkh >>=? function State.get cctxt pkh >>=? function
@ -116,7 +116,7 @@ let endorse_for_delegate cctxt block delegate =
Raw_level.pp level Raw_level.pp level
name name
Operation_hash.pp_short oph >>= fun () -> Operation_hash.pp_short oph >>= fun () ->
return () return_unit
let allowed_to_endorse cctxt bi delegate = let allowed_to_endorse cctxt bi delegate =
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
@ -144,7 +144,7 @@ let prepare_endorsement ~(max_past:int64) () (cctxt : #Proto_alpha.full) state b
if Time.diff (Time.now ()) bi.Client_baking_blocks.timestamp > max_past then if Time.diff (Time.now ()) bi.Client_baking_blocks.timestamp > max_past then
lwt_log_info "Ignore block %a: forged too far the past" lwt_log_info "Ignore block %a: forged too far the past"
Block_hash.pp_short bi.hash >>= fun () -> Block_hash.pp_short bi.hash >>= fun () ->
return () return_unit
else else
lwt_log_info "Received new block %a" lwt_log_info "Received new block %a"
Block_hash.pp_short bi.hash >>= fun () -> Block_hash.pp_short bi.hash >>= fun () ->
@ -158,7 +158,7 @@ let prepare_endorsement ~(max_past:int64) () (cctxt : #Proto_alpha.full) state b
block = bi ; block = bi ;
delegates ; delegates ;
} ; } ;
return () return_unit
let compute_timeout state = let compute_timeout state =
match state.pending with match state.pending with

View File

@ -409,7 +409,7 @@ let compute_timeout { future_slots } =
| (timestamp, _) :: _ -> | (timestamp, _) :: _ ->
match Client_baking_scheduling.sleep_until timestamp with match Client_baking_scheduling.sleep_until timestamp with
| None -> | None ->
Lwt.return () Lwt.return_unit
| Some timeout -> | Some timeout ->
timeout timeout
@ -470,7 +470,7 @@ let insert_block
| [] -> | [] ->
lwt_debug lwt_debug
"Can't compute slots for %a" Block_hash.pp_short bi.hash >>= fun () -> "Can't compute slots for %a" Block_hash.pp_short bi.hash >>= fun () ->
return () return_unit
| (_ :: _) as slots -> | (_ :: _) as slots ->
iter_p iter_p
(fun ((timestamp, (_, _, delegate)) as slot) -> (fun ((timestamp, (_, _, delegate)) as slot) ->
@ -480,7 +480,7 @@ let insert_block
name name
Block_hash.pp_short bi.hash >>= fun () -> Block_hash.pp_short bi.hash >>= fun () ->
state.future_slots <- insert_baking_slot slot state.future_slots ; state.future_slots <- insert_baking_slot slot state.future_slots ;
return () return_unit
) )
slots slots
@ -657,7 +657,7 @@ let record_nonce_hash cctxt block_hash seed_nonce seed_nonce_hash =
Client_baking_nonces.add cctxt block_hash seed_nonce Client_baking_nonces.add cctxt block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") |> trace_exn (Failure "Error while recording block")
else else
return () return_unit
let pp_operation_list_list = let pp_operation_list_list =
Format.pp_print_list Format.pp_print_list
@ -724,12 +724,12 @@ let bake
Raw_level.pp level priority Raw_level.pp level priority
Fitness.pp shell_header.fitness Fitness.pp shell_header.fitness
pp_operation_list_list operations >>= fun () -> pp_operation_list_list operations >>= fun () ->
return () return_unit
end end
| _ -> (* no candidates, or none fit-enough *) | _ -> (* no candidates, or none fit-enough *)
lwt_debug "No valid candidates." >>= fun () -> lwt_debug "No valid candidates." >>= fun () ->
return () return_unit

View File

@ -47,13 +47,13 @@ let bake_block (cctxt : #Proto_alpha.full)
let src_pkh = Signature.Public_key.hash src_pk in let src_pkh = Signature.Public_key.hash src_pk in
Client_baking_forge.State.record cctxt src_pkh level.level >>=? fun () -> Client_baking_forge.State.record cctxt src_pkh level.level >>=? fun () ->
begin match seed_nonce with begin match seed_nonce with
| None -> return () | None -> return_unit
| Some seed_nonce -> | Some seed_nonce ->
Client_baking_nonces.add cctxt block_hash seed_nonce Client_baking_nonces.add cctxt block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") |> trace_exn (Failure "Error while recording block")
end >>=? fun () -> end >>=? fun () ->
cctxt#message "Injected block %a" Block_hash.pp_short block_hash >>= fun () -> cctxt#message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return () return_unit
let endorse_block cctxt delegate = let endorse_block cctxt delegate =
Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) -> Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
@ -61,7 +61,7 @@ let endorse_block cctxt delegate =
cctxt#block ~src_sk src_pk >>=? fun oph -> cctxt#block ~src_sk src_pk >>=? fun oph ->
cctxt#answer "Operation successfully injected in the node." >>= fun () -> cctxt#answer "Operation successfully injected in the node." >>= fun () ->
cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return () return_unit
let get_predecessor_cycle (cctxt : #Client_context.printer) cycle = let get_predecessor_cycle (cctxt : #Client_context.printer) cycle =
match Cycle.pred cycle with match Cycle.pred cycle with
@ -79,7 +79,7 @@ let do_reveal cctxt block blocks =
Client_baking_revelation.forge_seed_nonce_revelation cctxt Client_baking_revelation.forge_seed_nonce_revelation cctxt
block nonces >>=? fun () -> block nonces >>=? fun () ->
Client_baking_nonces.dels cctxt (List.map fst blocks) >>=? fun () -> Client_baking_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
return () return_unit
let reveal_block_nonces (cctxt : #Proto_alpha.full) block_hashes = let reveal_block_nonces (cctxt : #Proto_alpha.full) block_hashes =
Lwt_list.filter_map_p Lwt_list.filter_map_p

View File

@ -29,7 +29,7 @@ let forge_seed_nonce_revelation
| [] -> | [] ->
cctxt#message "No nonce to reveal for block %a" cctxt#message "No nonce to reveal for block %a"
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
return () return_unit
| _ -> | _ ->
inject_seed_nonce_revelation cctxt ~chain block nonces >>=? fun oph -> inject_seed_nonce_revelation cctxt ~chain block nonces >>=? fun oph ->
cctxt#answer cctxt#answer
@ -38,4 +38,4 @@ let forge_seed_nonce_revelation
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
cctxt#answer "@[<v 2>Operation hash are:@ %a@]" cctxt#answer "@[<v 2>Operation hash are:@ %a@]"
(Format.pp_print_list Operation_hash.pp_short) oph >>= fun () -> (Format.pp_print_list Operation_hash.pp_short) oph >>= fun () ->
return () return_unit

View File

@ -77,4 +77,4 @@ let add_operation st ( op : Operation.packed ) =
return { st with state ; rev_operations = op :: st.rev_operations } return { st with state ; rev_operations = op :: st.rev_operations }
let finalize_construction inc = let finalize_construction inc =
Main.finalize_block inc.state >>=? fun _ -> return () Main.finalize_block inc.state >>=? fun _ -> return_unit

View File

@ -14,7 +14,7 @@ module Endorser = struct
cctxt `Main >>=? fun block_stream -> cctxt `Main >>=? fun block_stream ->
Client_baking_endorsement.create cctxt ~delay delegates block_stream >>=? fun () -> Client_baking_endorsement.create cctxt ~delay delegates block_stream >>=? fun () ->
ignore min_date; ignore min_date;
return () return_unit
end end
@ -26,7 +26,7 @@ module Baker = struct
Client_baking_forge.create cctxt Client_baking_forge.create cctxt
?threshold ?max_priority ~context_path delegates block_stream >>=? fun () -> ?threshold ?max_priority ~context_path delegates block_stream >>=? fun () ->
ignore min_date; ignore min_date;
return () return_unit
end end
@ -35,6 +35,6 @@ module Accuser = struct
let run (cctxt : #Proto_alpha.full) ~preserved_levels = let run (cctxt : #Proto_alpha.full) ~preserved_levels =
Client_baking_blocks.monitor_valid_blocks cctxt ~chains:[ `Main ] () >>=? fun valid_blocks_stream -> Client_baking_blocks.monitor_valid_blocks cctxt ~chains:[ `Main ] () >>=? fun valid_blocks_stream ->
Client_baking_denunciation.create cctxt ~preserved_levels valid_blocks_stream >>=? fun () -> Client_baking_denunciation.create cctxt ~preserved_levels valid_blocks_stream >>=? fun () ->
return () return_unit
end end

View File

@ -36,7 +36,7 @@ let no_write_context ?(block = `Head 0) config : #Client_context.full = object
method write : type a. string -> method write : type a. string ->
a -> a ->
a Data_encoding.encoding -> unit Error_monad.tzresult Lwt.t = a Data_encoding.encoding -> unit Error_monad.tzresult Lwt.t =
fun _ _ _ -> return () fun _ _ _ -> return_unit
method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = fun f -> f () method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = fun f -> f ()
method block = block method block = block
method confirmations = None method confirmations = None
@ -614,7 +614,7 @@ let display_level block =
Alpha_block_services.metadata Alpha_block_services.metadata
!rpc_ctxt ~chain:`Main ~block () >>=? fun { protocol_data = { level } } -> !rpc_ctxt ~chain:`Main ~block () >>=? fun { protocol_data = { level } } ->
Format.eprintf "Level: %a@." Level.pp_full level ; Format.eprintf "Level: %a@." Level.pp_full level ;
return () return_unit
let endorsement_security_deposit block = let endorsement_security_deposit block =
Constants_services.all !rpc_ctxt (`Main, block) >>=? fun c -> Constants_services.all !rpc_ctxt (`Main, block) >>=? fun c ->

View File

@ -65,7 +65,7 @@ let test_known_tez_litterals () =
let vs = Tez_repr.of_string s in let vs = Tez_repr.of_string s in
Assert.is_none ~msg:("Unexpected successful parsing of " ^ s) vs) Assert.is_none ~msg:("Unexpected successful parsing of " ^ s) vs)
known_bad_tez_litterals ; known_bad_tez_litterals ;
return () return_unit
let test_random_tez_litterals () = let test_random_tez_litterals () =
for _ = 0 to 100_000 do for _ = 0 to 100_000 do
@ -91,7 +91,7 @@ let test_random_tez_litterals () =
Assert.equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev Assert.equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev
end end
done ; done ;
return () return_unit
open Tezos_micheline open Tezos_micheline
open Micheline open Micheline

View File

@ -50,10 +50,10 @@ let run blkid =
let res = predicate result in let res = predicate result in
Format.eprintf "/%s (%d) -> %B@." (String.concat "/" path) depth res ; Format.eprintf "/%s (%d) -> %B@." (String.concat "/" path) depth res ;
success := !success && res ; success := !success && res ;
return () return_unit
) tests >>=? fun () -> ) tests >>=? fun () ->
if !success then if !success then
return () return_unit
else else
failwith "Error!" failwith "Error!"

View File

@ -90,7 +90,7 @@ let rpc_port = try int_of_string Sys.argv.(2) with _ -> 18400
let change_to_demo_proto () = let change_to_demo_proto () =
init ~exe ~vote:true ~rpc_port () >>=? fun (_node_pid, hash) -> init ~exe ~vote:true ~rpc_port () >>=? fun (_node_pid, hash) ->
run_change_to_demo_proto (`Hash (hash, 0)) Account.bootstrap_accounts >>=? fun _blkh -> run_change_to_demo_proto (`Hash (hash, 0)) Account.bootstrap_accounts >>=? fun _blkh ->
return () return_unit
let tests = [ let tests = [
"change_to_demo_proto", (fun _ -> change_to_demo_proto ()) ; "change_to_demo_proto", (fun _ -> change_to_demo_proto ()) ;

View File

@ -350,13 +350,13 @@ let apply_manager_operation_content :
match script with match script with
| None -> begin | None -> begin
match parameters with match parameters with
| None -> return () | None -> return_unit
| Some arg -> | Some arg ->
Lwt.return (Script.force_decode arg) >>=? fun arg -> Lwt.return (Script.force_decode arg) >>=? fun arg ->
match Micheline.root arg with match Micheline.root arg with
| Prim (_, D_Unit, [], _) -> | Prim (_, D_Unit, [], _) ->
(* Allow [Unit] parameter to non-scripted contracts. *) (* Allow [Unit] parameter to non-scripted contracts. *)
return () return_unit
| _ -> fail (Script_interpreter.Bad_contract_parameter destination) | _ -> fail (Script_interpreter.Bad_contract_parameter destination)
end >>=? fun () -> end >>=? fun () ->
let result = let result =

View File

@ -237,7 +237,7 @@ let check_proof_of_work_stamp ctxt block =
block.Block_header.shell block.Block_header.shell
block.protocol_data.contents block.protocol_data.contents
proof_of_work_threshold then proof_of_work_threshold then
return () return_unit
else else
fail Invalid_stamp fail Invalid_stamp
@ -250,7 +250,7 @@ let check_signature block key =
(shell, contents) in (shell, contents) in
Signature.check ~watermark:Block_header key signature unsigned_header in Signature.check ~watermark:Block_header key signature unsigned_header in
if check_signature key block then if check_signature key block then
return () return_unit
else else
fail (Invalid_block_signature (Block_header.hash block, fail (Invalid_block_signature (Block_header.hash block,
Signature.Public_key.hash key)) Signature.Public_key.hash key))
@ -266,7 +266,7 @@ let check_fitness_gap ctxt (block : Block_header.t) =
if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap)) fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
else else
return () return_unit
let last_of_a_cycle ctxt l = let last_of_a_cycle ctxt l =
Compare.Int32.(Int32.succ l.Level.cycle_position = Compare.Int32.(Int32.succ l.Level.cycle_position =

View File

@ -285,12 +285,12 @@ let exists c contract =
let must_exist c contract = let must_exist c contract =
exists c contract >>=? function exists c contract >>=? function
| true -> return () | true -> return_unit
| false -> fail (Non_existing_contract contract) | false -> fail (Non_existing_contract contract)
let must_be_allocated c contract = let must_be_allocated c contract =
allocated c contract >>=? function allocated c contract >>=? function
| true -> return () | true -> return_unit
| false -> | false ->
match Contract_repr.is_implicit contract with match Contract_repr.is_implicit contract with
| Some pkh -> fail (Empty_implicit_contract pkh) | Some pkh -> fail (Empty_implicit_contract pkh)
@ -315,7 +315,7 @@ let check_counter_increment c contract counter =
Storage.Contract.Counter.get c contract >>=? fun contract_counter -> Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
let expected = Z.succ contract_counter in let expected = Z.succ contract_counter in
if Compare.Z.(expected = counter) if Compare.Z.(expected = counter)
then return () then return_unit
else if Compare.Z.(expected > counter) then else if Compare.Z.(expected > counter) then
fail (Counter_in_the_past (contract, expected, counter)) fail (Counter_in_the_past (contract, expected, counter))
else else

View File

@ -195,11 +195,11 @@ let set_base c is_delegatable contract delegate =
when Signature.Public_key_hash.equal delegate current_delegate -> when Signature.Public_key_hash.equal delegate current_delegate ->
if self_delegation then if self_delegation then
Storage.Contract.Inactive_delegate.mem c contract >>= function Storage.Contract.Inactive_delegate.mem c contract >>= function
| true -> return () | true -> return_unit
| false -> fail Active_delegate | false -> fail Active_delegate
else else
fail Current_delegate fail Current_delegate
| None | Some _ -> return () | None | Some _ -> return_unit
end >>=? fun () -> end >>=? fun () ->
Storage.Contract.Balance.mem c contract >>= fun exists -> Storage.Contract.Balance.mem c contract >>= fun exists ->
fail_when fail_when

View File

@ -491,10 +491,10 @@ module Parse = struct
Lwt.return (parse_operation raw) >>=? fun op -> Lwt.return (parse_operation raw) >>=? fun op ->
begin match check with begin match check with
| Some true -> | Some true ->
return () (* FIXME *) return_unit (* FIXME *)
(* I.check_signature ctxt *) (* I.check_signature ctxt *)
(* op.protocol_data.signature op.shell op.protocol_data.contents *) (* op.protocol_data.signature op.shell op.protocol_data.contents *)
| Some false | None -> return () | Some false | None -> return_unit
end >>|? fun () -> op end >>|? fun () -> op
end operations end operations
end ; end ;

View File

@ -398,7 +398,7 @@ let check_inited ctxt =
| Some bytes -> | Some bytes ->
let s = MBytes.to_string bytes in let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then if Compare.String.(s = version_value) then
return () return_unit
else else
storage_error (Incompatible_protocol_version s) storage_error (Incompatible_protocol_version s)
@ -432,13 +432,13 @@ let prepare ~level ~timestamp ~fitness ctxt =
let check_first_block ctxt = let check_first_block ctxt =
Context.get ctxt version_key >>= function Context.get ctxt version_key >>= function
| None -> return () | None -> return_unit
| Some bytes -> | Some bytes ->
let s = MBytes.to_string bytes in let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then if Compare.String.(s = version_value) then
failwith "Internal error: previously initialized context." failwith "Internal error: previously initialized context."
else if Compare.String.(s = "genesis") then else if Compare.String.(s = "genesis") then
return () return_unit
else else
storage_error (Incompatible_protocol_version s) storage_error (Incompatible_protocol_version s)

View File

@ -730,11 +730,11 @@ let rec interp
logged_return (Item (amount, rest), ctxt) in logged_return (Item (amount, rest), ctxt) in
let stack = (Item (arg, Empty)) in let stack = (Item (arg, Empty)) in
begin match log with begin match log with
| None -> return () | None -> return_unit
| Some log -> | Some log ->
unparse_stack ctxt (stack, code.bef) >>=? fun stack -> unparse_stack ctxt (stack, code.bef) >>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ; log := (code.loc, Gas.level ctxt, stack) :: !log ;
return () return_unit
end >>=? fun () -> end >>=? fun () ->
step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) ->
return (ret, ctxt) return (ret, ctxt)

View File

@ -363,7 +363,7 @@ let unexpected expr exp_kinds exp_ns exp_prims =
let check_kind kinds expr = let check_kind kinds expr =
let kind = kind expr in let kind = kind expr in
if List.mem kind kinds then if List.mem kind kinds then
return () return_unit
else else
let loc = location expr in let loc = location expr in
fail (Invalid_kind (loc, kinds, kind)) fail (Invalid_kind (loc, kinds, kind))
@ -1147,8 +1147,8 @@ let rec parse_data
if Compare.Int.(0 = (compare_comparable key_type value k)) if Compare.Int.(0 = (compare_comparable key_type value k))
then fail (Duplicate_map_keys (loc, strip_locations expr)) then fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr)) else fail (Unordered_map_keys (loc, strip_locations expr))
else return () else return_unit
| None -> return () | None -> return_unit
end >>=? fun () -> end >>=? fun () ->
return (Some k, map_update k (Some (item_wrapper v)) map, ctxt) return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
| Prim (loc, D_Elt, l, _) -> | Prim (loc, D_Elt, l, _) ->
@ -1403,8 +1403,8 @@ let rec parse_data
if Compare.Int.(0 = (compare_comparable t value v)) if Compare.Int.(0 = (compare_comparable t value v))
then fail (Duplicate_set_values (loc, strip_locations expr)) then fail (Duplicate_set_values (loc, strip_locations expr))
else fail (Unordered_set_values (loc, strip_locations expr)) else fail (Unordered_set_values (loc, strip_locations expr))
else return () else return_unit
| None -> return () | None -> return_unit
end >>=? fun () -> end >>=? fun () ->
Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt ->
return (Some v, set_update v true set, ctxt)) return (Some v, set_update v true set, ctxt))

View File

@ -173,7 +173,7 @@ type _ opt_handler =
let rec combine_object = function let rec combine_object = function
| [] -> Handler { encoding = Data_encoding.unit ; | [] -> Handler { encoding = Data_encoding.unit ;
get = fun _ _ -> return () } get = fun _ _ -> return_unit }
| (name, Opt_handler handler) :: fields -> | (name, Opt_handler handler) :: fields ->
let Handler handlers = combine_object fields in let Handler handlers = combine_object fields in
Handler { encoding = Handler { encoding =

View File

@ -168,7 +168,7 @@ let activation_init () =
let simple_init_with_commitments () = let simple_init_with_commitments () =
activation_init () >>=? fun (blk, _contracts, _secrets) -> activation_init () >>=? fun (blk, _contracts, _secrets) ->
Block.bake blk >>=? fun _ -> Block.bake blk >>=? fun _ ->
return () return_unit
(** A single activation *) (** A single activation *)
let single_activation () = let single_activation () =
@ -196,7 +196,7 @@ let multi_activation_1 () =
return blk return blk
) blk secrets >>=? fun _ -> ) blk secrets >>=? fun _ ->
return () return_unit
(** All in one bake *) (** All in one bake *)
let multi_activation_2 () = let multi_activation_2 () =

View File

@ -19,7 +19,7 @@ open Test_tez
interpret the other tests that use them. *) interpret the other tests that use them. *)
let expect_error err = function let expect_error err = function
| err0 :: _ when err = err0 -> return () | err0 :: _ when err = err0 -> return_unit
| _ -> failwith "Unexpected successful result" | _ -> failwith "Unexpected successful result"
let expect_alpha_error err = let expect_alpha_error err =
@ -27,13 +27,13 @@ let expect_alpha_error err =
let expect_non_delegatable_contract = function let expect_non_delegatable_contract = function
| Alpha_environment.Ecoproto_error (Delegate_storage.Non_delegatable_contract _) :: _ -> | Alpha_environment.Ecoproto_error (Delegate_storage.Non_delegatable_contract _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "Contract is not delegatable and operation should fail." failwith "Contract is not delegatable and operation should fail."
let expect_no_deletion_pkh pkh = function let expect_no_deletion_pkh pkh = function
| Alpha_environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _ when pkh0 = pkh -> | Alpha_environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _ when pkh0 = pkh ->
return () return_unit
| _ -> | _ ->
failwith "Delegate can not be deleted and operation should fail." failwith "Delegate can not be deleted and operation should fail."
@ -115,7 +115,7 @@ let bootstrap_manager_already_registered_delegate ~fee () =
begin begin
Incremental.add_operation ~expect_failure:(function Incremental.add_operation ~expect_failure:(function
| Alpha_environment.Ecoproto_error Delegate_storage.Active_delegate :: _ -> | Alpha_environment.Ecoproto_error Delegate_storage.Active_delegate :: _ ->
return () return_unit
| _ -> | _ ->
failwith "Delegate is already active and operation should fail.") failwith "Delegate is already active and operation should fail.")
i sec_reg >>=? fun i -> i sec_reg >>=? fun i ->
@ -147,7 +147,7 @@ let delegate_to_bootstrap_by_origination ~fee () =
begin begin
Incremental.add_operation i ~expect_failure:(function Incremental.add_operation i ~expect_failure:(function
| Alpha_environment.Ecoproto_error Contract.Balance_too_low _ :: _ -> | Alpha_environment.Ecoproto_error Contract.Balance_too_low _ :: _ ->
return () return_unit
| _ -> | _ ->
failwith "Not enough balance for origination burn: operation should fail.") failwith "Not enough balance for origination burn: operation should fail.")
op >>=? fun i -> op >>=? fun i ->
@ -307,7 +307,7 @@ Not credited:
let expect_unregistered_key pkh = function let expect_unregistered_key pkh = function
| Alpha_environment.Ecoproto_error Roll_storage.Unregistered_delegate pkh0 :: _ | Alpha_environment.Ecoproto_error Roll_storage.Unregistered_delegate pkh0 :: _
when pkh = pkh0 -> return () when pkh = pkh0 -> return_unit
| _ -> failwith "Delegate key is not registered: operation should fail." | _ -> failwith "Delegate key is not registered: operation should fail."
(* A1: no self-delegation *) (* A1: no self-delegation *)
@ -893,7 +893,7 @@ let double_registration () =
(* credit 1μꜩ+ check balance *) (* credit 1μꜩ+ check balance *)
Op.transaction (I i) bootstrap impl_contract (Tez.one_mutez) >>=? fun create_contract -> Op.transaction (I i) bootstrap impl_contract (Tez.one_mutez) >>=? fun create_contract ->
Incremental.add_operation i create_contract >>=? fun i -> Incremental.add_operation i create_contract >>=? fun i ->
(* return () *) (* return_unit *)
(* self-delegation *) (* self-delegation *)
Op.delegation (I i) impl_contract (Some pkh) >>=? fun self_delegation -> Op.delegation (I i) impl_contract (Some pkh) >>=? fun self_delegation ->
Incremental.add_operation i self_delegation >>=? fun i -> Incremental.add_operation i self_delegation >>=? fun i ->

View File

@ -91,7 +91,7 @@ let same_blocks () =
Assert.proto_error ~loc:__LOC__ res begin function Assert.proto_error ~loc:__LOC__ res begin function
| Apply.Invalid_double_baking_evidence _ -> true | Apply.Invalid_double_baking_evidence _ -> true
| _ -> false end >>=? fun () -> | _ -> false end >>=? fun () ->
return () return_unit
(** Check that a double baking operation exposing two blocks with (** Check that a double baking operation exposing two blocks with
different levels fails *) different levels fails *)

View File

@ -12,7 +12,7 @@ open Proto_alpha
let error ~loc v f = let error ~loc v f =
match v with match v with
| Error err when List.exists f err -> | Error err when List.exists f err ->
return () return_unit
| Ok _ -> | Ok _ ->
failwith "Unexpected successful result (%s)" loc failwith "Unexpected successful result (%s)" loc
| Error err -> | Error err ->
@ -28,13 +28,13 @@ let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
if not (cmp a b) then if not (cmp a b) then
failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b
else else
return () return_unit
let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
if cmp a b then if cmp a b then
failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b
else else
return () return_unit
(* tez *) (* tez *)
let equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) = let equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) =

View File

@ -252,7 +252,7 @@ let genesis
else return acc else return acc
) Tez_repr.zero initial_accounts >>=? fun _ -> ) Tez_repr.zero initial_accounts >>=? fun _ ->
failwith "Insufficient tokens in initial accounts to create one roll" failwith "Insufficient tokens in initial accounts to create one roll"
with Exit -> return () with Exit -> return_unit
end >>=? fun () -> end >>=? fun () ->
let constants : Constants_repr.parametric = { let constants : Constants_repr.parametric = {

View File

@ -132,7 +132,7 @@ let regular () =
Context.get_endorser (B b) >>=? fun (account, _slots) -> Context.get_endorser (B b) >>=? fun (account, _slots) ->
Op.delegation (B b) new_contract (Some account) >>=? fun operation -> Op.delegation (B b) new_contract (Some account) >>=? fun operation ->
Block.bake ~operation b >>=? fun _ -> Block.bake ~operation b >>=? fun _ ->
return () return_unit
(*******************) (*******************)
(** ask source contract to pay a fee when originating a contract *) (** ask source contract to pay a fee when originating a contract *)
@ -141,7 +141,7 @@ let regular () =
let pay_fee () = let pay_fee () =
register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez () >>=? fun (b, contract, new_contract) -> register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez () >>=? fun (b, contract, new_contract) ->
transfer_and_check_balances b new_contract contract (Tez.of_int 2) >>=? fun _ -> transfer_and_check_balances b new_contract contract (Tez.of_int 2) >>=? fun _ ->
return () return_unit
(******************************************************) (******************************************************)
(** Errors *) (** Errors *)
@ -189,7 +189,7 @@ let undelegatable fee () =
begin begin
let expect_failure = function let expect_failure = function
| Alpha_environment.Ecoproto_error (Delegate_storage.Non_delegatable_contract _) :: _ -> | Alpha_environment.Ecoproto_error (Delegate_storage.Non_delegatable_contract _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "The contract is not delegatable, it fails!" failwith "The contract is not delegatable, it fails!"
in in
@ -225,7 +225,7 @@ let credit fee () =
begin begin
let not_enough_money = function let not_enough_money = function
| Alpha_environment.Ecoproto_error (Proto_alpha.Contract_storage.Balance_too_low _) :: _ -> | Alpha_environment.Ecoproto_error (Proto_alpha.Contract_storage.Balance_too_low _) :: _ ->
return () return_unit
| _ -> failwith "The contract does not have enough money, it fails!" | _ -> failwith "The contract does not have enough money, it fails!"
in in
Incremental.add_operation ~expect_failure:not_enough_money i operation >>=? fun i -> Incremental.add_operation ~expect_failure:not_enough_money i operation >>=? fun i ->
@ -259,7 +259,7 @@ let origination_contract_from_origination_contract_not_enough_fund fee () =
Op.origination ~fee (I inc) ~credit:amount contract >>=? fun (operation, orig_contract) -> Op.origination ~fee (I inc) ~credit:amount contract >>=? fun (operation, orig_contract) ->
let expect_failure = function let expect_failure = function
| Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> | Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "The contract has not enough funds, it fails!" failwith "The contract has not enough funds, it fails!"
in in
@ -378,7 +378,6 @@ let origination_contract_from_origination_contract () =
Context.Contract.balance (B b) orig_contract >>=? fun credit0 -> Context.Contract.balance (B b) orig_contract >>=? fun credit0 ->
Assert.equal_tez ~loc:__LOC__ credit0 credit Assert.equal_tez ~loc:__LOC__ credit0 credit
(******************************************************) (******************************************************)
let tests = [ let tests = [

View File

@ -68,7 +68,7 @@ let single_transfer ?fee ?expect_failure amount =
transfer_and_check_balances ~loc:__LOC__ ?fee ?expect_failure transfer_and_check_balances ~loc:__LOC__ ?fee ?expect_failure
b contract_1 contract_2 amount >>=? fun (b,_) -> b contract_1 contract_2 amount >>=? fun (b,_) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** single transfer without fee *) (** single transfer without fee *)
let block_with_a_single_transfer () = let block_with_a_single_transfer () =
@ -79,7 +79,7 @@ let transfer_zero_tez () =
single_transfer ~expect_failure:( single_transfer ~expect_failure:(
function function
| Alpha_environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _ -> | Alpha_environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "Empty transaction should fail") failwith "Empty transaction should fail")
Tez.zero Tez.zero
@ -101,7 +101,7 @@ let block_originate_and_transfer_with_fee () =
Incremental.add_operation b operation >>=? fun b -> Incremental.add_operation b operation >>=? fun b ->
transfer_and_check_balances ~loc:__LOC__ b ~fee:ten_tez contract new_contract ten_tez >>=? fun (b, _) -> transfer_and_check_balances ~loc:__LOC__ b ~fee:ten_tez contract new_contract ten_tez >>=? fun (b, _) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block, and two contracts; (** 1- Create a block, and two contracts;
2- Add a transfer from a current balance of a source contract 2- Add a transfer from a current balance of a source contract
@ -113,7 +113,7 @@ let block_transfer_from_contract_balance () =
Context.Contract.balance (I b) contract_1 >>=? fun balance -> Context.Contract.balance (I b) contract_1 >>=? fun balance ->
transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance >>=? fun (b,_) -> transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance >>=? fun (b,_) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block and a single contract; (** 1- Create a block and a single contract;
2- Add a transfer to a contract itself without fee into this block; 2- Add a transfer to a contract itself without fee into this block;
@ -128,7 +128,7 @@ let block_transfers_without_with_fee_to_self () =
transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee:ten_tez contract ten_tez transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee:ten_tez contract ten_tez
>>=? fun (b, _) -> >>=? fun (b, _) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block, two contracts; (** 1- Create a block, two contracts;
2- Add three transfers into the block; 2- Add three transfers into the block;
@ -140,7 +140,7 @@ let four_transfers_bake_three_transfers () =
n_transactions 3 b contract_1 contract_2 ten_tez >>=? fun b -> n_transactions 3 b contract_1 contract_2 ten_tez >>=? fun b ->
Op.transaction (I b) contract_1 contract_2 ten_tez >>=? fun _ -> Op.transaction (I b) contract_1 contract_2 ten_tez >>=? fun _ ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a contract from a bootstrap contract; (** 1- Create a contract from a bootstrap contract;
2- Create two implicit contracts; 2- Create two implicit contracts;
@ -163,7 +163,7 @@ let transfer_from_implicit_to_implicit_contract () =
transfer_and_check_balances ~loc:__LOC__ ~fee:(Tez.of_int 3) b transfer_and_check_balances ~loc:__LOC__ ~fee:(Tez.of_int 3) b
src dest ten_tez >>=? fun (b, _) -> src dest ten_tez >>=? fun (b, _) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block, contract from bootstrap accounts, contract from originate; (** 1- Create a block, contract from bootstrap accounts, contract from originate;
2- Add a transfer from the bootstract contract into the implicit contract; 2- Add a transfer from the bootstract contract into the implicit contract;
@ -183,7 +183,7 @@ let transfer_from_implicit_to_originated_contract () =
transfer_and_check_balances ~loc:__LOC__ b src new_contract Alpha_context.Tez.one transfer_and_check_balances ~loc:__LOC__ b src new_contract Alpha_context.Tez.one
>>=? fun (b, _) -> >>=? fun (b, _) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block with 2 contracts; (** 1- Create a block with 2 contracts;
2- Originate 2 contracts from the previous ones; 2- Originate 2 contracts from the previous ones;
@ -199,7 +199,7 @@ let transfer_from_originated_to_originated () =
transfer_and_check_balances ~loc:__LOC__ b transfer_and_check_balances ~loc:__LOC__ b
orig_contract_1 orig_contract_2 Alpha_context.Tez.one >>=? fun (b,_) -> orig_contract_1 orig_contract_2 Alpha_context.Tez.one >>=? fun (b,_) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block, an originate contract, an impicit contract, a contract (** 1- Create a block, an originate contract, an impicit contract, a contract
from bootstrap; from bootstrap;
@ -216,7 +216,7 @@ let transfer_from_originated_to_implicit () =
transfer_and_check_balances ~loc:__LOC__ b new_contract src Alpha_context.Tez.one transfer_and_check_balances ~loc:__LOC__ b new_contract src Alpha_context.Tez.one
>>=? fun (b, _) -> >>=? fun (b, _) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** Checking that the sender of a transaction is the actual (** Checking that the sender of a transaction is the actual
manager of the contract. manager of the contract.
@ -231,7 +231,7 @@ let ownership_sender () =
transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one
>>=? fun (b,_) -> >>=? fun (b,_) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(* Slow tests case *) (* Slow tests case *)
@ -240,7 +240,7 @@ let multiple_transfer n ?fee amount =
Incremental.begin_construction b >>=? fun b -> Incremental.begin_construction b >>=? fun b ->
n_transactions n b ?fee contract_1 contract_2 amount >>=? fun b -> n_transactions n b ?fee contract_1 contract_2 amount >>=? fun b ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block with two contracts; (** 1- Create a block with two contracts;
2- Apply 100 transfers. *) 2- Apply 100 transfers. *)
@ -280,7 +280,7 @@ let block_with_multiple_transfers_with_without_fee () =
n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty >>=? fun b -> n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty >>=? fun b ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** 1- Create a block with two contracts; (** 1- Create a block with two contracts;
2- Bake 10 blocks with a transfer each time. *) 2- Bake 10 blocks with a transfer each time. *)
@ -293,7 +293,7 @@ let build_a_chain () =
>>=? fun (b, _) -> >>=? fun (b, _) ->
Incremental.finalize_block b Incremental.finalize_block b
) b (1 -- 10) >>=? fun _ -> ) b (1 -- 10) >>=? fun _ ->
return () return_unit
(*********************************************************************) (*********************************************************************)
(* Expected error test cases *) (* Expected error test cases *)
@ -314,13 +314,13 @@ let balance_too_low fee () =
Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez >>=? fun op -> Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez >>=? fun op ->
let expect_failure = function let expect_failure = function
| Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> | Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "balance too low should fail" failwith "balance too low should fail"
in in
if fee > balance1 then begin if fee > balance1 then begin
Incremental.add_operation ~expect_failure i op >>= fun _res -> Incremental.add_operation ~expect_failure i op >>= fun _res ->
return () return_unit
end end
else begin else begin
Incremental.add_operation ~expect_failure i op >>=? fun i -> Incremental.add_operation ~expect_failure i op >>=? fun i ->
@ -352,7 +352,7 @@ let balance_too_low_two_transfers fee () =
two_third_of_balance >>=? fun operation -> two_third_of_balance >>=? fun operation ->
let expect_failure = function let expect_failure = function
| Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> | Alpha_environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return () return_unit
| _ -> | _ ->
failwith "balance too low should fail" failwith "balance too low should fail"
in in
@ -446,7 +446,7 @@ let random_transfer () =
transfer_and_check_balances ~loc:__LOC__ b source dest amount transfer_and_check_balances ~loc:__LOC__ b source dest amount
end >>=? fun (b,_) -> end >>=? fun (b,_) ->
Incremental.finalize_block b >>=? fun _ -> Incremental.finalize_block b >>=? fun _ ->
return () return_unit
(** Transfer random transactions *) (** Transfer random transactions *)
let random_multi_transactions () = let random_multi_transactions () =

View File

@ -21,17 +21,17 @@ let demo cctxt =
cctxt.message "Calling the 'failing' RPC." >>= fun () -> cctxt.message "Calling the 'failing' RPC." >>= fun () ->
Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function
| Error [Environment.Ecoproto_error [Error.Demo_error 3]] -> | Error [Environment.Ecoproto_error [Error.Demo_error 3]] ->
return () return_unit
| _ -> failwith "..." | _ -> failwith "..."
end >>=? fun () -> end >>=? fun () ->
cctxt.message "Direct call to `demo_error`." >>= fun () -> cctxt.message "Direct call to `demo_error`." >>= fun () ->
begin Error.demo_error 101010 >|= Environment.wrap_error >>= function begin Error.demo_error 101010 >|= Environment.wrap_error >>= function
| Error [Environment.Ecoproto_error [Error.Demo_error 101010]] -> | Error [Environment.Ecoproto_error [Error.Demo_error 101010]] ->
return () return_unit
| _ -> failwith "...." | _ -> failwith "...."
end >>=? fun () -> end >>=? fun () ->
cctxt.answer "All good!" >>= fun () -> cctxt.answer "All good!" >>= fun () ->
return () return_unit
let bake cctxt = let bake cctxt =
Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi -> Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi ->
@ -56,7 +56,7 @@ let bake cctxt =
proto = MBytes.create 0 } >>=? fun bytes -> proto = MBytes.create 0 } >>=? fun bytes ->
Client_node_rpcs.inject_block cctxt.rpc_config ~chain_id:bi.chain_id bytes [] >>=? fun hash -> Client_node_rpcs.inject_block cctxt.rpc_config ~chain_id:bi.chain_id bytes [] >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return () return_unit
let handle_error cctxt = function let handle_error cctxt = function
| Ok res -> | Ok res ->

View File

@ -77,7 +77,7 @@ let commands () =
(Activate { protocol = hash ; fitness ; protocol_parameters }) (Activate { protocol = hash ; fitness ; protocol_parameters })
sk >>=? fun hash -> sk >>=? fun hash ->
cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () -> cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return () return_unit
end ; end ;
command ~desc: "Fork a test protocol" command ~desc: "Fork a test protocol"
@ -94,7 +94,7 @@ let commands () =
delay = Int64.mul 24L 3600L }) delay = Int64.mul 24L 3600L })
sk >>=? fun hash -> sk >>=? fun hash ->
cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () -> cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return () return_unit
end ; end ;
] ]

View File

@ -128,7 +128,7 @@ module Init = struct
| Some version -> | Some version ->
if Compare.String.(version_value <> MBytes.to_string version) then if Compare.String.(version_value <> MBytes.to_string version) then
failwith "Internal error: incompatible protocol version" ; failwith "Internal error: incompatible protocol version" ;
return () return_unit
let tag_first_block ctxt = let tag_first_block ctxt =
Context.get ctxt version_key >>= function Context.get ctxt version_key >>= function