balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'ocp/protocol-db'

Browse Source
This commit is contained in:
Grégoire Henry 2016-11-08 12:53:00 +01:00
commit 5cea09bcb5
32 changed files with 868 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Makefile
View File

@ -315,7 +315,7 @@ proto/embedded_proto_%.cmxa: \
proto/%/TEZOS_PROTOCOL \
$$(wildcard proto/%/*.ml) \
$$(wildcard proto/%/*.mli)
@${TZCOMPILER} --build-dir proto/$*/_tzbuild $@ proto/$*/
@${TZCOMPILER} -static -build-dir proto/$*/_tzbuild $@ proto/$*/
CLIENT_PROTO_INCLUDES := \
utils node/updater node/db node/net node/shell client \
@ -328,7 +328,7 @@ proto/client_embedded_proto_%.cmxa: \
proto/%/TEZOS_PROTOCOL \
$$(wildcard proto/%/*.ml) \
$$(wildcard proto/%/*.mli)
@./${TZCOMPILER} --client --build-dir client/embedded/$*/_tzbuild \
@./${TZCOMPILER} -static -client -build-dir client/embedded/$*/_tzbuild \
$(addprefix -I , ${CLIENT_PROTO_INCLUDES}) \
$@ proto/$*
@ -348,6 +348,7 @@ CLIENT_LIB_INTFS := \
client/client_generic_rpcs.mli \
client/client_aliases.mli \
client/client_keys.mli \
client/client_protocols.mli \
CLIENT_LIB_IMPLS := \
client/client_version.ml \
@ -356,6 +357,7 @@ CLIENT_LIB_IMPLS := \
client/client_generic_rpcs.ml \
client/client_aliases.ml \
client/client_keys.ml \
client/client_protocols.ml \
CLIENT_IMPLS := \
client_main.ml
@ -378,7 +380,7 @@ CLIENT_OBJS := \
${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \
${TZCLIENT}
${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES}
${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db
${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db compiler
${CLIENT_OBJS}: TARGET="(client.cmxa)"
${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils

9
src/client/client_node_rpcs.ml
View File

@ -148,6 +148,8 @@ let inject_block ?(wait = true) ?force block =
call_service0 Services.inject_block (block, wait, force)
let inject_operation ?(wait = true) ?force operation =
call_service0 Services.inject_operation (operation, wait, force)
let inject_protocol ?(wait = true) ?force protocol =
call_service0 Services.inject_protocol (protocol, wait, force)
let describe ?recurse path =
let prefix, arg = RPC.forge_request Services.describe () recurse in
get_json (prefix @ path) arg >>=
@ -209,3 +211,10 @@ module Operations = struct
call_streamed_service0 Services.Operations.list
{ monitor = Some true ; contents }
end
module Protocols = struct
let bytes hash =
call_service1 Services.Protocols.bytes hash ()
let list ?contents () =
call_service0 Services.Protocols.list { contents; monitor = Some false }
end

11
src/client/client_node_rpcs.mli
View File

@ -25,6 +25,8 @@ val inject_block:
Block_hash.t tzresult Lwt.t
val inject_operation:
?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t
val inject_protocol:
?wait:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t
module Blocks : sig
@ -93,6 +95,15 @@ module Operations : sig
(Operation_hash.t * Store.operation option) list Lwt_stream.t Lwt.t
end
module Protocols : sig
val bytes:
Protocol_hash.t -> Store.protocol tzresult Time.timed_data Lwt.t
val list:
?contents:bool -> unit ->
(Protocol_hash.t * Store.protocol option) list Lwt.t
end
val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t
(** Low-level *)

52
src/client/client_protocols.ml Normal file
View File

@ -0,0 +1,52 @@
let commands () =
let open Cli_entries in
let check_dir dn =
if Sys.is_directory dn then Lwt.return dn else Lwt.fail_invalid_arg "not a directory"
in
let check_hash ph = Lwt.wrap1 Protocol_hash.of_b48check ph in
register_group "protocols" "Commands for managing protocols" ;
[
command
~group: "protocols"
~desc: "list known protocols"
(prefixes [ "list" ; "protocols" ] stop)
(fun () ->
Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos ->
List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos
);
command
~group: "protocols"
~desc: "inject a new protocol to the shell database"
(prefixes [ "inject" ; "protocol" ]
@@ param ~name:"directory containing a protocol" ~desc:"" check_dir
@@ stop)
(fun dirname () ->
Lwt.catch
(fun () ->
let proto = Tezos_compiler.Protocol.of_dir dirname in
Client_node_rpcs.inject_protocol proto >>= function
| Ok hash ->
message "Injected protocol %a successfully" Protocol_hash.pp_short hash;
Lwt.return ();
| Error err ->
error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err)
(fun exn ->
error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error [Error_monad.Exn exn])
);
command
~group: "protocols"
~desc: "dump a protocol from the shell database"
(prefixes [ "dump" ; "protocol" ]
@@ param ~name:"protocol hash" ~desc:"" check_hash
@@ stop)
(fun ph () ->
Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with
| Ok proto ->
Updater.extract "" ph proto >|= fun () ->
message "Extracted protocol %a" Protocol_hash.pp_short ph
| Error err ->
error "Error while dumping protocol %a: %a"
Protocol_hash.pp_short ph Error_monad.pp_print_error err);
]

2
src/client/client_protocols.mli Normal file
View File

@ -0,0 +1,2 @@
val commands: unit -> Cli_entries.command list

1
src/client_main.ml
View File

@ -30,6 +30,7 @@ let main () =
let commands =
Client_generic_rpcs.commands @
Client_keys.commands () @
Client_protocols.commands () @
Client_version.commands_for_version version in
Client_config.parse_args ~version
(Cli_entries.usage commands)

120
src/compiler/tezos_compiler.ml
View File

@ -36,11 +36,6 @@ module Backend = struct
end
let backend = (module Backend : Backend_intf.S)
let usage () =
Printf.eprintf
"Usage: %s output.cmxs source_dir [--in-place]\n%!"
Sys.argv.(0)
let warnings = "+a-4-6-7-9-29-40..42-44-45-48"
let warn_error = "-a"
@ -110,47 +105,66 @@ let unlink_object obj =
(** TEZOS_PROTOCOL files *)
module Meta = struct
let name = "TEZOS_PROTOCOL"
let config_file_encoding =
let open Data_encoding in
obj2
(opt "hash" ~description:"Used to force the hash of the protocol" Protocol_hash.encoding)
(req "modules" ~description:"Modules comprising the protocol" (list string))
let hash_wrapper =
let open Config_file in
{ to_raw = (fun h -> Raw.String (Protocol_hash.to_b48check h));
of_raw = (function
| Raw.String h -> begin try
Protocol_hash.of_b48check h
with _ ->
let error oc = Printf.fprintf oc "Invalid Base48Check-encoded SHA256 key %S" h in
raise (Wrong_type error)
end
| _ ->
let error oc =
Printf.fprintf oc "Unexcepted value: should be a Base48Check-encoded SHA256 key." in
raise (Wrong_type error));
}
let to_file dirname ?hash modules =
let open Data_encoding.Json in
let config_file = construct config_file_encoding (hash, modules) in
Utils.write_file ~bin:false (dirname // name) @@ to_string config_file
class protocol_hash_cp =
[Protocol_hash.t] Config_file.cp_custom_type hash_wrapper
let of_file dirname =
let open Data_encoding.Json in
Utils.read_file ~bin:false (dirname // name) |> from_string |> function
| Error err -> Pervasives.failwith err
| Ok json -> destruct config_file_encoding json
end
let to_file file hash modules =
let group = new Config_file.group in
let _ = new protocol_hash_cp ~group ["hash"] hash "" in
let _ =
new Config_file.list_cp Config_file.string_wrappers ~group
["modules"] modules "" in
group#write file
module Protocol = struct
type component = {
name: string;
interface: string option;
implementation: string;
}
let of_file file =
let group = new Config_file.group in
let hash =
new protocol_hash_cp ~group ["hash"]
(Protocol_hash.of_b48check
"TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr")
"" in
let modules =
new Config_file.list_cp Config_file.string_wrappers ~group
["modules"] [] "" in
group#read file;
(hash#get, modules#get)
let component_encoding =
let open Data_encoding in
conv
(fun { name ; interface; implementation } -> (name, interface, implementation))
(fun (name, interface, implementation) -> { name ; interface ; implementation })
(obj3
(req "name" string)
(opt "interface" string)
(req "implementation" string))
type t = component list
let encoding = Data_encoding.list component_encoding
let to_bytes v = Data_encoding.Binary.to_bytes encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let hash proto = Protocol_hash.hash_bytes [to_bytes proto]
let find_component dirname module_name =
let name_lowercase = String.uncapitalize_ascii module_name in
let implementation = dirname // name_lowercase ^ ".ml" in
let interface = implementation ^ "i" in
match Sys.file_exists implementation, Sys.file_exists interface with
| false, _ -> Pervasives.failwith @@ "Not such file: " ^ implementation
| true, false ->
let implementation = Utils.read_file ~bin:false implementation in
{ name = module_name; interface = None; implementation }
| _ ->
let interface = Utils.read_file ~bin:false interface in
let implementation = Utils.read_file ~bin:false implementation in
{ name = module_name; interface = Some interface; implementation }
let of_dir dirname =
let _hash, modules = Meta.of_file dirname in
List.map (find_component dirname) modules
end
(** Semi-generic compilation functions *)
@ -215,11 +229,11 @@ let pack_objects ?(ctxt = "") ?(keep_object = false) output objects =
if not keep_object then at_exit (fun () -> unlink_object output) ;
Warnings.check_fatal ()
let link_shared output objects =
let link_shared ?(static=false) output objects =
Printf.printf "LINK %s\n%!" (Filename.basename output);
Compenv.(readenv Format.err_formatter Before_link);
Compmisc.init_path true;
if Filename.check_suffix output ".cmxa" then
if static then
Asmlibrarian.create_archive objects output
else
Asmlink.link_shared Format.err_formatter objects output;
@ -283,12 +297,14 @@ let main () =
and client = ref false
and build_dir = ref None
and include_dirs = ref [] in
let static = ref false in
let args_spec = [
"--client", Arg.Set client, "TODO" ;
"-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), "TODO" ;
"--build-dir", Arg.String (fun s -> build_dir := Some s), "TODO"] in
let usage_msg = "TODO" in
Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) "TODO" ;
"-static", Arg.Set static, " Build a library (.cmxa)";
"-client", Arg.Set client, " Preserve type equality with concrete node environment (used to embed protocol into the client)" ;
"-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), "path Path for concrete node signatures (used to embed protocol into the client)" ;
"-build-dir", Arg.String (fun s -> build_dir := Some s), "path Reuse build dir (incremental compilation)"] in
let usage_msg = Printf.sprintf "Usage: %s <out> <src>\nOptions are:" Sys.argv.(0) in
Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
let client = !client and include_dirs = !include_dirs in
let output, source_dir =
@ -312,7 +328,11 @@ let main () =
Unix.rmdir sigs_dir ;
if not keep_object then Unix.rmdir build_dir ) ;
let hash, units = Meta.of_file (source_dir // "TEZOS_PROTOCOL") in
let hash, units = Meta.of_file source_dir in
let hash = match hash with
| Some hash -> hash
| None -> Protocol.hash @@ List.map (Protocol.find_component source_dir) units
in
let packname =
if keep_object then
String.capitalize_ascii (Filename.(basename @@ chop_extension output))
@ -439,4 +459,4 @@ let main () =
(* Create the final [cmxs] *)
Clflags.link_everything := true ;
link_shared output [packed_objects; register_object]
link_shared ~static:!static output [packed_objects; register_object]

20
src/compiler/tezos_compiler.mli
View File

@ -10,10 +10,26 @@
(** Low-level part of the [Updater]. *)
module Meta : sig
val to_file: Lwt_io.file_name -> ?hash:Protocol_hash.t -> string list -> unit
val of_file: Lwt_io.file_name -> Protocol_hash.t option * string list
end
val to_file: string -> Protocol_hash.t -> string list -> unit
val of_file: string -> Protocol_hash.t * string list
module Protocol : sig
type component = {
name : string;
interface : string option;
implementation : string;
}
val find_component : Lwt_io.file_name -> string -> component
val component_encoding : component Data_encoding.encoding
type t = component list
val encoding : t Data_encoding.encoding
val to_bytes : t -> MBytes.t
val of_bytes : MBytes.t -> t option
val hash : t -> Hash.Protocol_hash.t
val of_dir : Lwt_io.file_name -> t
end
val main: unit -> unit

2
src/node/db/context.ml
View File

@ -216,7 +216,7 @@ let remove_rec (module View : VIEW) key =
GitStore.FunView.remove_rec View.v (data_key key) >>= fun v ->
Lwt.return (pack (module GitStore) View.s v)
let keys (module View : VIEW) = Store.undefined_key_fn
(*-- Initialisation ----------------------------------------------------------*)

41
src/node/db/db_proxy.ml
View File

@ -23,6 +23,8 @@ module type DISTRIBUTED_DB = sig
val update: t -> key -> value -> bool Lwt.t
val remove: t -> key -> bool Lwt.t
val shutdown: t -> unit Lwt.t
val keys: t -> key list Lwt.t
end
type operation_state = {
@ -106,3 +108,42 @@ module Block =
Persist.MakeImperativeProxy
(Store.Faked_functional_block)
(Block_hash_table) (Block_scheduler)
type protocol_state = {
request_protocols: Protocol_hash.t list -> unit ;
}
module Protocol_scheduler = struct
let name = "protocol_scheduler"
type rdata = Store.net_id
type data = float ref
type state = protocol_state
let init_request _ _ = Lwt.return (ref 0.0)
let request net ~get:_ ~set:_ pendings =
let current_time = Unix.gettimeofday () in
let time = current_time -. (3. +. Random.float 8.) in
let protocols =
List.fold_left
(fun acc (hash, last_request, Store.Net net_id) ->
if !last_request < time then begin
last_request := current_time ;
let prev =
try Block_hash_map.find net_id acc
with Not_found -> [] in
Block_hash_map.add net_id (hash :: prev) acc
end else
acc)
Block_hash_map.empty
pendings in
if Block_hash_map.is_empty protocols then
0.
else begin
Block_hash_map.iter (fun _net_id -> net.request_protocols) protocols ;
1. +. Random.float 4.
end
end
module Protocol =
Persist.MakeImperativeProxy
(Store.Faked_functional_protocol)
(Protocol_hash_table) (Protocol_scheduler)

12
src/node/db/db_proxy.mli
View File

@ -23,6 +23,8 @@ module type DISTRIBUTED_DB = sig
val update: t -> key -> value -> bool Lwt.t
val remove: t -> key -> bool Lwt.t
val shutdown: t -> unit Lwt.t
val keys: t -> key list Lwt.t
end
type operation_state = {
@ -44,3 +46,13 @@ module Block :
and type key := Store.Block.key
and type value := Store.Block.value
and type state := block_state
type protocol_state = {
request_protocols: Protocol_hash.t list -> unit ;
}
module Protocol :
DISTRIBUTED_DB with type store := Store.Protocol.t
and type key := Store.Protocol.key
and type value := Store.Protocol.value
and type state := protocol_state

14
src/node/db/persist.ml
View File

@ -24,6 +24,8 @@ module type STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys : t -> key list Lwt.t
end
module type BYTES_STORE = sig
@ -35,6 +37,8 @@ module type BYTES_STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys : t -> key list Lwt.t
end
module type TYPED_STORE = sig
@ -45,6 +49,8 @@ module type TYPED_STORE = sig
val get: t -> key -> value option Lwt.t
val set: t -> key -> value -> t Lwt.t
val del: t -> key -> t Lwt.t
val keys: t -> key list Lwt.t
end
module type KEY = sig
@ -146,6 +152,7 @@ module MakeBytesStore
let remove_rec s k =
S.remove_rec s (to_path k)
let keys s = S.keys s >|= List.map of_path
end
module MakeTypedStore
@ -167,6 +174,7 @@ module MakeTypedStore
let raw_get = S.get
let keys = S.keys
end
module RawKey = struct
@ -369,6 +377,8 @@ module type IMPERATIVE_PROXY = sig
val fetch: t -> rdata -> Store.key -> Store.value Lwt.t
val pending: t -> Store.key -> bool
val shutdown: t -> unit Lwt.t
val keys: t -> Store.key list Lwt.t
end
module type IMPERATIVE_PROXY_SCHEDULER = sig
@ -457,6 +467,8 @@ module MakeImperativeProxy
let known { store } hash =
use store (fun store -> Store.mem store hash)
let keys { store } = use store Store.keys
let read { store } hash =
use store (fun store -> Store.get store hash)
@ -528,6 +540,8 @@ module MakeImperativeProxy
let shutdown { cancel ; worker } =
cancel () >>= fun () -> worker
let keys { store } =
use store (fun store -> Store.keys store)
end
(*-- Predefined Instances ----------------------------------------------------*)

9
src/node/db/persist.mli
View File

@ -27,6 +27,8 @@ module type STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys : t -> key list Lwt.t
end
(** Projection of OCaml keys of some abstract type to concrete storage
@ -55,6 +57,8 @@ module type BYTES_STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys : t -> key list Lwt.t
end
module MakeBytesStore (S : STORE) (K : KEY) :
@ -82,6 +86,8 @@ module type TYPED_STORE = sig
val get: t -> key -> value option Lwt.t
val set: t -> key -> value -> t Lwt.t
val del: t -> key -> t Lwt.t
val keys: t -> key list Lwt.t (** Not always relevant, BEWARE! *)
end
(** Gives a typed view of a store (values of a given type stored under
@ -91,6 +97,7 @@ end
module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) :
TYPED_STORE with type t = S.t and type key = K.t and type value = C.t
(** {2 Persistent Sets} ******************************************************)
(** Signature of a set as returned by {!MakePersistentSet} *)
@ -194,6 +201,8 @@ module type IMPERATIVE_PROXY = sig
val fetch: t -> rdata -> Store.key -> Store.value Lwt.t
val pending: t -> Store.key -> bool
val shutdown: t -> unit Lwt.t
val keys: t -> Store.key list Lwt.t
end
module type IMPERATIVE_PROXY_SCHEDULER = sig

103
src/node/db/store.ml
View File

@ -92,11 +92,13 @@ type generic_store = FS.t
type block_store = FS.t
type blockchain_store = FS.t
type operation_store = FS.t
type protocol_store = FS.t
type store = {
block: block_store Persist.shared_ref ;
blockchain: blockchain_store Persist.shared_ref ;
operation: operation_store Persist.shared_ref ;
protocol: protocol_store Persist.shared_ref ;
global_store: generic_store Persist.shared_ref ;
net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ;
net_read: net_id -> net_store tzresult Lwt.t ;
@ -126,6 +128,8 @@ module type TYPED_IMPERATIVE_STORE = sig
val get_exn: t -> key -> value Lwt.t
val set: t -> key -> value -> unit Lwt.t
val del: t -> key -> unit Lwt.t
val keys: t -> key list Lwt.t
end
module type IMPERATIVE_STORE = sig
@ -146,6 +150,14 @@ module type KEY = sig
val to_path: t -> string list
end
module type HASHKEY = sig
type t
val to_path: t -> string list
val of_path: string list -> t
val prefix : string list
val length : int
end
module Raw_key = struct
type t = string list
let to_path x = x
@ -187,6 +199,7 @@ module Errors_value = struct
let of_bytes b = Data_encoding.(Binary.of_bytes (list (error_encoding ()))) b
end
let undefined_key_fn = Lwt.fail_invalid_arg "function keys cannot be implemented in this module"
module Make (K : KEY) (V : Persist.VALUE) = struct
type t = FS.t
@ -205,6 +218,8 @@ module Make (K : KEY) (V : Persist.VALUE) = struct
let del t k = FS.del t (K.to_path k)
let list t ks = FS.list t (List.map K.to_path ks)
let remove_rec t k = FS.remove_rec t (K.to_path k)
let keys _t = undefined_key_fn
end
module Data_store : IMPERATIVE_STORE with type t = FS.t =
@ -212,6 +227,7 @@ module Data_store : IMPERATIVE_STORE with type t = FS.t =
include Data_store
(*-- Typed block store under "blocks/" ---------------------------------------*)
type shell_block = {
@ -350,6 +366,7 @@ module Block = struct
let raw_get t k = Raw_block.get t k
let keys _t = undefined_key_fn (** We never list keys here *)
end
module Blockchain_succ_key = struct
@ -484,9 +501,91 @@ module Operation = struct
let to_bytes = Raw_operation_value.to_bytes
let hash op = Operation_hash.hash_bytes [to_bytes op]
let raw_get t k = Raw_operation_data.get t k
let keys _t = undefined_key_fn (** We never list keys here *)
end
(*-- Typed operation store under "protocols/" -------------------------------*)
type protocol = Tezos_compiler.Protocol.t
let protocol_encoding = Tezos_compiler.Protocol.encoding
module Raw_protocol_value = Tezos_compiler.Protocol
module Raw_protocol_key = struct
type t = Protocol_hash.t
let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "contents" ]
end
module Protocol_data = Make (Raw_protocol_key) (Raw_protocol_value)
module Raw_protocol_data = Make (Raw_protocol_key) (Raw_value)
module Protocol_time_key = struct
type t = Protocol_hash.t
let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "discovery_time" ]
end
module Protocol_time = Make (Protocol_time_key) (Time_value)
module Protocol_errors_key = struct
type t = Protocol_hash.t
let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "errors" ]
end
module Protocol_errors = Make (Protocol_errors_key) (Errors_value)
module Protocol = struct
type t = FS.t
type key = Protocol_hash.t
type value = Tezos_compiler.Protocol.t tzresult Time.timed_data
let mem = Protocol_data.mem
let get s k =
Protocol_time.get s k >>= function
| None -> Lwt.return_none
| Some time ->
Protocol_errors.get s k >>= function
| Some exns -> Lwt.return (Some { Time.data = Error exns ; time })
| None ->
Protocol_data.get s k >>= function
| None -> Lwt.return_none
| Some bytes -> Lwt.return (Some { Time.data = Ok bytes ; time })
let get_exn s k =
get s k >>= function
| None -> Lwt.fail Not_found
| Some x -> Lwt.return x
let set s k { Time.data ; time } =
Protocol_time.set s k time >>= fun () ->
match data with
| Ok bytes ->
Protocol_data.set s k bytes >>= fun () ->
Protocol_errors.del s k
| Error exns ->
Protocol_errors.set s k exns >>= fun () ->
Protocol_data.del s k
let del s k =
Protocol_time.del s k >>= fun () ->
Protocol_data.del s k >>= fun () ->
Protocol_errors.del s k
let of_bytes = Raw_protocol_value.of_bytes
let to_bytes = Raw_protocol_value.to_bytes
let hash = Raw_protocol_value.hash
let compare p1 p2 =
Protocol_hash.(compare (hash_bytes [to_bytes p1]) (hash_bytes [to_bytes p2]))
let equal b1 b2 = compare b1 b2 = 0
let raw_get t k = Raw_protocol_data.get t k
let fold s x ~f =
let rec dig i root acc =
if i <= 0 then
f (Protocol_hash.of_path @@ List.tl root) acc
else
FS.list s [root] >>= fun roots ->
Lwt_list.fold_right_s (dig (i - 1)) roots acc
in
dig Protocol_hash.path_len ["protocols"] x
let keys s = fold s [] ~f:(fun k a -> Lwt.return @@ k :: a)
end
(*- Genesis and initialization -----------------------------------------------*)
let genesis_encoding =
@ -620,6 +719,7 @@ let init root =
{ block = Persist.share t ;
blockchain = Persist.share t ;
operation = Persist.share t ;
protocol = Persist.share t ;
global_store = Persist.share t ;
net_init = net_init ~root ;
net_read = net_read ~root ;
@ -638,6 +738,7 @@ end
module Faked_functional_operation = Faked_functional_typed_store (Operation)
module Faked_functional_block = Faked_functional_typed_store (Block)
module Faked_functional_protocol = Faked_functional_typed_store (Protocol)
module Faked_functional_store : Persist.STORE with type t = t
= struct
@ -645,4 +746,6 @@ module Faked_functional_store : Persist.STORE with type t = t
let set s k v = Data_store.set s k v >>= fun () -> Lwt.return s
let del s k = Data_store.del s k >>= fun () -> Lwt.return s
let remove_rec s k = Data_store.remove_rec s k >>= fun () -> Lwt.return s
let keys _s = invalid_arg "function keys not implementable here" (** We never use list here. *)
end

27
src/node/db/store.mli
View File

@ -21,6 +21,7 @@ module type TYPED_IMPERATIVE_STORE = sig
val get_exn: t -> key -> value Lwt.t
val set: t -> key -> value -> unit Lwt.t
val del: t -> key -> unit Lwt.t
val keys: t -> key list Lwt.t
end
module type IMPERATIVE_STORE = sig
@ -39,11 +40,13 @@ type generic_store
type block_store
type blockchain_store
type operation_store
type protocol_store
type store = private {
block: block_store Persist.shared_ref ;
blockchain: blockchain_store Persist.shared_ref ;
operation: operation_store Persist.shared_ref ;
protocol: protocol_store Persist.shared_ref ;
global_store: generic_store Persist.shared_ref ;
net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ;
net_read: net_id -> net_store tzresult Lwt.t ;
@ -70,6 +73,9 @@ val pp_net_id: Format.formatter -> net_id -> unit
(** Open or initialize a store at a given path. *)
val init: string -> store Lwt.t
(** Lwt exn returned when function keys is not implemented *)
val undefined_key_fn : 'a Lwt.t
(** {2 Generic interface} ****************************************************)
(** The generic primitives do work on the direct root, but in a
@ -107,6 +113,9 @@ type block = {
val shell_block_encoding: shell_block Data_encoding.t
val block_encoding: block Data_encoding.t
type protocol = Tezos_compiler.Protocol.t
val protocol_encoding: protocol Data_encoding.t
(** {2 Block and operations store} ********************************************)
module Block : sig
@ -177,6 +186,19 @@ module Operation : sig
end
module Protocol : sig
val of_bytes: MBytes.t -> Tezos_compiler.Protocol.t option
val to_bytes: Tezos_compiler.Protocol.t -> MBytes.t
val hash: Tezos_compiler.Protocol.t -> Protocol_hash.t
include TYPED_IMPERATIVE_STORE
with type t = protocol_store
and type key = Protocol_hash.t
and type value = Tezos_compiler.Protocol.t tzresult Time.timed_data
val raw_get: t -> Protocol_hash.t -> MBytes.t option Lwt.t
end
(**/**) (* For testing only *)
(* module LwtUnixStore : sig *)
@ -198,4 +220,9 @@ module Faked_functional_block :
and type value = Block.value
and type key = Block.key
module Faked_functional_protocol :
Persist.TYPED_STORE with type t = Protocol.t
and type value = Protocol.value
and type key = Protocol.key
module Faked_functional_store : Persist.STORE with type t = t

16
src/node/shell/messages.ml
View File

@ -25,8 +25,8 @@ type message =
| Get_operations of Operation_hash.t list
| Operation of MBytes.t
| Current_protocol of net_id
| Protocol_inventory of Protocol_hash.t
| Get_protocols of Protocol_hash.t list
| Protocol of MBytes.t
let to_frame msg =
@ -54,10 +54,10 @@ let to_frame msg =
| Operation b ->
[ S 2703 ; B b ]
| Current_protocol (Net net_id) ->
[ S 2800 ; bh net_id ]
| Protocol_inventory p ->
[ S 2801 ; ph p ]
| Get_protocols protos ->
[ S 2800 ; F (List.map ph protos) ]
| Protocol p ->
[ S 2801 ; B p ]
let from_frame msg =
@ -82,9 +82,9 @@ let from_frame msg =
Some (Get_operations (List.map oph ops))
| [ S 2703 ; B contents ] -> Some (Operation contents)
| [ S 2800 ; B netid ] -> Some (Current_protocol (net netid))
| [ S 2800 ; F protos ] -> Some (Get_protocols (List.map ph protos))
| [ S 2801 ; p ] -> Some (Protocol_inventory (ph p))
| [ S 2801 ; B contents ] -> Some (Protocol contents)
| _ -> None

5
src/node/shell/messages.mli
View File

@ -22,8 +22,9 @@ type message =
| Get_operations of Operation_hash.t list
| Operation of MBytes.t
| Current_protocol of Store.net_id
| Protocol_inventory of Protocol_hash.t
| Get_protocols of Protocol_hash.t list
| Protocol of MBytes.t
(** Converts a high level message to a network frame *)
val to_frame: message -> Netbits.frame

64
src/node/shell/node.ml
View File

@ -24,6 +24,18 @@ let inject_operation validator ?force bytes =
let hash = Operation_hash.hash_bytes [bytes] in
Lwt.return (hash, t)
let inject_protocol state ?force:_ proto =
let proto_bytes = Store.Protocol.to_bytes proto in
let hash = Protocol_hash.hash_bytes [proto_bytes] in
let validation = Updater.compile hash proto >>= function
| false -> Lwt.fail_with (Format.asprintf "Invalid protocol %a: compilation failed" Protocol_hash.pp_short hash)
| true ->
State.Protocol.store state proto_bytes >>= function
| Ok None -> Lwt.fail_with "Previously registred protocol"
| t -> t >|? ignore |> Lwt.return
in
Lwt.return (hash, validation)
let process_operation state validator bytes =
State.Operation.store state bytes >>= function
| Error _ | Ok None -> Lwt.return_unit
@ -38,6 +50,13 @@ let process_operation state validator bytes =
Prevalidator.register_operation prevalidator hash ;
Lwt.return_unit
let process_protocol state _validator bytes =
State.Protocol.store state bytes >>= function
| Error _ | Ok None -> Lwt.return_unit
| Ok (Some (hash, _proto)) ->
(* TODO: Store only pending protocols... *)
lwt_log_info "process Protocol %a" Protocol_hash.pp_short hash
let process_block state validator bytes =
State.Block.store state bytes >>= function
| Error _ | Ok None -> Lwt.return_unit
@ -144,23 +163,20 @@ let process state validator msg =
process_operation state validator content >>= fun () ->
Lwt.return_nil
| Current_protocol net_id ->
lwt_log_info "process Current_protocol" >>= fun () ->
if not (State.Net.is_active state net_id) then
Lwt.return_nil
else begin
match State.Net.get state net_id with
| Error _ -> Lwt.return_nil
| Ok net ->
State.Net.Blockchain.head net >>= fun head ->
Lwt.return [Protocol_inventory head.protocol_hash]
end
| Get_protocols protos ->
lwt_log_info "process Get_protocols" >>= fun () ->
Lwt_list.map_p (State.Protocol.raw_read state) protos >>= fun protos ->
let cons_protocol acc = function
| Some proto -> Protocol proto :: acc
| None -> acc in
Lwt.return (List.fold_left cons_protocol [] protos)
| Protocol_inventory _ ->
lwt_log_info "process Protocol_inventory" >>= fun () ->
(* TODO... *)
| Protocol content ->
lwt_log_info "process Protocol" >>= fun () ->
process_protocol state validator content >>= fun () ->
Lwt.return_nil
type t = {
state: State.t ;
validator: Validator.worker ;
@ -170,6 +186,8 @@ type t = {
?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t ;
inject_operation:
?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t ;
inject_protocol:
?force:bool -> Store.protocol -> (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t ;
shutdown: unit -> unit Lwt.t ;
}
@ -184,6 +202,11 @@ let request_blocks net _net_id blocks =
For now simply broadcast the request to all our neighbours. *)
P2p.broadcast (Messages.(to_frame (Get_blocks blocks))) net
let request_protocols net protocols =
(* TODO improve the lookup strategy.
For now simply broadcast the request to all our neighbours. *)
P2p.broadcast (Messages.(to_frame (Get_protocols protocols))) net
let init_p2p net_params =
match net_params with
| None ->
@ -200,8 +223,9 @@ let create
lwt_log_info "reading state..." >>= fun () ->
let request_operations = request_operations p2p in
let request_blocks = request_blocks p2p in
let request_protocols = request_protocols p2p in
State.read
~request_operations ~request_blocks
~request_operations ~request_blocks ~request_protocols
~store_root ~context_root ~ttl:(48 * 3600) (* 2 days *)
?patch_context () >>= fun state ->
let validator = Validator.create_worker p2p state in
@ -264,6 +288,7 @@ let create
global_validator ;
inject_block = inject_block state validator ;
inject_operation = inject_operation validator ;
inject_protocol = inject_protocol state ;
shutdown ;
}
@ -310,6 +335,7 @@ module RPC = struct
let inject_block node = node.inject_block
let inject_operation node = node.inject_operation
let inject_protocol node = node.inject_protocol
let raw_block_info node hash =
State.Valid_block.read_exn node.state hash >|= convert
@ -449,6 +475,11 @@ module RPC = struct
State.Net.Mempool.for_block net b >|= fun ops ->
Updater.empty_result, ops
let protocols { state } = State.Protocol.keys state
let protocol_content node hash =
State.Protocol.read node.state hash
let preapply node block ~timestamp ~sort ops =
begin
match block with
@ -539,6 +570,9 @@ module RPC = struct
let operation_watcher node =
State.Operation.create_watcher node.state
let protocol_watcher node =
State.Protocol.create_watcher node.state
let validate node net_id block =
Validator.get node.validator net_id >>=? fun net_v ->
Validator.fetch_block net_v block >>=? fun _ ->

9
src/node/shell/node.mli
View File

@ -29,6 +29,8 @@ module RPC : sig
t -> ?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t
val inject_operation:
t -> ?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t
val inject_protocol:
t -> ?force:bool -> Store.protocol -> (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t
val raw_block_info:
t -> Block_hash.t -> block_info Lwt.t
@ -54,6 +56,13 @@ module RPC : sig
val pending_operations:
t -> block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t
val protocols:
t -> Protocol_hash.t list Lwt.t
val protocol_content:
t -> Protocol_hash.t -> Store.protocol tzresult Time.timed_data option Lwt.t
val protocol_watcher:
t -> (Protocol_hash.t * Store.protocol) Lwt_stream.t * (unit -> unit)
val context_dir:
t -> block -> 'a RPC.directory option Lwt.t

47
src/node/shell/node_rpc.ml
View File

@ -332,6 +332,42 @@ let get_operations node hash () =
| Some bytes -> RPC.Answer.return bytes
| None -> raise Not_found
let list_protocols node {Services.Protocols.monitor; contents} =
let monitor = match monitor with None -> false | Some x -> x in
let include_contents = match contents with None -> false | Some x -> x in
Node.RPC.protocols node >>= fun protocols ->
Lwt_list.map_p
(fun hash ->
if include_contents then
Node.RPC.protocol_content node hash >>= function
| None | Some { Time.data = Error _ } -> Lwt.return (hash, None)
| Some { Time.data = Ok bytes }->
Lwt.return (hash, Some bytes)
else
Lwt.return (hash, None))
protocols >>= fun protocols ->
if not monitor then
RPC.Answer.return protocols
else
let stream, shutdown = Node.RPC.protocol_watcher node in
let first_request = ref true in
let next () =
if not !first_request then
Lwt_stream.get stream >>= function
| None -> Lwt.return_none
| Some (h, op) when include_contents -> Lwt.return (Some [h, Some op])
| Some (h, _) -> Lwt.return (Some [h, None])
else begin
first_request := false ;
Lwt.return (Some protocols)
end in
RPC.Answer.return_stream { next ; shutdown }
let get_protocols node hash () =
Node.RPC.protocol_content node hash >>= function
| Some bytes -> RPC.Answer.return bytes
| None -> raise Not_found
let build_rpc_directory node =
let dir = RPC.empty in
let dir = RPC.register0 dir Services.Blocks.list (list_blocks node) in
@ -351,6 +387,10 @@ let build_rpc_directory node =
RPC.register0 dir Services.Operations.list (list_operations node) in
let dir =
RPC.register1 dir Services.Operations.bytes (get_operations node) in
let dir =
RPC.register0 dir Services.Protocols.list (list_protocols node) in
let dir =
RPC.register1 dir Services.Protocols.bytes (get_protocols node) in
let dir =
let implementation (net_id, pred, time, fitness, operations, header) =
Node.RPC.block_info node (`Head 0) >>= fun bi ->
@ -383,6 +423,13 @@ let build_rpc_directory node =
(if blocking then wait else return ()) >>=? fun () -> return hash
end >>= RPC.Answer.return in
RPC.register0 dir Services.inject_operation implementation in
let dir =
let implementation (proto, blocking, force) =
Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) ->
begin
(if blocking then wait else return ()) >>=? fun () -> return hash
end >>= RPC.Answer.return in
RPC.register0 dir Services.inject_protocol implementation in
let dir =
let implementation () =
RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in

103
src/node/shell/node_rpc_services.ml
View File

@ -383,6 +383,56 @@ module Operations = struct
end
module Protocols = struct
let protocols_arg =
let name = "protocol_id" in
let descr =
"A protocol identifier in hexadecimal." in
let construct = Protocol_hash.to_b48check in
let destruct h =
try Ok (Protocol_hash.of_b48check h)
with _ -> Error "Can't parse hash" in
RPC.Arg.make ~name ~descr ~construct ~destruct ()
let bytes =
RPC.service
~input: empty
~output:
(obj1 (req "data"
(describe ~title: "Tezos protocol"
(Time.timed_encoding @@
RPC.Error.wrap @@
Store.protocol_encoding))))
RPC.Path.(root / "protocols" /: protocols_arg)
type list_param = {
contents: bool option ;
monitor: bool option ;
}
let list_param_encoding =
conv
(fun {contents; monitor} -> (contents, monitor))
(fun (contents, monitor) -> {contents; monitor})
(obj2
(opt "contents" bool)
(opt "monitor" bool))
let list =
RPC.service
~input: list_param_encoding
~output:
(obj1
(req "protocols"
(list
(obj2
(req "hash" Protocol_hash.encoding)
(opt "contents"
(dynamic_size Store.protocol_encoding)))
)))
RPC.Path.(root / "protocols")
end
let forge_block =
RPC.service
~description: "Forge a block header"
@ -480,6 +530,59 @@ let inject_operation =
(obj1 (req "injectedOperation" Operation_hash.encoding)))
RPC.Path.(root / "inject_operation")
let inject_protocol =
let proto =
(list
(obj3
(req "name"
(describe ~title:"OCaml module name"
string))
(opt "interface"
(describe
~description:"Content of the .mli file"
string))
(req "implementation"
(describe
~description:"Content of the .ml file"
string))))
in
let proto_of_rpc =
List.map (fun (name, interface, implementation) ->
{ Tezos_compiler.Protocol.name; interface; implementation })
in
let rpc_of_proto =
List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } ->
(name, interface, implementation))
in
RPC.service
~description:
"Inject a protocol in node. Returns the ID of the protocol."
~input:
(conv
(fun (proto, blocking, force) -> (rpc_of_proto proto, Some blocking, force))
(fun (proto, blocking, force) -> (proto_of_rpc proto, unopt true blocking, force))
(obj3
(req "protocol"
(describe ~title: "Tezos protocol"
proto))
(opt "blocking"
(describe
~description:
"Should the RPC wait for the protocol to be \
validated before to answer. (default: true)"
bool))
(opt "force"
(describe
~description:
"Should we inject protocol that is invalid. (default: false)"
bool))))
~output:
(RPC.Error.wrap @@
describe
~title: "Hash of the injected protocol" @@
(obj1 (req "injectedProtocol" Protocol_hash.encoding)))
RPC.Path.(root / "inject_protocol")
let describe =
RPC.Description.service
~description: "RPCs documentation and input/output schema"

17
src/node/shell/node_rpc_services.mli
View File

@ -97,6 +97,19 @@ module Operations : sig
list_param, (Operation_hash.t * Store.operation option) list) RPC.service
end
module Protocols : sig
val bytes:
(unit, unit * Protocol_hash.t, unit,
Store.protocol tzresult Time.timed_data) RPC.service
type list_param = {
contents: bool option ;
monitor: bool option ;
}
val list:
(unit, unit,
list_param, (Protocol_hash.t * Store.protocol option) list) RPC.service
end
val forge_block:
(unit, unit,
Updater.net_id option * Block_hash.t option * Time.t option *
@ -115,5 +128,9 @@ val inject_operation:
(unit, unit,
(MBytes.t * bool * bool option), Operation_hash.t tzresult) RPC.service
val inject_protocol:
(unit, unit,
(Store.protocol * bool * bool option), Protocol_hash.t tzresult) RPC.service
val describe:
(unit, unit, bool option, RPC.Description.directory_descr) RPC.service

82
src/node/shell/state.ml
View File

@ -82,6 +82,9 @@ type t = {
operation_db: Db_proxy.Operation.t ;
operation_watchers:
(Operation_hash.t * Store.operation) Watcher.t list ref ;
protocol_db: Db_proxy.Protocol.t ;
protocol_watchers:
(Protocol_hash.t * Store.protocol) Watcher.t list ref ;
valid_block_state: valid_block_state Persist.shared_ref ;
}
@ -154,6 +157,15 @@ module InvalidOperations =
Persist.MakeBufferedPersistentSet
(Store.Faked_functional_store) (InvalidOperations_key) (Operation_hash_set)
module InvalidProtocols_key = struct
include Protocol_hash
let prefix = ["state"; "invalid_protocols"]
let length = path_len
end
module InvalidProtocols =
Persist.MakeBufferedPersistentSet
(Store.Faked_functional_store) (InvalidProtocols_key) (Protocol_hash_set)
module InvalidBlocks_key = struct
include Block_hash
let prefix = ["state"; "invalid_blocks"]
@ -236,6 +248,66 @@ module Operation = struct
end
module Protocol = struct
type key = Store.Protocol.key
type component = Tezos_compiler.Protocol.component = {
name: string;
interface: string option;
implementation: string
}
type t = Store.protocol
type protocol = t
exception Invalid of key * error list
let of_bytes = Store.Protocol.of_bytes
let to_bytes = Store.Protocol.to_bytes
let known t k = Db_proxy.Protocol.known t.protocol_db k
let read t k = Db_proxy.Protocol.read t.protocol_db k
let read_exn t k =
Db_proxy.Protocol.read t.protocol_db k >>= function
| None -> Lwt.fail Not_found
| Some { data = Error e } -> Lwt.fail (Invalid (k, e))
| Some { data = Ok data ; time } -> Lwt.return { Time.data ; time }
let hash = Store.Protocol.hash
let raw_read t k =
Persist.use t.store.Store.protocol
(fun store -> Store.Protocol.raw_get store k)
let prefetch t net_id ks =
List.iter (Db_proxy.Protocol.prefetch t.protocol_db net_id) ks
let fetch t net_id k = Db_proxy.Protocol.fetch t.protocol_db net_id k
let store t bytes =
match of_bytes bytes with
| None -> fail Cannot_parse
| Some proto ->
let h = hash proto in
Db_proxy.Protocol.store t.protocol_db h (Time.make_timed (Ok proto))
>>= function
| true ->
Watcher.notify !(t.protocol_watchers) (h, proto) ;
return (Some (h, proto))
| false ->
return None
let mark_invalid t k e =
Db_proxy.Protocol.update t.protocol_db k (Time.make_timed (Error e))
>>= function
| true ->
Persist.update t.store.global_store (fun store ->
InvalidProtocols.set store k >>= fun store ->
Lwt.return (Some store)) >>= fun _ ->
Lwt.return true
| false -> Lwt.return false
let invalid state =
Persist.use state.store.global_store InvalidProtocols.read
let create_watcher t = Watcher.create_stream t.protocol_watchers ()
let keys { protocol_db } = Db_proxy.Protocol.keys protocol_db
end
let iter_predecessors
(type t)
(compare: t -> t -> int)
@ -458,7 +530,7 @@ module Valid_block = struct
hash: Block_hash.t ;
pred: Block_hash.t ;
timestamp: Time.t ;
fitness: Protocol.fitness ;
fitness: Fitness.fitness ;
operations: Operation_hash.t list ;
discovery_time: Time.t ;
protocol_hash: Protocol_hash.t ;
@ -785,6 +857,8 @@ module Valid_block = struct
| Error exns ->
locked_store_invalid vstate hash exns >>= fun _changed ->
Lwt.return vstate
let keys _ = Store.undefined_key_fn
end
let iter_predecessors =
@ -1216,12 +1290,14 @@ let () =
(** Whole protocol state : read and store. *)
let read
~request_operations ~request_blocks
~request_operations ~request_blocks ~request_protocols
~store_root ~context_root ~ttl ?patch_context () =
Store.init store_root >>= fun store ->
lwt_log_info "Initialising the distributed database..." >>= fun () ->
let operation_db =
Db_proxy.Operation.create { request_operations } store.operation in
let protocol_db =
Db_proxy.Protocol.create { request_protocols } store.protocol in
let block_db =
Db_proxy.Block.create { request_blocks } store.block in
Valid_block.create
@ -1233,6 +1309,8 @@ let read
nets = Block_hash_table.create 7 ;
operation_db ;
operation_watchers = ref [] ;
protocol_db ;
protocol_watchers = ref [] ;
block_db ; block_watchers = ref [] ;
valid_block_state ;
}

73
src/node/shell/state.mli
View File

@ -39,6 +39,7 @@ type error +=
val read:
request_operations: (net_id -> Operation_hash.t list -> unit) ->
request_blocks: (net_id -> Block_hash.t list -> unit) ->
request_protocols: (Protocol_hash.t list -> unit) ->
store_root:string ->
context_root:string ->
ttl:int ->
@ -342,6 +343,78 @@ module Valid_block : sig
end
(** {2 Protocol database} ****************************************************)
(** The local and distributed database of protocols. *)
module Protocol : sig
type key = Protocol_hash.t
type component = Tezos_compiler.Protocol.component = {
name : string ;
interface : string option ;
implementation : string ;
}
type t = Tezos_compiler.Protocol.t
type protocol = t
(** Is a protocol stored in the local database ? *)
val known: state -> key -> bool Lwt.t
(** Read a protocol in the local database. This returns [None]
when the protocol does not exist in the local database; this returns
[Some (Error _)] when [mark_invalid] was used. This also returns
the time when the protocol was stored on the local database. *)
val read:
state -> key -> protocol tzresult Time.timed_data option Lwt.t
(** Read a protocol in the local database. This throws [Not_found]
when the protocol does not exist in the local database or when
[mark_invalid] was used. *)
val read_exn:
state -> key -> protocol Time.timed_data Lwt.t
exception Invalid of key * error list
(** Read an operation in the local database (without parsing). *)
val raw_read: state -> key -> MBytes.t option Lwt.t
(** Read a protocol from the distributed database. This may block
while the block is fetched from the P2P network. *)
val fetch:
state -> Store.net_id -> key -> protocol tzresult Time.timed_data Lwt.t
(** Request protocols on the P2P network without waiting for answers. *)
val prefetch: state -> Store.net_id -> key list -> unit
(** Add a protocol to the local database. This returns [Ok None]
if the protocol was already stored in the database, or returns
the parsed operation if not. It may also fails when the shell
part of the operation cannot be parsed or when the operation
does not belong to an active "network". For a given sequence of
bytes, it is guaranted that at most one call to [store] returns
[Some _]. *)
val store:
state -> MBytes.t -> (Protocol_hash.t * protocol) option tzresult Lwt.t
(** Mark a protocol as invalid in the local database. This returns
[false] if the protocol was previously stored in the local
database. The protocol is not removed from the local database,
but its content is replaced by a list of errors. *)
val mark_invalid: state -> key -> error list -> bool Lwt.t
(** Returns the list known-invalid procols. *)
val invalid: state -> Protocol_hash_set.t Lwt.t
(** Create a stream of all the newly locally-stored protocols.
The returned function allows to terminate the stream. *)
val create_watcher:
state -> (key * protocol) Lwt_stream.t * (unit -> unit)
val keys: state -> key list Lwt.t
end
(** {2 Network} ****************************************************************)
(** Data specific to a given network. *)

29
src/node/updater/updater.ml
View File

@ -131,7 +131,7 @@ let get_basedir () =
let init dir =
basedir := Some dir
type component = {
type component = Tezos_compiler.Protocol.component = {
name : string ;
interface : string option ;
implementation : string ;
@ -141,11 +141,12 @@ let create_files dir units =
Utils.remove_dir dir >>= fun () ->
Utils.create_dir dir >>= fun () ->
Lwt_list.map_s
(fun unit ->
let ml = dir // (unit.name ^ ".ml") in
let mli = dir // (unit.name ^ ".mli") in
Utils.create_file ml unit.implementation >>= fun () ->
match unit.interface with
(fun { name; interface; implementation } ->
let name = String.lowercase_ascii name in
let ml = dir // (name ^ ".ml") in
let mli = dir // (name ^ ".mli") in
Utils.create_file ml implementation >>= fun () ->
match interface with
| None -> Lwt.return [ml]
| Some content ->
Utils.create_file mli content >>= fun () ->
@ -154,17 +155,21 @@ let create_files dir units =
let files = List.concat files in
Lwt.return files
let extract dirname hash units =
let source_dir = dirname // Protocol_hash.to_short_b48check hash // "src" in
create_files source_dir units >|= fun _files ->
Tezos_compiler.Meta.to_file source_dir ~hash
(List.map (fun {name} -> String.capitalize_ascii name) units)
let do_compile hash units =
let basedir = get_basedir () in
let source_dir = basedir // Protocol_hash.to_short_b48check hash // "src" in
let log_file = basedir // Protocol_hash.to_short_b48check hash // "LOG" in
let plugin_file =
basedir // Protocol_hash.to_b48check hash
// Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in
let plugin_file = basedir // Protocol_hash.to_short_b48check hash //
Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash
in
create_files source_dir units >>= fun _files ->
Tezos_compiler.Meta.to_file
(source_dir // "TEZOS")
hash
Tezos_compiler.Meta.to_file source_dir ~hash
(List.map (fun {name} -> String.capitalize_ascii name) units);
let compiler_command =
(Sys.executable_name,

3
src/node/updater/updater.mli
View File

@ -70,12 +70,13 @@ module type REGISTRED_PROTOCOL = sig
and type 'a tzresult := 'a tzresult
end
type component = {
type component = Tezos_compiler.Protocol.component = {
name : string ;
interface : string option ;
implementation : string ;
}
val extract: Lwt_io.file_name -> Protocol_hash.t -> component list -> unit Lwt.t
val compile: Protocol_hash.t -> component list -> bool Lwt.t
val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t

99
src/proto/bootstrap/TEZOS_PROTOCOL
View File

@ -1,57 +1,56 @@
hash = "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr"
modules = [
{
"hash": "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr",
"modules": [
"Misc",
"Tezos_hash",
"Qty_repr",
"Tez_repr",
"Period_repr",
"Time_repr",
"Constants_repr",
"Fitness_repr",
"Raw_level_repr",
"Voting_period_repr",
"Cycle_repr",
"Level_repr",
"Seed_repr",
"Script_int_repr",
"Script_repr",
"Contract_repr",
"Roll_repr",
"Asset_repr",
"Vote_repr",
"Operation_repr",
"Block_repr",
Misc ;
Tezos_hash ;
"Storage_sigs",
"Storage_functors",
"Storage",
Qty_repr ;
Tez_repr ;
Period_repr ;
Time_repr ;
Constants_repr ;
Fitness_repr ;
Raw_level_repr ;
Voting_period_repr ;
Cycle_repr ;
Level_repr ;
Seed_repr ;
Script_int_repr ;
Script_repr ;
Contract_repr ;
Roll_repr ;
Asset_repr ;
Vote_repr ;
Operation_repr ;
Block_repr ;
"Level_storage",
"Nonce_storage",
"Seed_storage",
"Roll_storage",
"Contract_storage",
"Reward_storage",
"Bootstrap_storage",
"Fitness_storage",
"Vote_storage",
"Init_storage",
Storage_sigs ;
Storage_functors ;
Storage ;
"Tezos_context",
Level_storage ;
Nonce_storage ;
Seed_storage ;
Roll_storage ;
Contract_storage ;
Reward_storage ;
Bootstrap_storage ;
Fitness_storage ;
Vote_storage ;
Init_storage ;
"Script_typed_ir",
"Script_ir_translator",
"Script_interpreter",
Tezos_context ;
"Mining",
"Amendment",
"Apply",
Script_typed_ir ;
Script_ir_translator ;
Script_interpreter ;
"Services",
"Services_registration",
Mining ;
Amendment ;
Apply ;
Services ;
Services_registration ;
Main ;
]
"Main"
]
}

10
src/proto/demo/TEZOS_PROTOCOL
View File

@ -1,6 +1,4 @@
hash = "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"
modules = [
Error ;
Services ;
Main ;
]
{
"hash": "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee",
"modules": ["Error", "Services", "Main"]
}

6
src/proto/environment/persist.mli
View File

@ -18,6 +18,8 @@ module type STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys: t -> key list Lwt.t
end
(** Projection of OCaml keys of some abstract type to concrete storage
@ -57,6 +59,8 @@ module type BYTES_STORE = sig
val del: t -> key -> t Lwt.t
val list: t -> key list -> key list Lwt.t
val remove_rec: t -> key -> t Lwt.t
val keys: t -> key list Lwt.t
end
module MakeBytesStore (S : STORE) (K : KEY) :
@ -73,6 +77,8 @@ module type TYPED_STORE = sig
val get: t -> key -> value option Lwt.t
val set: t -> key -> value -> t Lwt.t
val del: t -> key -> t Lwt.t
val keys: t -> key list Lwt.t
end
(** Gives a typed view of a store (values of a given type stored under

5
src/utils/hex_encode.ml
View File

@ -24,13 +24,14 @@ let hex_encode = gen_encode String.length (fun s i -> int_of_char s.[i])
(* From OCaml's stdlib. See [Digest.from_hex]. *)
let gen_decode create set h =
let n = String.length h in
if n mod 2 <> 0 then invalid_arg "hex_decode" ;
if n mod 2 <> 0 then invalid_arg ("hex_decode: " ^ h);
let digit c =
match c with
| '0'..'9' -> int_of_char c - int_of_char '0'
| 'A'..'F' -> int_of_char c - int_of_char 'A' + 10
| 'a'..'f' -> int_of_char c - int_of_char 'a' + 10
| _c -> invalid_arg "hex_decode" in
| _c -> invalid_arg ("hex_decode: " ^ h)
in
let byte i = digit h.[i] lsl 4 + digit h.[i+1] in
let result = create (n / 2) in
for i = 0 to n/2 - 1 do

20
src/utils/utils.ml
View File

@ -121,3 +121,23 @@ let rec remove_elem_from_list nb = function
| [] -> []
| l when nb <= 0 -> l
| _ :: tl -> remove_elem_from_list (nb - 1) tl
let finalize f g = try let res = f () in g (); res with exn -> g (); raise exn
let read_file ?(bin=false) fn =
let ic = (if bin then open_in_bin else open_in) fn in
finalize (fun () ->
let len = in_channel_length ic in
let buf = Bytes.create len in
let nb_read = input ic buf 0 len in
if nb_read <> len then failwith (Printf.sprintf "read_file: read %d, expected %d" nb_read len)
else Bytes.unsafe_to_string buf)
(fun () -> close_in ic)
let write_file ?(bin=false) fn contents =
let oc = (if bin then open_out_bin else open_out) fn in
finalize (fun () ->
let contents = Bytes.unsafe_of_string contents in
output oc contents 0 @@ Bytes.length contents
)
(fun () -> close_out oc)

3
src/utils/utils.mli
View File

@ -38,3 +38,6 @@ val remove_elem_from_list: int -> 'a list -> 'a list
val filter_map: ('a -> 'b option) -> 'a list -> 'b list
val finalize: (unit -> 'a) -> (unit -> unit) -> 'a
val read_file: ?bin:bool -> string -> string
val write_file: ?bin:bool -> string -> string -> unit