diff --git a/src/Makefile b/src/Makefile index 71327c60c..61b2dbc1f 100644 --- a/src/Makefile +++ b/src/Makefile @@ -491,6 +491,7 @@ CLIENT_LIB_INTFS := \ client/client_generic_rpcs.mli \ client/client_helpers.mli \ client/client_aliases.mli \ + client/client_tags.mli \ client/client_keys.mli \ client/client_protocols.mli \ client/client_blocks.mli \ @@ -503,6 +504,7 @@ CLIENT_LIB_IMPLS := \ client/client_generic_rpcs.ml \ client/client_helpers.ml \ client/client_aliases.ml \ + client/client_tags.ml \ client/client_keys.ml \ client/client_protocols.ml \ client/client_blocks.ml \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 13a142439..efd87354c 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -50,9 +50,15 @@ module type Alias = sig val del : Client_commands.context -> string -> unit Lwt.t + val update : + Client_commands.context -> + string -> t -> unit Lwt.t val save : Client_commands.context -> (string * t) list -> unit Lwt.t + val of_source : + Client_commands.context -> + string -> t Lwt.t val to_source : Client_commands.context -> t -> string Lwt.t @@ -175,6 +181,14 @@ module Alias = functor (Entity : Entity) -> struct 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 diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli index 502ef10f7..eaa8bc50c 100644 --- a/src/client/client_aliases.mli +++ b/src/client/client_aliases.mli @@ -46,9 +46,15 @@ module type Alias = sig val del : Client_commands.context -> string -> unit Lwt.t + val update : + Client_commands.context -> + string -> t -> unit Lwt.t val save : Client_commands.context -> (string * t) list -> unit Lwt.t + val of_source : + Client_commands.context -> + string -> t Lwt.t val to_source : Client_commands.context -> t -> string Lwt.t diff --git a/src/client/client_tags.ml b/src/client/client_tags.ml new file mode 100644 index 000000000..fb82e31a8 --- /dev/null +++ b/src/client/client_tags.ml @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Tag = struct + + type t = string list + + let add tags t = + t :: tags + + let remove tags t = + let rec aux acc = function + | [] -> raise Not_found + | x :: ts when x = t -> (List.rev acc) @ ts + | x :: ts -> aux (x :: acc) ts + in + aux [] tags + + let encoding = + Data_encoding.(list string) + +end + +module type Entity = sig + val name : string +end + +module Tags (Entity : Entity) = struct + + include Client_aliases.Alias (struct + + type t = Tag.t + + let encoding = Tag.encoding + + (* Split a string of tags separated by commas, and possibly spaces *) + let of_source _ tags_str = + let rec aux tags s = + try + let idx = String.index s ',' in + let tag = String.(trim (sub s 0 idx)) in + let tail = String.(sub s (idx + 1) (length s - (idx + 1))) in + aux (tag :: tags) tail + with + | Not_found -> + String.(trim s) :: tags + in + Lwt.return (aux [] tags_str) + + let to_source _ tags = + Lwt.return (String.concat ", " tags) + + let name = Entity.name ^ " tag" + + end) + + let tag_param ?(name = "tag") ?(desc = "list of tags") next = + let desc = + desc ^ "\n" + ^ "can be one or multiple tags separated by commas" in + Cli_entries.param ~name ~desc of_source next + + let rev_find_by_tag cctxt tag = + load cctxt >>= fun tags -> + try return (Some (List.find (fun (_, v) -> List.mem tag v) tags |> fst)) + with Not_found -> return None + + let filter cctxt pred = + load cctxt >>= fun tags -> + return (List.filter pred tags) + + let filter_by_tag cctxt tag = + filter cctxt (fun (_, v) -> List.mem tag v) + +end diff --git a/src/client/client_tags.mli b/src/client/client_tags.mli new file mode 100644 index 000000000..9b85b8556 --- /dev/null +++ b/src/client/client_tags.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Tag : sig + + type t = string list + + val add: t -> string -> t + val remove: t -> string -> t + val encoding: t Data_encoding.t + +end + +module type Entity = sig + val name : string +end + +module Tags (Entity : Entity) : sig + + include Client_aliases.Alias with type t = Tag.t + + val tag_param: + ?name:string -> + ?desc:string -> + ('a, Client_commands.context, unit) Cli_entries.params -> + (Tag.t -> 'a, Client_commands.context, unit) Cli_entries.params + + val rev_find_by_tag: + Client_commands.context -> + string -> + string option tzresult Lwt.t + + val filter: + Client_commands.context -> + (string * t -> bool) -> + (string * t) list tzresult Lwt.t + + val filter_by_tag: + Client_commands.context -> + string -> + (string * t) list tzresult Lwt.t + +end diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 032c2f950..356d18306 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -87,6 +87,10 @@ module ContractAlias = struct end +module Contract_tags = Client_tags.Tags (struct + let name = "contract" + end) + let list_contracts cctxt = (* List contracts *) RawContractAlias.load cctxt >>= fun raw_contracts -> @@ -163,16 +167,16 @@ let commands () = command ~group ~desc: "lists all known contracts" (fixed [ "list" ; "known" ; "contracts" ]) (fun cctxt -> - list_contracts cctxt >>= fun contracts -> - Lwt_list.iter_s (fun (prefix, alias, contract) -> - cctxt.message "%s%s: %s" prefix alias - (Contract.to_b58check contract)) - contracts) ; + list_contracts cctxt >>= fun contracts -> + Lwt_list.iter_s (fun (prefix, alias, contract) -> + cctxt.message "%s%s: %s" prefix alias + (Contract.to_b58check contract)) + contracts) ; command ~group ~desc: "forget all known contracts" (fixed [ "forget" ; "all" ; "contracts" ]) (fun cctxt -> if not cctxt.config.force then - cctxt.Client_commands.error "this can only used with option -force true" + cctxt.Client_commands.error "this can only used with option -force true" else RawContractAlias.save cctxt []) ; command ~group ~desc: "display a contract from the wallet" @@ -181,4 +185,34 @@ let commands () = @@ stop) (fun (_, contract) cctxt -> cctxt.message "%a\n%!" Contract.pp contract) ; + command ~group ~desc: "tag a contract in the wallet" + (prefixes [ "tag" ; "contract" ] + @@ RawContractAlias.alias_param + @@ prefixes [ "with" ] + @@ Contract_tags.tag_param + @@ stop) + (fun (alias, _contract) new_tags cctxt -> + Contract_tags.find_opt cctxt alias >>= fun tags -> + let new_tags = match tags with + | None -> new_tags + | Some tags -> Utils.merge_list2 tags new_tags in + Contract_tags.update cctxt alias new_tags) ; + command ~group ~desc: "remove tag(s) from a contract in the wallet" + (prefixes [ "untag" ; "contract" ] + @@ RawContractAlias.alias_param + @@ prefixes [ "with" ] + @@ Contract_tags.tag_param + @@ stop) + (fun (alias, _contract) new_tags cctxt -> + Contract_tags.find_opt cctxt alias >>= fun tags -> + let new_tags = match tags with + | None -> [] + | Some tags -> + Utils.merge_filter_list2 + ~f:(fun x1 x2 -> match x1, x2 with + | None, None -> assert false + | None, Some _ -> None + | Some t1, Some t2 when t1 = t2 -> None + | Some t1, _ -> Some t1) tags new_tags in + Contract_tags.update cctxt alias new_tags) ; ]