298 lines
9.1 KiB
OCaml
298 lines
9.1 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* Copyright (c) 2014 - 2017. *)
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* *)
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
(* Tezos Command line interface - Local Storage for Configuration *)
|
|
|
|
open Lwt.Infix
|
|
open Cli_entries
|
|
|
|
module type Entity = sig
|
|
type t
|
|
val encoding : t Data_encoding.t
|
|
val of_source :
|
|
Client_commands.context ->
|
|
string -> t tzresult Lwt.t
|
|
val to_source :
|
|
Client_commands.context ->
|
|
t -> string tzresult Lwt.t
|
|
val name : string
|
|
end
|
|
|
|
module type Alias = sig
|
|
type t
|
|
val load :
|
|
Client_commands.context ->
|
|
(string * t) list tzresult Lwt.t
|
|
val find :
|
|
Client_commands.context ->
|
|
string -> t tzresult Lwt.t
|
|
val find_opt :
|
|
Client_commands.context ->
|
|
string -> t option tzresult Lwt.t
|
|
val rev_find :
|
|
Client_commands.context ->
|
|
t -> string option tzresult Lwt.t
|
|
val name :
|
|
Client_commands.context ->
|
|
t -> string tzresult Lwt.t
|
|
val mem :
|
|
Client_commands.context ->
|
|
string -> bool tzresult Lwt.t
|
|
val add :
|
|
Client_commands.context ->
|
|
string -> t -> unit tzresult Lwt.t
|
|
val del :
|
|
Client_commands.context ->
|
|
string -> unit tzresult Lwt.t
|
|
val update :
|
|
Client_commands.context ->
|
|
string -> t -> unit tzresult Lwt.t
|
|
val save :
|
|
Client_commands.context ->
|
|
(string * t) list -> unit tzresult Lwt.t
|
|
val of_source :
|
|
Client_commands.context ->
|
|
string -> t tzresult Lwt.t
|
|
val to_source :
|
|
Client_commands.context ->
|
|
t -> string tzresult Lwt.t
|
|
val alias_param :
|
|
?name:string ->
|
|
?desc:string ->
|
|
('a, Client_commands.context, 'ret) Cli_entries.params ->
|
|
(string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params
|
|
val fresh_alias_param :
|
|
?name:string ->
|
|
?desc:string ->
|
|
('a, Client_commands.context, 'ret) Cli_entries.params ->
|
|
(string -> 'a, Client_commands.context, 'ret) Cli_entries.params
|
|
val source_param :
|
|
?name:string ->
|
|
?desc:string ->
|
|
('a, Client_commands.context, 'ret) Cli_entries.params ->
|
|
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params
|
|
val autocomplete:
|
|
Client_commands.context -> string list tzresult Lwt.t
|
|
end
|
|
|
|
module Alias = functor (Entity : Entity) -> struct
|
|
|
|
open Client_commands
|
|
|
|
let encoding =
|
|
let open Data_encoding in
|
|
list (obj2
|
|
(req "name" string)
|
|
(req "value" Entity.encoding))
|
|
|
|
let dirname cctxt =
|
|
cctxt.config.base_dir
|
|
|
|
let filename cctxt =
|
|
Filename.concat (dirname cctxt) (Entity.name ^ "s")
|
|
|
|
let load cctxt =
|
|
let filename = filename cctxt in
|
|
if not (Sys.file_exists filename) ||
|
|
Unix.(stat filename).st_size = 0 then
|
|
return []
|
|
else
|
|
Data_encoding_ezjsonm.read_file filename
|
|
|> generic_trace
|
|
"couldn't to read the %s alias file" Entity.name >>=? fun json ->
|
|
match Data_encoding.Json.destruct encoding json with
|
|
| exception _ -> (* TODO print_error *)
|
|
failwith "didn't understand the %s alias file" Entity.name
|
|
| list ->
|
|
return list
|
|
|
|
let autocomplete cctxt =
|
|
load cctxt >>= function
|
|
| Error _ -> return []
|
|
| Ok list -> return (List.map fst list)
|
|
|
|
let find_opt cctxt name =
|
|
load cctxt >>=? fun list ->
|
|
try return (Some (List.assoc name list))
|
|
with Not_found -> return None
|
|
|
|
let find cctxt name =
|
|
load cctxt >>=? fun list ->
|
|
try return (List.assoc name list)
|
|
with Not_found ->
|
|
failwith "no %s alias named %s" Entity.name name
|
|
|
|
let rev_find cctxt v =
|
|
load cctxt >>=? fun list ->
|
|
try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
|
|
with Not_found -> return None
|
|
|
|
let mem cctxt name =
|
|
load cctxt >>=? fun list ->
|
|
try
|
|
ignore (List.assoc name list) ;
|
|
return true
|
|
with
|
|
| Not_found -> return false
|
|
|
|
let save cctxt list =
|
|
Lwt.catch
|
|
(fun () ->
|
|
let dirname = dirname cctxt in
|
|
Lwt_utils.create_dir dirname >>= fun () ->
|
|
let filename = filename cctxt in
|
|
let json = Data_encoding.Json.construct encoding list in
|
|
Data_encoding_ezjsonm.write_file filename json)
|
|
(fun exn -> Lwt.return (error_exn exn))
|
|
|> generic_trace "could not write the %s alias file." Entity.name
|
|
|
|
let add cctxt name value =
|
|
let keep = ref false in
|
|
load cctxt >>=? fun list ->
|
|
begin
|
|
if cctxt.config.force then
|
|
return ()
|
|
else
|
|
iter_s (fun (n, v) ->
|
|
if n = name && v = value then begin
|
|
keep := true ;
|
|
cctxt.message
|
|
"The %s alias %s already exists with the same value."
|
|
Entity.name n >>= fun () ->
|
|
return ()
|
|
end else if n = name && v <> value then begin
|
|
failwith
|
|
"another %s is already aliased as %s, \
|
|
use -force true to update"
|
|
Entity.name n
|
|
end else if n <> name && v = value then begin
|
|
failwith
|
|
"this %s is already aliased as %s, \
|
|
use -force true to insert duplicate"
|
|
Entity.name n
|
|
end else begin
|
|
return ()
|
|
end)
|
|
list
|
|
end >>=? fun () ->
|
|
let list = List.filter (fun (n, _) -> n <> name) list in
|
|
let list = (name, value) :: list in
|
|
if !keep then
|
|
return ()
|
|
else
|
|
save cctxt list >>=? fun () ->
|
|
cctxt.Client_commands.message
|
|
"New %s alias '%s' saved." Entity.name name >>= fun () ->
|
|
return ()
|
|
|
|
let del cctxt name =
|
|
load cctxt >>=? fun list ->
|
|
let list = List.filter (fun (n, _) -> n <> name) list in
|
|
save cctxt list
|
|
|
|
let update cctxt name value =
|
|
load cctxt >>=? fun list ->
|
|
let list =
|
|
List.map
|
|
(fun (n, v) -> (n, if n = name then value else v))
|
|
list in
|
|
save cctxt list
|
|
|
|
let save cctxt list =
|
|
save cctxt list >>=? fun () ->
|
|
cctxt.Client_commands.message
|
|
"Successful update of the %s alias file." Entity.name >>= fun () ->
|
|
return ()
|
|
|
|
include Entity
|
|
|
|
let alias_param
|
|
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
|
|
param ~name ~desc
|
|
(parameter (fun cctxt s ->
|
|
find cctxt s >>=? fun v ->
|
|
return (s, v)))
|
|
next
|
|
|
|
let fresh_alias_param
|
|
?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
|
|
param ~name ~desc
|
|
(parameter (fun cctxt s ->
|
|
begin
|
|
load cctxt >>=? fun list ->
|
|
begin
|
|
if cctxt.config.force then
|
|
return ()
|
|
else
|
|
iter_s
|
|
(fun (n, _v) ->
|
|
if n = s then
|
|
Entity.to_source cctxt _v >>=? fun value ->
|
|
failwith
|
|
"@[<v 2>The %s alias %s already exists.@,\
|
|
The current value is %s.@,\
|
|
Use -force true to update@]"
|
|
Entity.name n
|
|
value
|
|
else
|
|
return ())
|
|
list
|
|
end
|
|
end >>=? fun () ->
|
|
return s))
|
|
next
|
|
|
|
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
|
|
let desc =
|
|
desc ^ "\n"
|
|
^ "can be an alias, file or literal (autodetected in this order)\n\
|
|
use 'file:path', 'text:literal' or 'alias:name' to force" in
|
|
param ~name ~desc
|
|
(parameter (fun cctxt s ->
|
|
let read path =
|
|
Lwt.catch
|
|
(fun () ->
|
|
Lwt_io.(with_file ~mode:Input path read) >>= fun content ->
|
|
return content)
|
|
(fun exn ->
|
|
failwith
|
|
"cannot read file (%s)" (Printexc.to_string exn))
|
|
>>=? fun content ->
|
|
of_source cctxt content in
|
|
begin
|
|
match String.split ~limit:1 ':' s with
|
|
| [ "alias" ; alias ]->
|
|
find cctxt alias
|
|
| [ "text" ; text ] ->
|
|
of_source cctxt text
|
|
| [ "file" ; path ] ->
|
|
read path
|
|
| _ ->
|
|
find cctxt s >>= function
|
|
| Ok v -> return v
|
|
| Error a_errs ->
|
|
read s >>= function
|
|
| Ok v -> return v
|
|
| Error r_errs ->
|
|
of_source cctxt s >>= function
|
|
| Ok v -> return v
|
|
| Error s_errs ->
|
|
let all_errs =
|
|
List.flatten [ a_errs ; r_errs ; s_errs ] in
|
|
Lwt.return (Error all_errs)
|
|
end))
|
|
next
|
|
|
|
let name cctxt d =
|
|
rev_find cctxt d >>=? function
|
|
| None -> Entity.to_source cctxt d
|
|
| Some name -> return name
|
|
|
|
end
|