Commit 51981ca7 authored by Seb Mondet's avatar Seb Mondet
Browse files

Merge 'master' into 'sm@add-michokit'

Conflicts fixed:
* `src/lib/experiments.ml`
parents a8f788b2 5f6d05a3
profile=compact
......@@ -5,7 +5,6 @@ module More_fmt = struct
include Fmt
let vertical_box ?indent ppf f = vbox ?indent (fun ppf () -> f ppf) ppf ()
let wrapping_box ?indent ppf f = hvbox ?indent (fun ppf () -> f ppf) ppf ()
let wf ppf fmt =
......@@ -26,8 +25,73 @@ module More_fmt = struct
let long_string ?(max = 30) ppf s =
match String.sub s ~pos:0 ~len:(max - 2) with
| s ->
pf ppf "%S" (s ^ "...")
| exception _ ->
pf ppf "%S" s
| s -> pf ppf "%S" (s ^ "...")
| exception _ -> pf ppf "%S" s
end
module Markup_fmt = struct
(** An alternative experiment. *)
let vertical_box ?indent ppf f =
let open Fmt in
vbox ?indent (fun ppf () -> f ppf) ppf ()
let wrapping_box ?indent ppf f =
let open Fmt in
box ?indent (fun ppf () -> f ppf) ppf ()
type in_par =
[`Text of string | `Highlight of in_par | `Concat of in_par list]
type t =
[ `Par of in_par
| `Itemize of in_par list
| `Raw of string
| `Verbatim of string list ]
let par l : t list =
match l with [one] -> [`Par one] | l -> [`Par (`Concat l)]
let verbatim l = [`Verbatim l]
let verbatim_raw raw = [`Verbatim (String.split ~on:'\n' raw)]
let verbatim_ezjson json =
verbatim_raw (Ezjsonm.value_to_string ~minify:false json)
let t s : in_par list = [`Text s]
let tf fmt = Format.kasprintf t fmt
let hl l : in_par list = [`Highlight (`Concat l)]
let concat l = `Concat l
let hlf fmt = Format.kasprintf (fun s -> hl (t s)) fmt
let itemize l : t list = [`Itemize (List.map l ~f:(fun l -> `Concat l))]
let to_fmt (x : t list) ppf () =
let open Fmt in
let rec pp_in_par ppf = function
| `Text s -> text ppf s
| `Concat l -> List.iter l ~f:(pp_in_par ppf)
| `Highlight s ->
Format.pp_open_tag ppf "prompt" ;
pp_in_par ppf s ;
Format.pp_close_tag ppf ()
in
vertical_box ppf (fun ppf ->
list ~sep:cut
(fun ppf item ->
match item with
| `Par in_par -> wrapping_box ppf (fun ppf -> pp_in_par ppf in_par)
| `Verbatim sl ->
vertical_box ppf (fun ppf ->
string ppf "`````" ;
List.iter sl ~f:(fun l -> cut ppf () ; string ppf l) ;
cut ppf () ;
string ppf "`````" )
| `Itemize l ->
list ~sep:cut
(fun ppf inpar ->
wrapping_box ~indent:2 ppf (fun ppf ->
string ppf "* " ; pp_in_par ppf inpar ) )
ppf l
| `Raw s -> string ppf s )
ppf x )
end
open Tezos_network_sandbox
open Internal_pervasives
module MFmt = Experiments.Markup_fmt
let failf ?attach fmt =
ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt
module Data = struct
type t = Fmt of (Format.formatter -> unit)
let to_string = function
| Fmt f -> Format.asprintf "%a" (fun ppf () -> f ppf) ()
let pp ppf (Fmt f) =
let open Fmt in
box (fun ppf () -> f ppf) ppf ()
let rawf fmt =
Format.kasprintf (fun s -> Fmt (fun ppf -> Fmt.string ppf s)) fmt
let fmt f = Fmt f
let address s = rawf "%s" s
let list_like ~sep ~delimiter l =
Fmt
Fmt.(
fun ppf ->
delimiter
(fun ppf () -> list ~sep (fun ppf (Fmt f) -> f ppf) ppf l)
ppf ())
let tuple l = list_like ~sep:Fmt.comma ~delimiter:Fmt.parens l
let int i = Fmt (fun ppf -> Fmt.int ppf i)
let string = rawf "%S"
let nat d = rawf "%dp" d
let semi_colon = Fmt.(fun ppf () -> string ppf ";" ; sp ppf ())
let list l = list_like ~sep:semi_colon ~delimiter:Fmt.brackets l
let set l =
list_like ~sep:semi_colon l
~delimiter:Fmt.(fun x ppf -> pf ppf "@[<6>(Set [%a]@])" x)
let empty_set = set []
let key_hash s = rawf "%s" s
let key s = rawf "%s" s
let account_key a = Tezos_protocol.Account.pubkey a |> key
let account_key_hash a = Tezos_protocol.Account.pubkey_hash a |> key_hash
let signature s = rawf "%s" s
let bytes s = rawf "0x%s" s
let some s = fmt (fun ppf -> Fmt.pf ppf "@[<5>(Some %a)@]" pp s)
let none = rawf "None"
let typed_none t = rawf "(None : %s)" t
let record l =
list_like ~sep:semi_colon ~delimiter:Fmt.braces
(List.map l ~f:(fun (k, v) ->
fmt Fmt.(fun ppf -> pf ppf "@[<2>%s =@ %a@]" k pp v) ))
end
module Contract = struct
type t = {name: string; paths: string list; main_name: string option}
let make ?(library = []) ?main_name name ~path =
{name; paths= library @ [path]; main_name}
let build_dir state t =
Paths.root state // sprintf "liquidity-build-%s" t.name
let ensure_build_dir state t =
let dir = build_dir state t in
Running_processes.run_successful_cmdf state "mkdir -p %s"
(Filename.quote dir)
>>= fun _ -> return dir
let base_liquidity_command _state t =
sprintf "liquidity %s %s"
(List.map t.paths ~f:Filename.quote |> String.concat ~sep:" ")
(Option.value_map t.main_name ~default:"" ~f:(sprintf "--main %s"))
let michelson state t =
let f = build_dir state t // sprintf "%s.tz" t.name in
ensure_build_dir state t
>>= fun _ ->
Running_processes.run_successful_cmdf state "%s -o %s"
(base_liquidity_command state t)
(Filename.quote f)
>>= fun _ -> return f
let storage_initialization state t ~tezos_node ~storage =
ensure_build_dir state t
>>= fun dir ->
let out = dir // sprintf "%s-initial-storage.tz" t.name in
Running_processes.run_successful_cmdf state
"%s -o %s --tezos-node %s --init-storage %s"
(base_liquidity_command state t)
(Filename.quote out)
(Filename.quote tezos_node)
( List.map storage ~f:(fun item -> Filename.quote (Data.to_string item))
|> String.concat ~sep:" " )
>>= fun _ -> System.read_file state out >>= fun content -> return content
let arguments state t ~entry_point ~data =
Running_processes.run_successful_cmdf state "%s --data %s %s"
(base_liquidity_command state t)
(Filename.quote entry_point)
(Filename.quote (Data.to_string data))
>>= fun res -> return (String.concat ~sep:" " res#out)
let cmdliner_term ~prefix ~name () =
let contract_name = name in
let open Cmdliner in
let open Term in
let flag_name s = sprintf "%s-%s" prefix s in
Arg.(
pure (fun path main_name library ->
make ~library ?main_name ~path contract_name )
$ required
(opt (some non_dir_file) None
(info [flag_name "path"]
~doc:
(sprintf "Path to the liquidity %s contract." contract_name)))
$ value
(opt (some string) None
(info [flag_name "main"]
~doc:
(sprintf "Name of main contract for %s." contract_name)))
$ value
(opt
(list ~sep:',' non_dir_file)
[]
(info [flag_name "library"]
~doc:
(sprintf
"Paths to extra liquidity %s contract-library files."
contract_name))))
end
module On_chain = struct
let tezos_client_keyed_originate_contract ?(force = false)
?(transferring = 0) ?(burn_cap = 0.5) state keyed ~name ~source ~storage
=
let client = keyed.Tezos_client.Keyed.client in
Tezos_client.successful_client_cmd state ~client
( [ "--wait"; "none"; "originate"; "contract"; name; "for"; keyed.key_name
; "transferring"; Int.to_string transferring; "from"; keyed.key_name
; "running"; source; "--init"; storage; "--burn-cap"
; Float.to_string burn_cap ]
@ if force then ["--force"] else [] )
let build_and_deploy ?(burn_cap = 10.1) state contract ~keyed_client ~storage
~balance =
let name = contract.Contract.name in
let tezos_node =
sprintf "http://localhost:%d" keyed_client.Tezos_client.Keyed.client.port
in
Contract.michelson state contract
>>= fun michetz ->
Contract.storage_initialization state contract ~tezos_node
~storage:(List.map storage ~f:snd)
>>= fun init ->
tezos_client_keyed_originate_contract state keyed_client ~name
~transferring:balance ~source:michetz ~storage:init ~burn_cap ~force:true
>>= fun _ ->
Tezos_client.Keyed.bake state keyed_client (sprintf "%s origination" name)
>>= fun () ->
Tezos_client.successful_client_cmd state
~client:keyed_client.Tezos_client.Keyed.client
["show"; "known"; "contract"; name]
>>= fun res ->
let address = String.strip (String.concat ~sep:"" res#out) in
Console.sayf state
MFmt.(
par (t "Deployed " @ hlf "%s" name)
@ itemize [tf "Script: `%s`" michetz; tf "Address: `%s`" address]
@ par (tf "Storage:")
@ itemize
(List.map storage ~f:(fun (name, data) ->
tf "%s:@ %a" name Data.pp data ))
|> to_fmt)
>>= fun () -> return address
(* This should go to flextesa soon... *)
let silent_client_cmd state ~client args =
Running_processes.run_cmdf state "sh -c %s"
( Tezos_client.client_command client ~state args
|> Genspio.Compile.to_one_liner |> Filename.quote )
>>= fun res ->
let success = res#status = Lwt_unix.WEXITED 0 in
return (success, res)
let call ?msg ?(should = `Be_ok) ?(transferring = 0) ?(burn_cap = 0.3) state
contract ~keyed_client ~entry_point ~data =
Contract.arguments state contract ~entry_point ~data
>>= fun low_level_arg ->
silent_client_cmd state ~client:keyed_client.Tezos_client.Keyed.client
[ "--wait"; "none"; "transfer"; Int.to_string transferring; "from"
; keyed_client.key_name; "to"; contract.name; "--burn-cap"
; Float.to_string burn_cap; "--arg"; low_level_arg ]
>>= fun (succeeds, res) ->
( match succeeds with
| false -> (
match should with
| `Fail -> return (`Expected `Failure)
| `Fail_with_re re ->
let intersting_part =
List.drop_while res#err ~f:(fun line ->
String.is_prefix line ~prefix:"script reached FAILWITH" )
|> String.concat ~sep:" "
in
if Re.execp re intersting_part then return (`Expected `Failure)
else return (`Failed `With_error_does_not_match)
| `Be_ok -> return (`Failed `Not_ok) )
| true when should = `Be_ok ->
silent_client_cmd state ~client:keyed_client.client
[ "bake"; "for"; keyed_client.key_name; "--force"
; "--minimal-timestamp" ]
>>= fun (_bake, _) -> return (`Expected `Ok)
| true (* should is no ok *) -> return (`Failed `Unexpected_ok) )
>>= fun test_status ->
let test_full_name =
sprintf "%s#%s%s" contract.name entry_point
(Option.value_map msg ~default:"" ~f:(sprintf " (%s)"))
in
Console.sayf state
MFmt.(
let details =
match test_status with
| `Expected _ -> []
| `Failed _ ->
par (tf "Data:")
@ verbatim [Data.to_string data]
@ par (tf "Std-out:")
@ verbatim res#out
@ par (tf "Std-err:")
@ verbatim res#err
in
par (tf "Test-call %s" test_full_name)
@ itemize
[ ( match test_status with
| `Expected exp ->
hlf "Success: %s"
( match exp with
| `Ok -> "op-baked"
| `Failure -> "expected-failure" )
| `Failed reason ->
hlf "FAILURE: %s"
( match reason with
| `Not_ok -> "Not-OK"
| `Unexpected_ok -> "Should-have-failed"
| `With_error_does_not_match ->
"Error-message-does-not-match" ) ) ]
@ details
|> to_fmt)
>>= fun () ->
match test_status with
| `Expected _ -> return res
| `Failed _ -> failf "Test failed: %s" test_full_name
let key_with_type_json key =
let open Ezjsonm in
match key with
| `Nat n ->
( dict [("int", `String (Int.to_string n))]
, dict [("prim", `String "nat")] )
let big_map_get state ~client ~address ~key =
let post_json =
let open Ezjsonm in
let k, t = key_with_type_json key in
dict [("key", k); ("type", t)] |> to_string ~minify:false
in
Tezos_client.rpc state ~client (`Post post_json)
~path:
(sprintf "/chains/main/blocks/head/context/contracts/%s/big_map_get"
address)
>>= fun json ->
return
(object
method post = post_json
method result = json
end)
let show_contract_command state ~client ~name ~address ~pp_error =
Console.Prompt.unit_and_loop
EF.(wf "Show status of the contract %s." address)
[sprintf "show-%s" name]
(fun _sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"show-contract: %a" pp_error e )
( List.fold ["storage"; "balance"] ~init:(return [])
~f:(fun pm endpoint ->
pm
>>= fun l ->
Tezos_client.rpc state ~client `Get
~path:
(sprintf "/chains/main/blocks/head/context/contracts/%s/%s"
address endpoint)
>>= fun json ->
return
EF.(
desc (wf "/%s" endpoint)
(markdown_verbatim
(Ezjsonm.value_to_string ~minify:false json))
:: l) )
>>= fun l ->
Console.say state
EF.(
desc
(haf "Contract %s@%s" name address)
(list ~sep:"" ~delimiters:("", "") l)) ) )
let big_map_get_command state ~names ~thing ~client ~name ~address
~key_of_string ~pp_error =
Console.Prompt.unit_and_loop
EF.(
wf "Get %s from the big-map of the contract %s@%s." thing name address)
names
(fun sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"%s: %a" (List.hd_exn names) pp_error e )
( match sexps with
| [Sexplib.Sexp.Atom s] ->
key_of_string s
>>= fun key ->
big_map_get state ~client ~address ~key
>>= fun getthing ->
Console.sayf state
MFmt.(
par (tf "Posted:")
@ verbatim_raw getthing#post
@ par (tf "Got:")
@ verbatim_ezjson getthing#result
|> to_fmt)
| _ -> failf "Wrong s-exp command line" ) )
end
open Tezos_network_sandbox
open Internal_pervasives
module Data : sig
type t
val to_string : t -> string
val rawf : ('a, Format.formatter, unit, t) format4 -> 'a
val empty_set : t
val address : string -> t
val tuple : t list -> t
val int : int -> t
val string : string -> t
val nat : int -> t
val list : t list -> t
val set : t list -> t
val key_hash : string -> t
val key : string -> t
val account_key : Tezos_protocol.Account.t -> t
val account_key_hash : Tezos_protocol.Account.t -> t
val signature : string -> t
val bytes : string -> t
val some : t -> t
val none : t
val typed_none : string -> t
val record : (string * t) list -> t
end
module Contract : sig
type t = private {name: string; paths: string list; main_name: string option}
val make :
?library:string list -> ?main_name:string -> string -> path:string -> t
val build_dir : < paths: Paths.t ; .. > -> t -> string
val ensure_build_dir :
< paths: Paths.t ; runner: Running_processes.State.t ; .. >
-> t
-> ( string
, [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] )
Asynchronous_result.t
val base_liquidity_command : 'a -> t -> string
val michelson :
< paths: Paths.t ; runner: Running_processes.State.t ; .. >
-> t
-> ( string
, [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] )
Asynchronous_result.t
val storage_initialization :
< application_name: string
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> t
-> tezos_node:string
-> storage:Data.t list
-> ( string
, [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] )
Asynchronous_result.t
val arguments :
< paths: Paths.t ; runner: Running_processes.State.t ; .. >
-> t
-> entry_point:string
-> data:Data.t
-> ( string
, [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] )
Asynchronous_result.t
val cmdliner_term : prefix:string -> name:string -> unit -> t Cmdliner.Term.t
end
module On_chain : sig
val tezos_client_keyed_originate_contract :
?force:bool
-> ?transferring:int
-> ?burn_cap:float
-> < application_name: string
; console: Console.t
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> Tezos_client.Keyed.t
-> name:string
-> source:string
-> storage:string
-> ( < err: string list ; out: string list ; status: Unix.process_status >
, [> `Client_command_error of string * string list option
| `Lwt_exn of exn ] )
Asynchronous_result.t
val build_and_deploy :
?burn_cap:float
-> < application_name: string
; console: Console.t
; operations_log: Log_recorder.Operations.t
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> Contract.t
-> keyed_client:Tezos_client.Keyed.t
-> storage:(string * Data.t) list
-> balance:int
-> ( string
, [> `Client_command_error of string * string list option
| `Lwt_exn of exn
| `Wrong_status of Process_result.t * string ] )
Asynchronous_result.t
val silent_client_cmd :
< paths: Paths.t ; runner: Running_processes.State.t ; .. >
-> client:Tezos_client.t
-> string list
-> (bool * Process_result.t, [> `Lwt_exn of exn]) Asynchronous_result.t
val call :
?msg:string
-> ?should:[< `Be_ok | `Fail | `Fail_with_re of Re.re > `Be_ok]
-> ?transferring:int
-> ?burn_cap:float
-> < application_name: string
; console: Console.t
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> Contract.t
-> keyed_client:Tezos_client.Keyed.t
-> entry_point:string
-> data:Data.t
-> ( Process_result.t
, [> `Lwt_exn of exn
| `Scenario_error of string
| `Wrong_status of Process_result.t * string ] )
Asynchronous_result.t
val key_with_type_json : [< `Nat of int] -> [> Ezjsonm.t] * [> Ezjsonm.t]
val big_map_get :
< application_name: string
; console: Console.t
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> client:Tezos_client.t
-> address:string
-> key:[< `Nat of int]
-> ( < post: string ; result: Ezjsonm.value >
, [> `Client_command_error of string * string list option
| `Lwt_exn of exn ] )
Asynchronous_result.t
val show_contract_command :
< application_name: string
; console: Console.t
; paths: Paths.t
; runner: Running_processes.State.t
; .. >
-> client:Tezos_client.t
-> name:string
-> address:string
-> pp_error:( Format.formatter
-> [> `Client_command_error of string * string list option
| `Lwt_exn of exn ]
-> unit)
-> Console.Prompt.item