Revision 500f420c32153facd1acd68a4ca648dbff6dbff5 authored by Nic Volanschi on 15 November 2022, 22:14:22 UTC, committed by Marge Bot on 04 December 2022, 21:22:08 UTC
1 parent af64ee6
qcheck_rpc.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Testing
-------
Component: Node
Invocation: dune exec tezt/long_tests/main.exe -- --file qcheck_rpc.ml
Subject: Property testing the RPC server
*)
(*
{0 Description}
This test tries to see if it can crash the node by calling RPCs with random
inputs. The setup is as follows. A fresh node and client are started and the
node is brought to protocol alpha. A single RPC is tested on that node by
calls from the client with random input that obeys the schema of that RPC.
This is repeated for each RPC with a fresh node and client. The list of RPCs
is generated from starting a node and getting JSON descriptions from the
following URLs:
- ["localhost:$rpc_port/describe/?recurse=yes"]
- ["localhost:$rpc_port/describe/chains/main/blocks/head?recurse=yes"]
- ["localhost:$rpc_port/describe/chains/main/mempool?recurse=yes"]
To see a log of all RPC calls, pass [--log-file] when running.
*)
(* Test configuration *)
(* ------------------------------------------------------------------------- *)
(* The number of random inputs we generate per RPC *)
let num_rand_inputs = 30
(* We currently are only able to test protocol alpha *)
let protocol = Protocol.Alpha
(* The central types *)
(* ------------------------------------------------------------------------- *)
(* A parameter to a URL of an RPC
Note: this is not exhaustive; it includes the inputs
that are easy to generate (e.g., excluding a ["sapling_state_id"])
*)
type path_input =
| Chain_ID
| Block_hash
| List_offset
| Op_offset
| Block_level
| Protocol_hash
| Rand_string
(* A URL given to an RPC *)
type path = (string, path_input) Either.t list
(* A type representation for the JSON input to an RPC. *)
type rpc_input =
| Any : rpc_input
| Boolean : rpc_input
| Integer : {min : int option; max : int option} -> rpc_input
| Z : rpc_input (* ["bignum"] *)
| Int_enum : int list -> rpc_input
| Float : {min : float option; max : float option} -> rpc_input
| Even_alphanum : rpc_input (* Even number of alpha numeric [char]s. *)
| String_enum : string list -> rpc_input
| Rand_string : rpc_input
| Array : rpc_input -> rpc_input
| Object : property list -> rpc_input
| One_of : rpc_input list -> rpc_input
| Mich_exp : rpc_input
| Tree_encoding : rpc_input
| Inode_tree : rpc_input
(* A JSON object field *)
and property = {name : string; required : bool; payload : rpc_input}
(* This is a description/schema for an RPC *)
type rpc_description = {
description : string;
meth : Client.meth;
path : path;
data : rpc_input option;
}
(* This is a particular RPC call *)
type rpc_instance = {
description : string;
meth : Client.meth;
full_path : string list;
input : Ezjsonm.value option;
}
let show_rpc_instance {meth; full_path; input; _} : string =
let inp_str =
match input with
| None -> "none"
| Some value -> Ezjsonm.value_to_string ~minify:false value
in
let meth_str = Client.string_of_meth meth in
let path_str = String.concat "/" full_path in
sf "\n\nMeth: %s\nPath:%s\nInput:\n%s\n" meth_str path_str inp_str
(* Dynamically get the list of all RPCs *)
(* ------------------------------------------------------------------------- *)
module RPC_Index = struct
open Tezos_openapi
open Tezos_openapi.Openapi
module String_map = Map.Make (String)
(* Parsing into [rpc_description]s *)
(* ------------------------------- *)
let path_param_form_re = Re.Str.(regexp "^{.+}$")
(* We only parse fields we can easily generate inputs for.
E.g., we do not parse ["{sapling_state_id}"].
*)
let parse_path_input s : path_input =
match s with
| "{chain_id}" -> Chain_ID
| "{block_hash}" -> Block_hash
| "{list_offset}" -> List_offset
| "{operation_offset}" -> Op_offset
| "{block_level}" -> Block_level
| "{Protocol_hash}" -> Protocol_hash
| _ -> Rand_string
let parse_path_input str : (string, path_input) Either.t =
let is_path_param = Re.Str.(string_match path_param_form_re str 0) in
match is_path_param with
| false -> Either.left str
| true -> Either.right @@ parse_path_input str
let parse_path path_string : path =
(* Note: We use [List.tl] since [split_on_char '/' "/a/b"]
is [[""; "a"; "b"]].
*)
path_string |> String.split_on_char '/' |> List.tl
|> List.map parse_path_input
(** [map_e f l] applies the [f] function (that can return [Ok _] or [Error _])
to all elements of [l]. If [f] succeeded on all elements, [Ok _] of
all transformed elements is returned, otherwise the first error is returned. *)
let rec map_e f = function
| [] -> Ok []
| x :: xs -> (
match f x with
| Ok y -> ( match map_e f xs with Ok ys -> Ok (y :: ys) | err -> err)
| Error err ->
(* No need to continue, in particular, no need to recurse *)
Error err)
let rec parse_input env schema : (rpc_input, string) result =
let open Schema in
match schema with
(* These first four references are circular. *)
| Ref "bignum" -> Ok Z
| Ref "micheline.alpha.michelson_v1.expression" -> Ok Mich_exp
| Ref "tree_encoding" -> Ok Tree_encoding
| Ref "inode_tree" -> Ok Inode_tree
| Ref str -> parse_input env @@ String_map.find str env
| Other {kind = Boolean; _} -> Ok Boolean
| Other {kind = Integer {minimum; maximum; enum = None}; _} ->
Ok (Integer {min = minimum; max = maximum})
| Other {kind = Integer {enum = Some enum; _}; _} -> Ok (Int_enum enum)
| Other {kind = Number {minimum; maximum}; _} ->
Ok (Float {min = minimum; max = maximum})
| Other {kind = String {pattern = Some s; _}; _} -> (
(* Only one regexp is used currently *)
match s with
| "^([a-zA-Z0-9][a-zA-Z0-9])*$" -> Ok Even_alphanum
| _ -> Error ("Unexpected regexp: " ^ s))
| Other {kind = String {enum = None; _}; _} -> Ok Rand_string
| Other {kind = String {enum = Some enum; _}; _} -> Ok (String_enum enum)
| Other {kind = Array schema'; _} -> (
match parse_input env schema' with Ok x -> Ok (Array x) | err -> err)
| Other {kind = Object {additional_properties = Some _; _}; _} ->
(* Note: Additional properties never occur in input. *)
Error "Additional properties are unsupported"
| Other {kind = Object {properties; _}; _} -> (
let conv_prop Schema.{name; required; schema} =
match parse_input env schema with
| Ok payload -> Ok {name; required; payload}
| Error err -> Error err
in
match map_e conv_prop properties with
| Ok conv_properties -> Ok (Object conv_properties)
| Error err -> Error err)
| Other {kind = One_of schemas; _} -> (
match map_e (parse_input env) schemas with
| Ok sub -> Ok (One_of sub)
| Error err -> Error err)
| Other {kind = Any; _} -> Ok Any
let parse_service path env meth service : rpc_description =
let open Service in
let data =
match service.request_body with
| Some schema -> (
match parse_input env schema with
| Ok rpc_input -> Some rpc_input
| Error err ->
Test.fail
"Error when parsing service \"%s\": %s. Can function \
parse_input above be generalized?"
service.description
err)
| None -> None
in
let description = service.description in
{description; meth; path; data}
(* A single endpoint can have multiple RPCs. An endpoint is basically
just a URL, which can have a different RPC per method.
*)
let parse_endpoint env endpoint : rpc_description list =
let open Endpoint in
let path_str = Path.to_string endpoint.path in
let path = parse_path path_str in
let services =
Client.
[
(GET, Openapi.(Endpoint.get_method endpoint GET));
(POST, Openapi.(Endpoint.get_method endpoint POST));
(PUT, Openapi.(Endpoint.get_method endpoint PUT));
(DELETE, Openapi.(Endpoint.get_method endpoint DELETE));
(PATCH, Openapi.(Endpoint.get_method endpoint PATCH));
]
in
let opt_convert (meth, opt_service) =
opt_service |> Option.map @@ parse_service path env meth
in
List.filter_map opt_convert services
(* Parse [rpc_description]s from the given [env] and [Endpoint.t list]. *)
let parse_endpoints env endpoints : rpc_description list =
List.concat_map (parse_endpoint env) endpoints
(* Dynamically querying all RPCs *)
(* ----------------------------- *)
(* Given a list of urls that spit out JSON descriptions of RPCs,
use the technique from [Rpc_openapi.Openapi] to query a node to get those
JSON descriptions and parse them.
*)
let get_endpoints rpc_port urls : (Convert.env * Endpoint.t) list Lwt.t =
let get_url_endpoints url =
let open Lwt_process in
let* curl_result = pread ~stderr:`Dev_null ("curl", [|"curl"; url|]) in
curl_result |> JSON.parse ~origin:url |> Api.parse_tree
|> Api.parse_services |> Api.flatten
|> List.map Convert.convert_endpoint
|> return
in
let args = Node.[Network "sandbox"; Expected_pow 0; No_bootstrap_peers] in
let* node = Node.init ~rpc_port args in
let* client = Client.init ~endpoint:(Node node) () in
let* () = Client.activate_protocol ~protocol client in
Lwt_list.map_s get_url_endpoints urls |> Lwt.map List.concat
(* For the given protocol, get [rpc_description]s for the rpc server. *)
let get_index () : rpc_description list Lwt.t =
(* Define urls to query JSON descriptions from *)
let port = 8732 in
let url_prefix = sf "http://localhost:%d/describe/" port in
let shell_url = url_prefix ^ "?recurse=yes" in
let proto_url = url_prefix ^ "chains/main/blocks/head?recurse=yes" in
let mempool_url = url_prefix ^ "chains/main/mempool?recurse=yes" in
let urls = [shell_url; proto_url; mempool_url] in
let* envs, endpts = Lwt.(get_endpoints port urls >|= List.split) in
let env = Convert.merge_env_list envs in
return @@ parse_endpoints env endpts
end
(* Generate random data for RPC calls *)
(* ------------------------------------------------------------------------- *)
module Gen = struct
type 'a t = 'a QCheck2.Gen.t
(* Prerequisites of [path_gen] *)
(* ---------------------------- *)
let chain_id_gen : string t =
let open QCheck2.Gen in
let open Tezos_crypto in
let non_alias =
list string >|= Chain_id.hash_string >|= Chain_id.to_string
in
frequency [(4, pure "main"); (2, pure "test"); (1, non_alias)]
let block_hash_gen : string t =
let open QCheck2.Gen in
let open Tezos_crypto in
let non_alias =
list string >|= Block_hash.hash_string >|= Block_hash.to_string
in
frequency [(4, pure "head"); (2, pure "genesis"); (1, non_alias)]
let protocol_hash_gen : string t =
let open QCheck2.Gen in
let open Tezos_crypto in
list string >|= Protocol_hash.hash_string >|= Protocol_hash.to_string
let path_int_gen : string t = QCheck2.Gen.(map Int.to_string small_nat)
(* Prerequisites of [known_input_gen] *)
(* ----------------------------------- *)
let nums = "0123456789"
let alpha = "abcdefghijklmnopqrstuvwxyz"
let alpha_num_alphabet : char list =
nums ^ alpha ^ String.capitalize_ascii alpha |> String.to_seq |> List.of_seq
let even_alpha_num_gen : string t =
let alpha_num_gen = QCheck2.Gen.oneofl alpha_num_alphabet in
let even_gen = QCheck2.Gen.map (( * ) 2) QCheck2.Gen.(0 -- 100) in
QCheck2.Gen.string_size ~gen:alpha_num_gen even_gen
let rec take n xs : 'a list =
match (n, xs) with
| 0, _ -> []
| _, [] -> []
| n, y :: ys -> y :: take (n - 1) ys
let pick_some_elems xs : 'a list t =
let open QCheck2.Gen in
let shuffle_gen = pair (shuffle_l xs) (0 -- List.length xs) in
map (fun (ys, n) -> take n ys) shuffle_gen
let micheline_exp_gen =
let open Tezos_alpha_test_helpers.Test_global_constants in
let open Tezos_protocol_alpha.Protocol.Michelson_v1_primitives in
let open Tezos_micheline in
let open Micheline_encoding in
let open QCheck2.Gen in
let l_gen = return (-1) in
let annot_gen = return [] in
let micheline_node_gen =
Generators.micheline_node_gen l_gen Generators.prim_gen annot_gen
in
let node_encoding =
table_encoding ~variant:"name" Data_encoding.int31 prim_encoding
in
micheline_node_gen >|= Data_encoding.Json.construct node_encoding
(* TODO: Those trivial implementations are here to prevent the parsing
of "tree_encoding" and "inode_tree" references from generating stack
overflows (these references are circular) and crashing tests.
We ought to make proper implementations if we want the tests
to be significant. *)
let tree_encoding_gen = QCheck2.Gen.return `Null
let inode_tree_gen = QCheck2.Gen.return `Null
(* Random path generation *)
(* ---------------------- *)
let path_gen path : string list t =
let open QCheck2.Gen in
let path_str_gen = string_size (1 -- 100) in
let elem_to_gen : (string, path_input) Either.t -> string t = function
| Either.Left s -> pure s
| Either.Right input -> (
match input with
| Chain_ID -> chain_id_gen
| Block_hash -> block_hash_gen
| List_offset -> path_int_gen
| Op_offset -> path_int_gen
| Block_level -> path_int_gen
| Rand_string -> path_str_gen
| Protocol_hash -> protocol_hash_gen)
in
path |> List.map elem_to_gen |> flatten_l
(* Random input json generation *)
(* ---------------------------- *)
let rec known_input_gen : rpc_input -> Ezjsonm.value t =
let open QCheck2.Gen in
function
| Boolean -> map Ezjsonm.bool bool
| Integer {min; max} ->
int_range
(Option.value min ~default:Int.min_int)
(Option.value max ~default:Int.max_int)
>|= Ezjsonm.int
| Z -> map Ezjsonm.int64 ui64
| Int_enum enum -> oneofl enum |> map Ezjsonm.int
| Float {min; max} ->
float_range
(Option.value min ~default:Float.min_float)
(Option.value max ~default:Float.max_float)
>|= Ezjsonm.float
| Even_alphanum -> map Ezjsonm.string even_alpha_num_gen
| String_enum enum -> oneofl enum |> map Ezjsonm.string
| Any | Rand_string -> map Ezjsonm.string string
| Array rpc_input ->
list_size (0 -- 10) (known_input_gen rpc_input) |> map (fun l -> `A l)
| One_of rpc_inputs -> oneof @@ List.map known_input_gen rpc_inputs
| Object properties ->
let open QCheck2.Gen in
List.partition (fun x -> x.required) properties |> fun (req, not_req) ->
pick_some_elems not_req >>= fun some_elems ->
req @ some_elems
|> List.map (fun {name; payload; _} -> (name, payload))
|> List.split
|> fun (names, payloads) ->
List.map known_input_gen payloads
|> QCheck2.Gen.flatten_l
|> QCheck2.Gen.map (fun inputs -> `O (List.combine names inputs))
| Mich_exp -> micheline_exp_gen
| Tree_encoding -> tree_encoding_gen
| Inode_tree -> inode_tree_gen
let input_gen opt_rpc_input : Ezjsonm.value option t =
Option.map known_input_gen opt_rpc_input |> QCheck2.Gen.flatten_opt
(* Random RPC instance generation *)
(* ------------------------------ *)
let instance_gen {description; meth; path; data} : rpc_instance t =
let open QCheck2.Gen in
pair (input_gen data) (path_gen path)
|> map (fun (input, full_path) -> {description; meth; full_path; input})
end
(* Test each RPC for whether it crashes the node *)
(* ------------------------------------------------------------------------- *)
module Test = struct
(* Call an rpc, allowing for failure without calling [Tezt.Test.fail].
We need this because we are testing the resilience of the node; the
test fails iff the node given random-input RPC calls (which will almost
always fail) crashes.
*)
let call_rpc client {meth; full_path; input; _} :
(JSON.t, Unix.process_status) result Lwt.t =
let proc =
(* As this test performs many RPC calls, we don't want to log,
to avoid consuming a lot of storage space on the CI.
Only checking if the node stays alive matters.
In case this test needs to be debugged, set all three [log_*] flags
to [true], to get feedback on the faulty RPC. *)
Client.spawn_rpc
~log_command:false
~log_status_on_exit:false
~log_output:false
?data:input
meth
full_path
client
in
let* exit_code = Process.wait proc in
match exit_code with
| WEXITED 0 ->
let* output = Lwt_io.read @@ Process.stdout proc in
let origin = Client.string_of_path full_path ^ " response" in
return @@ Ok (JSON.parse ~origin output)
| _ -> return @@ Error exit_code
(* Check if the node attached to a client is still alive.
We assume that if the vanilla node (not proxy) is still
alive it will return something for "rpc get /version". *)
let check_node_alive client : bool Lwt.t =
Lwt.map Result.is_ok
@@ call_rpc
client
{
description = "";
meth = Client.GET;
full_path = ["version"];
input = None;
}
let test_instance client rpc_instance : unit Lwt.t =
(* To see the RPC being called: *)
(* let () = Log.info "%s" (show_rpc_instance rpc_instance) in *)
let* _ = call_rpc client rpc_instance in
let* node_alive = check_node_alive client in
match node_alive with
| true -> unit
| false -> Tezt.Test.fail "Node has crashed! See log file."
let test_rpc (rpc_description : rpc_description) : unit Lwt.t =
(* Log description of RPC *)
let () = Log.info "%s\n\n" rpc_description.description in
(* Start node and client *)
let* node, client = Client.init_with_protocol `Client ~protocol () in
(* Generate and test instances *)
let* () =
rpc_description |> Gen.instance_gen
|> QCheck2.Gen.generate ~n:num_rand_inputs
|> Lwt_list.iter_s (test_instance client)
in
Node.terminate node
(* The presence of any of these terms means the RPC is a streaming RPC
that does not return. We omit these from the scope of this test.
- /monitor requires to sync with other nodes to function properly
- /log requires some activity, e.g., pushing operations in parallel
*)
let streaming_url = ["monitor"; "log"]
let filter_description {path; data; _} =
let not_streaming =
List.for_all (fun x -> not @@ List.mem (Either.Left x) path) streaming_url
in
(* We don't want to fuzz RPCs that have no input: *)
let not_no_input = Option.is_some data in
not_streaming && not_no_input
let test_rpc_server () : unit Lwt.t =
let* rpc_descriptions = RPC_Index.get_index () in
let filtered = List.filter filter_description rpc_descriptions in
Lwt_list.iter_s test_rpc filtered
end
let property_test_rpc_server ~executors =
Long_test.register
~__FILE__
~title:"property_test_rpc_server"
~tags:["node"; "pbt"; "fuzz"; "rpc"]
~executors
~timeout:(Hours 1)
Test.test_rpc_server
let register_for_alpha () = property_test_rpc_server
![swh spinner](/static/img/swh-spinner.gif)
Computing file changes ...