commit b40b7ddef4b7079089db35f08dbc8bf7368b728c Author: Ulf Wiger Date: Mon Feb 24 22:17:41 2025 +0100 Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..7a1d220 --- /dev/null +++ b/LICENSE @@ -0,0 +1,16 @@ +ISC License + +Copyright (c) 2025, QPQ AG +Copyright (c) 2017, aeternity developers + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE +OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. \ No newline at end of file diff --git a/rebar.config b/rebar.config new file mode 100644 index 0000000..912074a --- /dev/null +++ b/rebar.config @@ -0,0 +1,21 @@ +%% -*- mode: erlang; erlang-indent-level: 4; indent-tabs-mode: nil -*- +{erl_opts, [debug_info]}. +{plugins, [rebar3_hex]}. + +{deps, [ + {zj, {git, "https://gitlab.com/zxq9/zj.git", {tag, "1.1.2"}}} + , {yamerl, "0.10.0"} + , {setup, "2.1.2"} + ]}. + +{profiles, [ + {test, [{deps, [{meck, "0.9.2"}]}]} + ]}. + +{xref_checks, [undefined_function_calls, undefined_functions, + locals_not_used, + deprecated_function_calls, deprecated_functions]}. + +{dialyzer, [ {warnings, [unknown]} + , {base_plt_apps, [erts, kernel, stdlib, yamerl, zj, setup]} + ]}. diff --git a/rebar.lock b/rebar.lock new file mode 100644 index 0000000..37a8aaa --- /dev/null +++ b/rebar.lock @@ -0,0 +1,15 @@ +{"1.2.0", +[{<<"setup">>,{pkg,<<"setup">>,<<"2.1.2">>},0}, + {<<"yamerl">>,{pkg,<<"yamerl">>,<<"0.10.0">>},0}, + {<<"zj">>, + {git,"https://gitlab.com/zxq9/zj.git", + {ref,"090a43d23edc481695664f16763f147a78c45afc"}}, + 0}]}. +[ +{pkg_hash,[ + {<<"setup">>, <<"43C0BBFE9160DE7925BF2FC2FE4396A99DC4EE1B73F0DC46ACC3F10E27B07A9C">>}, + {<<"yamerl">>, <<"4FF81FEE2F1F6A46F1700C0D880B24D193DDB74BD14EF42CB0BCF46E81EF2F8E">>}]}, +{pkg_hash_ext,[ + {<<"setup">>, <<"596713D48D8241DF31821C08A9F7BAAF3E7CDD042C8396BC956CC7AE056925DC">>}, + {<<"yamerl">>, <<"346ADB2963F1051DC837A2364E4ACF6EB7D80097C0F53CBDC3046EC8EC4B4E6E">>}]} +]. diff --git a/src/gmconfig.app.src b/src/gmconfig.app.src new file mode 100644 index 0000000..ef63d8b --- /dev/null +++ b/src/gmconfig.app.src @@ -0,0 +1,17 @@ +%% -*- mode: erlang; erlang-indent-level: 4; indent-tabs-mode: nil -*- +{application, gmconfig, + [{description, "Gajumaru configuration management support"}, + {vsn, "0.1.0"}, + {registered, []}, + {application, + [ + kernel + , stdlib + , zj + ]}, + {env, []}, + {modules, []}, + {maintainers, ["QPQ IaaS AG"]}, + {licensens, ["ISC"]}, + {links, [{"gitea", "https://git.qpq.swiss/gmconfig"}]} + ]}. diff --git a/src/gmconfig.erl b/src/gmconfig.erl new file mode 100644 index 0000000..411b3d7 --- /dev/null +++ b/src/gmconfig.erl @@ -0,0 +1,1057 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2025, QPQ AG +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc Bootstrapping and querying the Gajumaru environment +%%% +%%% @end +%%%------------------------------------------------------------------- +-module(gmconfig). + +-export([get_env/2, get_env/3]). + +-export([user_config/0]). +-export([load_main_config_schema/0, % called from start phase 50 + load_system_defaults/0]). % called from start phase 60 +-export([schema/0, schema/1, schema/2]). +-export([load_schema/0]). +-export([schema_default/1, schema_default/2]). +-export([schema_keys/0, schema_keys/1]). +-export([config_value/4]). +-export([find_config/1, find_config/2, %% -> {ok, Value} | undefined + get_config/1, get_config/2 %% -> Value (or exception) + ]). +-export([merge_config_maps/2]). +-export([nested_map_get/2]). +-export([read_config/0, read_config/1]). +-export([load_config_file/1]). % apply system-/network-specific defaults +-export([search_for_config_file/2]). +-export([apply_os_env/0, + apply_os_env/3]). +-export([data_dir/1]). +-export([check_config/1]). + +-export([update_config/1, + update_config/2, + update_config/3, + silent_update_config/1, + delete_config_value/1, + suggest_config/2, + set_config_value/2]). %% (Path, Value) + +-export([export_config/0]). + +-export([ gmconfig_env/0 + , gmconfig_env/1 + , gmconfig_env/2 + , set_gmconfig_env/1 + ]). + +-ifdef(TEST). +-export([mock_config/0, + mock_config/1, + mock_system_defaults/0, + mock_system_defaults/1, + ensure_schema_loaded/0, + unmock_schema/0, + unmock_config/0]). +-endif. + +-include_lib("kernel/include/logger.hrl"). + +-type gmconfig() :: #{ os_env_prefix => string() + , config_file_basename => string + , config_file_search_path => [string()] + , system_suffix => string() + , schema => string() | map() | fun(() -> map())}. + +-type basic_type() :: number() | binary() | boolean(). +-type basic_or_list() :: basic_type() | [basic_type()]. +-type config_tree() :: [{binary(), config_tree() | basic_or_list()}]. + +%% -type env_key() :: atom() | list(). +-type config_key() :: binary() | [binary()]. + +-type find_opts() :: [user_config | schema_default | {env, atom(), atom()} | {value, any()}]. + +-export_type([ find_opts/0 ]). + +-ifdef(TEST). + +mock_config() -> + mock_config(#{}). + +mock_config(Cfg) -> + ensure_schema_loaded(), + store(Cfg, _Notify = false, _Mode = silent). + +unmock_config() -> + gmconfig_schema_utils:clear(), + ok. + +unmock_schema() -> + gmconfig_schema_utils:clear(), + ok. + +mock_system_defaults() -> + mock_config(), + load_system_defaults(silent). + +mock_system_defaults(Config) -> + ensure_schema_loaded(), + load_system_defaults(silent), + mock_config(Config). + +-endif. + +-spec set_gmconfig_env(gmconfig()) -> ok. +set_gmconfig_env(Env) when is_map(Env) -> + case maps:keys(default_gmconfig()) -- maps:keys(Env) of + [] -> + persistent_term:put({?MODULE, gmconfig_env}, Env); + Unknown -> + error({unknown_config_keys, Unknown}) + end. + +-spec gmconfig_env() -> gmconfig(). +gmconfig_env() -> + persistent_term:get({?MODULE, gmconfig_env}, default_gmconfig()). + +-spec gmconfig_env(atom()) -> any(). +gmconfig_env(Key) -> + gmconfig_env(Key, undefined). + +gmconfig_env(Key, Default) -> + maps:get(Key, gmconfig_env(), Default). + +default_gmconfig() -> + #{ os_env_prefix => "GM" + , config_file_basename => "gmconfig" + , config_file_search_path => ["."] + , system_suffix => "" }. + +%% This function is similar to application:get_env/2, except +%% 1. It uses the setup:get_env/2 function, which supports a number +%% of useful variable expansions (see the setup documentation) +%% 2. It supports a hierarchical key format, [A,B,...], where each +%% part of the key represents a level in a tree structure. +%% Example: +%% if get_env(A, a) returns {ok, {a, [{1, foo}, {2, bar}]}}, or +%% {ok, [{a, [{1, foo}, {2, bar}]}]}, then +%% get_env(A, [a,1]) will return {ok, foo} +-spec get_env(atom(), atom() | list()) -> undefined | {ok, any()}. +get_env(App, [H|T]) -> + case setup:get_env(App, H) of + {ok, V} -> + get_env_l(T, V); + undefined -> + undefined + end; +get_env(App, K) when is_atom(K) -> + setup:get_env(App, K). + +get_env(App, K, Default) -> + case get_env(App, K) of + {ok, V} -> V; + undefined -> Default + end. + +get_env_l([], V) -> + {ok, V}; +get_env_l([H|T], [_|_] = L) -> + case lists:keyfind(H, 1, L) of + {_, V} -> + get_env_l(T, V); + false -> + undefined + end; +get_env_l(_, _) -> + undefined. + +-spec user_config() -> config_tree(). +user_config() -> + pt_get_config(). + +config_value(CfgKey, App, Env, Default) -> + {ok, Value} =find_config(CfgKey, [ user_config + , {env, App, Env} + , schema_default + , {value, Default} ]), + Value. + +%%% ==================================================================================== +%%% Config lookup API +%%% +%%% These are the preferred functions for config data lookup + +get_config(CfgKey) -> + get_config(CfgKey, [user_config, schema_default]). + +get_config(CfgKey, Path) -> + case find_config(CfgKey, Path) of + {ok, Value} -> + Value; + undefined -> + error(expected_value, [CfgKey, Path]) + end. + +find_config(CfgKey) -> + find_config(CfgKey, [user_config, schema_default]). + +find_config(CfgKey, [H|T]) -> + case find_config_(CfgKey, H) of + undefined -> find_config(CfgKey, T); + {ok,_} = Ok -> Ok + end; +find_config(_, []) -> + undefined. + +find_config_(K, user_config ) -> user_map(K); +find_config_(_, {env, App, EnvKey}) -> get_env(App, EnvKey); +find_config_(K, schema_default ) -> schema_default(K); +find_config_(_, {value, V} ) -> {ok, V}. + + +%%% ==================================================================================== +%%% Merging config maps +%%% +%%% This function implements a deep map merge, ensuring that sub-maps also get merged. +-spec merge_config_maps(map(), map()) -> map(). +merge_config_maps(A, B) -> + {A1, B1} = + maps:fold( + fun(K, V, {Ca, Cb}) when is_map(V), is_map(map_get(K, Cb)) -> + {Ca#{K := merge_config_maps(V, map_get(K, Cb))}, maps:remove(K, Cb)}; + (_, _, Acc) -> + Acc + end, {A, B}, A), + maps:merge(A1, B1). + + +%% The user_map() functions are equivalent to user_config(), but +%% operate on a tree of maps rather than a tree of {K,V} tuples. +%% Actually, the user_map() data is the original validated object, +%% which is then transformed to the Key-Value tree used in user_config(). +-spec user_map() -> map(). +user_map() -> + pt_get_config(). + +-spec user_map([any()] | any()) -> {ok, any()} | undefined. +user_map(Key) when is_list(Key) -> + M = user_map(), + case maps:find(Key, M) of + {ok, _} = Ok -> + Ok; + error -> + nested_map_get(Key, M) + end; +user_map(Key) -> + case maps:find(Key, user_map()) of + {ok, _} = Ok -> Ok; + error -> undefined + end. + +nested_map_get([], V) -> + {ok, V}; +nested_map_get([H|T], M) when is_map(M) -> + case maps:find(H, M) of + {ok, M1} when is_map(M1); is_list(M1) -> + nested_map_get(T, M1); + {ok, V} when T == [] -> + {ok, V}; + _ -> + undefined + end; +nested_map_get([H|T], L) when is_list(L) -> + case lists_map_key_find(H, L) of + {ok, V} when is_map(V); is_list(V) -> + nested_map_get(T, V); + {ok, V} when T == [] -> + {ok, V}; + error -> + undefined + end. + +lists_map_key_find({K,V,Then} = Pat, [#{} = H|T]) -> + case maps:find(K, H) of + {ok, V} -> + maps:find(Then, H); + {ok, _} -> + lists_map_key_find(Pat, T); + error -> + lists_map_key_find(Pat, T) + end; +lists_map_key_find(K, [#{} = H|T]) -> + case maps:find(K, H) of + {ok, _} = Ok -> + Ok; + error -> + lists_map_key_find(K, T) + end; +lists_map_key_find(K, [{K, V}|_]) -> + {ok, V}; +lists_map_key_find(_, []) -> + error. + +schema() -> + case pt_get_schema(undefined) of + undefined -> + load_schema(), + pt_get_schema(); + S -> + S + end. + +pt_get_schema() -> + gmconfig_schema_utils:get_schema(). + +pt_get_schema(Default) -> + gmconfig_schema_utils:get_schema(Default). + +pt_set_schema(Schema) -> + gmconfig_schema_utils:set_schema(Schema). + +pt_get_config() -> + gmconfig_schema_utils:get_config(). + +pt_set_config(Config) -> + gmconfig_schema_utils:set_config(Config). + +schema(Key) -> + gmconfig_schema_utils:schema(Key). + +schema(Key, Schema) -> + gmconfig_schema_utils:schema(Key, Schema). + +schema_keys() -> + schema_keys([]). + +schema_keys(Path) -> + case schema(Path) of + undefined -> + undefined; + {ok, Map} -> + just_schema_keys(Map) + end. + +just_schema_keys(#{<<"properties">> := Ps}) -> + maps:fold(fun(K, V, Acc) -> + Acc#{K => just_schema_keys(V)} + end, #{}, Ps); +just_schema_keys(#{<<"patternProperties">> := Ps}) -> + maps:fold(fun(K, V, Acc) -> + Acc#{{'$pat', K} => just_schema_keys(V)} + end, #{}, Ps); +just_schema_keys(#{<<"type">> := <<"array">>, <<"items">> := Items}) -> + case Items of + #{<<"type">> := <<"object">>} -> + [just_schema_keys(Items)]; + #{<<"type">> := T} -> + [binary_to_atom(T, utf8)]; + #{<<"pattern">> := _} -> + [string] + end; +just_schema_keys(#{<<"oneOf">> := List}) -> + #{<<"oneOf">> => lists:foldr( + fun(Alt, Acc) -> + case just_schema_keys(Alt) of + [] -> + [maps:fold( + fun(K, #{<<"type">> := T}, Acc1) -> + Acc1#{K => binary_to_atom(T, utf8)}; + (_, _, Acc1) -> + Acc1 + end, #{}, Alt) | Acc]; + Other -> + [Other|Acc] + end + end, [], List)}; +just_schema_keys(#{<<"type">> := T}) -> + binary_to_atom(T, utf8); +just_schema_keys(#{properties := Ps}) -> + maps:fold(fun(K, V, Acc) -> + Acc#{K => just_schema_keys(V)} + end, #{}, Ps); +just_schema_keys(#{patternProperties := Ps}) -> + maps:fold(fun(K, V, Acc) -> + Acc#{{'$pat', K} => just_schema_keys(V)} + end, #{}, Ps); +just_schema_keys(#{type := array, items := Items}) -> + case Items of + #{type := object} -> + [just_schema_keys(Items)]; + #{type := T} -> + [T]; + #{pattern := _} -> + [string] + end; +just_schema_keys(#{oneOf := List}) -> + #{oneOf => lists:foldr( + fun(Alt, Acc) -> + case just_schema_keys(Alt) of + [] -> + [maps:fold( + fun(K, #{type := T}, Acc1) -> + Acc1#{K => T}; + (_, _, Acc1) -> + Acc1 + end, #{}, Alt) | Acc]; + Other -> + [Other|Acc] + end + end, [], List)}; +just_schema_keys(#{type := T}) -> + T; +just_schema_keys(_) -> + []. + +schema_default(Path) when is_list(Path) -> + schema_default(Path, schema()). + +schema_default(Path, Schema) -> + case schema(Path, Schema) of + undefined -> undefined; + {ok, Tree} -> + case schema_default_(Tree) of + undefined -> undefined; + Res -> + {ok, Res} + end + end. + +schema_default_(#{<<"type">> := <<"object">>, <<"properties">> := Props}) -> + maps:map(fun(_, #{<<"type">> := <<"object">>} = PP) -> + schema_default_(PP); + (_, #{<<"type">> := <<"array">>, <<"default">> := Def}) -> + Def; + (_, #{<<"type">> := <<"array">>, <<"items">> := Items}) -> + [schema_default_(Items)]; + (_, #{<<"default">> := Def}) -> Def; + (_, _) -> undefined + end, Props); +schema_default_(#{<<"type">> := <<"array">>, <<"default">> := Def}) -> + Def; +schema_default_(#{<<"type">> := <<"array">>, <<"items">> := Items}) -> + [schema_default_(Items)]; +schema_default_(#{<<"default">> := Def}) -> + Def; +schema_default_(#{type := <<"object">>, properties := Props}) -> + maps:map(fun(_, #{<<"type">> := <<"object">>} = PP) -> + schema_default_(PP); + (_, #{type := array, default := Def}) -> + Def; + (_, #{type := array, items := Items}) -> + [schema_default_(Items)]; + (_, #{default := Def}) -> Def; + (_, _) -> undefined + end, Props); +schema_default_(#{type := array, default := Def}) -> + Def; +schema_default_(#{type := array, items := Items}) -> + [schema_default_(Items)]; +schema_default_(#{default := Def}) -> + Def; +schema_default_(_) -> + undefined. + +read_config() -> + read_config(silent). + +read_config(Mode) when Mode =:= check; Mode =:= silent; Mode =:= report -> + case config_file() of + undefined -> + info_msg(Mode, "No config file specified; using default settings~n", []), + ok; + F -> + info_msg(Mode, "Reading config file ~s~n", [F]), + do_read_config(F, store, Mode) + end. + +load_config_file(File) -> + load_config_file(File, report). + +load_config_file(File, Mode) when Mode =:= check; + Mode =:= silent; + Mode =:= report -> + do_read_config(File, store, Mode). + +apply_os_env() -> + ok = application:ensure_started(gproc), + Pfx = os_env_prefix(), + ConfigMap = pt_get_config(), + case apply_os_env(Pfx, schema(), ConfigMap) of + NewConfig when is_map(NewConfig) -> + pt_set_config(NewConfig), + NewConfig; + Other -> + Other + end. + +os_env_prefix() -> + gmconfig_env(os_env_prefix, "GM"). + +%% Plugin API version, using plugin schema and config. +%% The plugin API might decide to publish a specific event... +apply_os_env(Pfx, Schema, ConfigMap) -> + %% We sort on variable names to allow specific values to override object + %% definitions at a higher level (e.g. GM__MEMPOOL followed by GM__MEMPOOL__TX_TTL) + %% Note that all schema name parts are converted to uppercase. + try + Names = lists:keysort(1, schema_key_names(Pfx, Schema)), + error_logger:info_msg("OS env config: ~p~n", [Names]), + Map = lists:foldl( + fun({_Name, Key, Value}, Acc) -> + Value1 = coerce_type(Key, Value, Schema), + update_map(to_map(Key, Value1), Acc) + end, #{}, Names), + error_logger:info_msg("Map for OS env config: ~p~n", [Map]), + if map_size(Map) > 0 -> + update_config_(Map, ConfigMap, Schema, report); + true -> + no_change + end + catch + error:E:ST -> + error_logger:info_msg("CAUGHT error:~p / ~p~n", [E, ST]), + error(E) + end. + +to_map(K, V) -> + to_map(K, V, #{}). + +to_map([K], Val, M) -> + M#{K => Val}; +to_map([H|T], Val, M) -> + SubMap = maps:get(H, M, #{}), + M#{H => to_map(T, Val, SubMap)}. + +coerce_type(Key, Value, Schema) -> + case schema(Key, Schema) of + {ok, #{<<"type">> := Type}} -> + case Type of + <<"integer">> -> to_integer(Value); + <<"string">> -> to_string(Value); + <<"boolean">> -> to_bool(Value); + <<"array">> -> json_decode(list_to_binary(Value)); + <<"object">> -> json_decode(list_to_binary(Value)) + end; + _ -> + error({unknown_key, Key}) + end. + +to_integer(I) when is_integer(I) -> I; +to_integer(L) when is_list(L) -> list_to_integer(L); +to_integer(B) when is_binary(B) -> binary_to_integer(B). + +to_string(L) when is_list(L) -> list_to_binary(L); +to_string(B) when is_binary(B) -> B. + +to_bool("true") -> true; +to_bool("false") -> false; +to_bool(B) when is_boolean(B) -> + B; +to_bool(Other) -> + error({expected_boolean, Other}). + +schema_key_names(Prefix, Schema) -> + case Schema of + #{<<"$schema">> := _, <<"properties">> := Props} -> + schema_key_names(Prefix, [], Props, []); + _ -> + [] + end. + +schema_key_names(NamePfx, KeyPfx, Map, Acc0) when is_map(Map) -> + maps:fold( + fun(SubKey, SubMap, Acc) -> + NamePfx1 = NamePfx ++ "__" ++ string:to_upper(binary_to_list(SubKey)), + KeyPfx1 = KeyPfx ++ [SubKey], + EnvKey = unhyphenate(NamePfx1), + Acc1 = case os:getenv(EnvKey) of + false -> Acc; + Value -> + [{EnvKey, KeyPfx1, Value} | Acc] + end, + case maps:find(<<"properties">>, SubMap) of + error -> + Acc1; + {ok, Props} -> + schema_key_names(NamePfx1, KeyPfx1, Props, Acc1) + end + end, Acc0, Map). + +%% Unfortunately, the config schema contains some names with hyphens in them. +%% Since hyphens aren't allowed in OS environment names, we replace them with underscores. +%% This should be safe, since we DO NOT stupidly have names that differ only on '-' v '_'. +unhyphenate(Str) -> + re:replace(Str, <<"\\-">>, <<"_">>, [global, {return, list}]). + +check_config(F) -> + do_read_config(F, check, check). + +data_dir(Name) when is_atom(Name) -> + filename:join([setup:data_dir(), Name]). + +config_file() -> + case command_line_config_file() of + undefined -> + default_config_file(); + F -> F + end. + +command_line_config_file() -> + case init:get_argument('-config') of + {ok, [[F]]} -> F; + _ -> undefined + end. + +default_config_file() -> + case os:getenv("GAJUMARU_CONFIG") of + false -> + case setup:get_env(aecore, config) of + {ok, F} -> F; + _ -> search_default_config() + end; + F -> + F + end. + +search_default_config() -> + Dirs = [filename:join([os:getenv("HOME"), ".gajumaru", "gajumaru"]), + setup:home()], + SystemSuffix = get_system_suffix(), + Fname = "gajumaru" ++ SystemSuffix ++ ".{json,yaml}", + search_for_config_file(Dirs, Fname). + +search_for_config_file(Dirs, FileWildcard) -> + lists:foldl( + fun(D0, undefined) -> + D = to_list_string(D0), + error_logger:info_msg("Searching for config file ~s " + "in directory ~s~n", [FileWildcard, D]), + case filelib:wildcard(FileWildcard, D) of + [] -> undefined; + [F|_] -> filename:join(D, F) + end; + (_, Acc) -> Acc + end, undefined, Dirs). + +to_list_string(S) when is_binary(S) -> + binary_to_list(S); +to_list_string(S) when is_list(S) -> + binary_to_list(iolist_to_binary(S)). + +do_read_config(F, Action, Mode) -> + case {filename:extension(F), Action} of + {".json", store} -> store(read_json(F, Mode), Mode); + {".yaml", store} -> store(read_yaml(F, Mode), Mode); + {".json", check} -> check_config_(catch read_json(F, Mode)); + {".yaml", check} -> check_config_(catch read_yaml(F, Mode)) + end. + +store(Vars, Mode) when is_map(Vars) -> + case pt_get_config() of + Map when map_size(Map) == 0 -> + check_validation([validate_(Vars)], + [Vars], set_config_value, report), + pt_set_config(Vars); + Map -> + ?LOG_DEBUG("Existing config, updating ...", []), + update_config(Vars, Map, Mode) + end; +store([Vars], Mode) when is_map(Vars) -> + store(Vars, Mode). + +check_config_({yamerl_exception, _StackTrace} = Error) -> + {error, Error}; +check_config_({'EXIT', Reason}) -> + ShortError = pp_error(Reason), + {error, ShortError}; +check_config_([Vars]) -> + {ok, {Vars, to_tree(Vars)}}. + +pp_error({validation_failed, _}) -> + validation_failed; +pp_error(Other) -> + Other. + +pp_error_({error, {schema_file_not_found, Schema}}, Mode) -> + error_format("Schema not found : ~s", [Schema], Mode); +pp_error_({error, [{data_invalid, _Schema, Type, Value, Pos}]}, Mode) -> + PosStr = pp_pos(Pos), + ValStr = pp_val(Value), + TypeStr = pp_type(Type), + case Mode of + check -> + io:format("Validation failed~n" + "Position: ~s~n" + "Value : ~s~n" + "Reason : ~s~n", + [PosStr, ValStr, TypeStr]); + report -> + error_format("Validation failed, Pos: ~s~n" + "Value: ~s~n" + "Reason: ~s", [PosStr, ValStr, TypeStr], Mode) + end; +pp_error_({error, [{schema_invalid, Section, Description}]}, Mode) -> + SchemaStr = schema_string(Section, Mode), + error_format("Reading schema failed~n" + "Section: ~n~s~n" + "Reason: ~p~n", [SchemaStr, Description], Mode). + +silent_as_report(silent) -> report; +silent_as_report(Mode ) -> Mode. + +schema_string(Schema, Mode) -> + JSONSchema = json:encode(Schema), + case Mode of + check -> json:format(JSONSchema, #{indent => 2}); + report -> JSONSchema + end. + +error_format(Fmt, Args, check) -> + io:format(Fmt, Args); +error_format(Fmt, Args, report) -> + Str = io_lib:format(Fmt, Args), + Parts = re:split(Str, <<"\n">>), + Out = iolist_to_binary( + [hd(Parts) | + [[" | ", P] || P <- tl(Parts)]]), + Out = re:replace(Str, <<"\n">>, <<" | ">>, [global, {return, binary}]), + ?LOG_ERROR("~s", [Out]). + +pp_pos([H | T]) -> + [to_string(H) | [pp_pos_(X) || X <- T]]. + +pp_pos_(I) when is_integer(I) -> ["[", integer_to_list(I), "]"]; +pp_pos_(S) when is_binary(S) -> ["/", S]. + +pp_val(I) when is_integer(I) -> integer_to_list(I); +pp_val(S) when is_binary(S) -> ["\"", S, "\""]; +pp_val(X) -> + try schema_string(X, report) + catch + error:_ -> + io_lib:fwrite("~w", [X]) + end. + +pp_type(data_invalid) -> "Data invalid"; +pp_type(missing_id_field) -> "Missing ID field"; +pp_type(missing_required_property) -> "Missing required property"; +pp_type(no_match ) -> "No match"; +pp_type(no_extra_properties_allowed) -> "No extra properties allowed"; +pp_type(no_extra_items_allowed) -> "No extra items allowed"; +pp_type(not_allowed) -> "Not allowed"; +pp_type(not_unique) -> "Not unique"; +pp_type(not_in_enum) -> "Not in enum"; +pp_type(not_in_range) -> "Not in range"; +pp_type(not_divisible) -> "Not divisible"; +pp_type(wrong_type) -> "Wrong type"; +pp_type(wrong_size) -> "Wrong size"; +pp_type(wrong_length) -> "Wrong length"; +pp_type(wrong_format) -> "Wrong format"; +pp_type(too_many_properties) -> "Too many properties"; +pp_type(too_few_properties) -> "Too few properties"; +pp_type(all_schemas_not_valid) -> "The 'allOf' requirement is not upheld"; +pp_type(any_schemas_not_valid) -> "The 'anyOf' requirement is not upheld"; +pp_type(not_multiple_of) -> "Not an instance of 'multipleOf'"; +pp_type(not_one_schema_valid) -> "The 'oneOf' requirement is not upheld"; +pp_type(not_schema_valid) -> "The 'not' requirement is not upheld"; +pp_type(wrong_not_schema) -> "Wrong not schema"; +pp_type(external) -> "External"; +pp_type(Other) -> io_lib:fwrite("~w", [Other]). + +to_tree(Vars) -> + to_tree_(expand_maps(Vars)). + +expand_maps(M) when is_map(M) -> + [{K, expand_maps(V)} || {K, V} <- maps:to_list(M)]; +expand_maps(L) when is_list(L) -> + [expand_maps(E) || E <- L]; +expand_maps(E) -> + E. + +to_tree_(L) when is_list(L) -> + lists:flatten([to_tree_(E) || E <- L]); +to_tree_({K, V}) -> + {K, to_tree_(V)}; +to_tree_(E) -> + E. + +silent_update_config(Map) -> + update_config(Map, _Notify = false, silent). + +update_config(Map) when is_map(Map) -> + update_config(Map, report). + +update_config(Map, Mode) when is_map(Map) -> + ConfigMap = pt_get_config(), + update_config(Map, ConfigMap, Mode). + +update_config(Map, ConfigMap, Mode) -> + Schema = pt_get_schema(), + ConfigMap1 = update_config_(Map, ConfigMap, Schema, Mode), + ?LOG_DEBUG("New config: ~p", [ConfigMap1]), + pt_set_config(ConfigMap1), + ok. + +export_config() -> + Config = pt_get_config(), + JSON = json:format(Config, #{indent => 2}), + TS = calendar:system_time_to_rfc3339(erlang:system_time(second)), + File = filename:join(setup:log_dir(), "user_config-" ++ TS ++ ".json"), + file:write_file(File, JSON). + +-spec delete_config_value(config_key()) -> boolean(). +delete_config_value(Key) when is_binary(Key) -> + delete_config_value([Key]); +delete_config_value(Path) when is_list(Path) -> + Config = pt_get_config(), + case delete_(Path, Config) of + Config1 when Config1 =/= Config -> + pt_set_config(Config1), + true; + _ -> + false + end. + +delete_([H], Config) when is_map_key(H, Config) -> + maps:remove(H, Config); +delete_([H|T], Map) when T =/= [], is_map_key(H, Map) -> + Map#{H := delete_(T, maps:get(H, Map))}; +delete_(_, C) -> + C. + +set_config_value(Path, Value) -> + ConfigMap = pt_get_config(), + NewConfig = set_config_value(Path, ConfigMap, Value), + check_validation([validate_(NewConfig)], + [NewConfig], set_config_value, report), + pt_set_config(NewConfig). + +set_config_value([K], Map, Value) when is_map(Map) -> + Map#{K => Value}; +set_config_value([H|T], Map, Value) when is_map(Map) -> + case maps:find(H, Map) of + {ok, Sub} when is_map(Sub) -> + Map#{H := set_config_value(T, Sub, Value)}; + _ -> + Map#{H => set_config_value(T, #{}, Value)} + end. + +%% Checks if a given config key (list of binary keys corresponding to the GM +%% config schema) is already configured. If not, the suggested value is used. +suggest_config(Key, Value) -> + case find_config(Key, [user_config]) of + {ok, _} -> + {error, already_configured}; + undefined -> + Map = kv_to_config_map(Key, Value), + update_config(Map), + ok + end. + +kv_to_config_map([H], V) -> + #{H => V}; +kv_to_config_map([H|T], V) -> + #{H => kv_to_config_map(T, V)}. + +update_config_(Map, _ConfigMap, Schema, Mode) when Mode =:= check; + Mode =:= silent; + Mode =:= report -> + NewConfig = gmconfig_schema_utils:update_config(Map), + %% NewConfig = update_map(Map, ConfigMap), + ?LOG_DEBUG("NewConfig = ~p", [NewConfig]), + %% Note: We must validate the *resulting* config, since some validation + %% steps will require the full structure (e.g. multiple required fields in + %% the original config, which should not have to be included in the update) + check_validation([validate_(NewConfig, Schema)], + [NewConfig], update_config, Mode), + NewConfig. + + +update_map(With, Map) when is_map(With), is_map(Map) -> + maps:fold( + fun(K, V, Acc) -> + case maps:find(K, Acc) of + {ok, Submap} when is_map(Submap) -> + Acc#{K => update_map(V, Submap)}; + {ok, _} -> + Acc#{K => V}; + error -> + Acc#{K => V} + end + end, Map, With). + +read_json(F, Mode) -> + validate( + try_decode(F, fun(F1) -> + json_consult(F1) + end, "JSON", Mode), F, Mode). + +json_consult(F) -> + case setup_file:read_file(F) of + {ok, Bin} -> + [json_decode(Bin)]; + {error, Reason} -> + ?LOG_ERROR("Read error ~s - ~p", [F, Reason]), + error({read_error, F, Reason}) + end. + +json_decode(Bin) -> + case json_decode_(Bin) of + {ok, Value} -> + Value; + {error, Reason} -> + ?LOG_ERROR("CAUGHT: ~p", [Reason]), + error(Reason) + end. + +json_decode_(Bin) -> + case zj:binary_decode(Bin) of + {ok, _} = Ok -> + Ok; + {error, _Parsed, Remainder} -> + {error, {json_decode_error, string_slice(Remainder)}} + end. + +-define(SliceSz, 80). +string_slice(B) -> + case size(B) of + Sz when Sz > ?SliceSz -> + Sl = string:slice(B, 0, ?SliceSz - 4), + <>; + _ -> + B + end. + +read_yaml(F, Mode) -> + validate( + try_decode( + F, + fun(F1) -> + yamerl:decode_file(F1, [{str_node_as_binary, true}, + {map_node_format, map}]) + end, "YAML", Mode), + F, Mode). + +try_decode(F, DecF, Fmt, Mode) -> + try DecF(F) + catch + error:E -> + error_msg(Mode, "Error reading ~s file: ~s~n", [Fmt, F]), + erlang:error(E) + end. + +validate(JSON, F, Mode) when is_list(JSON) -> + check_validation([validate_(J) || J <- JSON], JSON, F, Mode). +%% validate(JSON, F, Mode) when is_map(JSON) -> +%% validate([JSON], F, Mode). + +vinfo(Mode, Res, F) -> + case Res of + {ok, _} -> + info_report(Mode, [{validation, F}, + {result, Res}]); + {error, Errors} -> + Mode1 = silent_as_report(Mode), + [pp_error_(E, Mode1) || E <- Errors], + ok + end. + +info_report(report, Info) -> + error_logger:info_report(Info); +info_report(_, _) -> + ok. + +info_msg(report, Fmt, Args) -> + error_logger:info_msg(Fmt, Args); +info_msg(_, _,_ ) -> + ok. + +error_msg(report, Fmt, Args) -> + error_logger:error_msg(Fmt, Args); +error_msg(_, _, _) -> + ok. + +check_validation(Res, _JSON, F, Mode) -> + case lists:foldr( + fun({ok, M}, {Ok,Err}) when is_map(M) -> + {[M|Ok], Err}; + (Other, {Ok,Err}) -> + {Ok, [Other|Err]} + end, {[], []}, Res) of + {Ok, []} -> + vinfo(Mode, {ok, Ok}, F), + Ok; + {_, Errors} -> + vinfo(Mode, {error, Errors}, F), + erlang:error(validation_failed) + end. + +validate_(JSON) -> + Schema = ensure_schema_loaded(), + validate_(JSON, Schema). + +validate_(JSON, Schema) -> + _ = gmconfig_schema_utils:valid(JSON, Schema), + {ok, JSON}. + +load_main_config_schema() -> + _ = load_schema(), + ?LOG_INFO("Loaded config schema", []), + ok. + +load_system_defaults() -> + load_system_defaults(report). + +load_system_defaults(Mode) -> + SystemSuffix = get_system_suffix(), + Fname = "gajumaru_defaults" ++ SystemSuffix ++ ".{yaml,json}", + case search_for_config_file([setup:data_dir()], Fname) of + undefined -> + ok; + ConfigFile -> + ?LOG_DEBUG("Loading system defaults from ~s", [ConfigFile]), + load_config_file(ConfigFile, Mode) + end. + +get_system_suffix() -> + case init:get_argument('-system') of + error -> + Pfx = os_env_prefix(), + case os:getenv(Pfx ++ "_SYSTEM") of + false -> + ""; + Suffix -> + "_" ++ Suffix + end; + {ok, [[Suffix]]} -> + "_" ++ Suffix + end. + +ensure_schema_loaded() -> + case pt_get_schema(undefined) of + undefined -> + Res = load_schema(), + %% ?LOG_INFO("Schema Res = ~p", [Res]), + Res; + S -> + S + end. + +load_schema() -> + JSON = gmconfig_schema(), + Schema = json_decode(JSON), + pt_set_schema(Schema), + Schema. + +gmconfig_schema() -> + case gmconfig_env(schema, #{}) of + File when is_list(File) -> + json_consult(File); + Json when is_map(Json) -> + Json; + F when is_function(F, 0) -> + F() + end. diff --git a/src/gmconfig_schema_utils.erl b/src/gmconfig_schema_utils.erl new file mode 100644 index 0000000..105c589 --- /dev/null +++ b/src/gmconfig_schema_utils.erl @@ -0,0 +1,959 @@ +%% -*- mode: erlang; erlang-indent-level: 4; indent-tabs-mode: nil -*- +-module(gmconfig_schema_utils). + + +-export([get_config/0, + set_config/1, + get_schema/0, + get_schema/1, %% (Default) + set_schema/1, + schema/1, %% (Path) + schema/2, %% (Path, Schema) + schema/3, %% (Path, Schema, Opts) + clear/0, + expand_schema/1]). + +-export([ update_config/1 %% (Map) -> ok + , merge/2 %% (Item1, Item2) -> Item3 + , merge/3 %% (Item1, Item2, Schema) -> Item3 + , valid/1 %% (Item) -> Item | error() + , valid/2 %% (Item, Schema) -> Item | error() + ]). +-export([in_properties/2]). + +-type json_string() :: binary(). +-type json_int() :: integer(). +-type json_num() :: number(). +-type json_null() :: 'null'. +-type json_bool() :: boolean(). +-type json_simple() :: json_null() | json_string() | json_int() | json_num() + | json_bool(). +-type json_object() :: #{json_string() => json()}. +-type json_array() :: [json()]. +-type json() :: json_simple() | json_array() | json_object(). + +-type json_type() :: null | boolean | string | number | integer + | object | array. + +-type schema() :: json(). + +-record(st, { s :: schema() %% schema + , r :: schema() %% root schema + , p = [] + , a = [] %% annotations + , v :: json() | undefined %% value + }). + +-type st() :: #st{}. + + +-spec set_schema(schema()) -> ok. +set_schema(Schema) -> + persistent_term:put({?MODULE, '$schema'}, Schema). + +-spec get_config() -> json(). +get_config() -> + persistent_term:get({?MODULE, '$config'}, #{}). + +-spec set_config(schema()) -> ok. +set_config(Config) -> + persistent_term:put({?MODULE, '$config'}, Config). + +-spec get_schema() -> schema(). +get_schema() -> + persistent_term:get({?MODULE, '$schema'}). + +-spec get_schema(Default) -> schema() | Default. +get_schema(Default) -> + persistent_term:get({?MODULE, '$schema'}, Default). + +clear() -> + persistent_term:erase({?MODULE,'$schema'}), + persistent_term:erase({?MODULE,'$config'}), + ok. + +-spec update_config(json()) -> json(). +update_config(Cfg) -> + OldCfg = get_config(), + Schema = get_schema(), + Res = merge(Cfg, OldCfg, #st{s = Schema, + r = Schema }), + set_config(Res), + Res. + +-spec merge(json(), json()) -> json(). +merge(A, B) -> + merge(A, B, get_schema()). + +-spec merge(json(), json(), schema() | st()) -> json(). +merge(A, B, #st{} = St) -> + merge_(A, B, St); +merge(A, B, Schema) -> + merge_(A, B, #st{s = Schema, r = Schema}). + +%% Neither the JSON spec or the JSON-Schema spec are very helpful +%% regarding what takes precedence if dynamically evaluated parts +%% conflict with the base schema. The jsonschemavalidator.net version +%% is actually non-deterministic in this regard. So let's just pick one +%% approach that seems sensible. +%% +-spec schema_prop(Prop, State, SubSchemas, Default) -> json() + when Prop :: json_string() + , State :: st() + , SubSchemas :: [st()] + , Default :: json(). +schema_prop(P, Schema, Ss, Default) -> + case any_schema_prop(P, Schema, Ss) of + {ok, V} -> + V; + error -> + Default + end. + +any_schema_prop(P, S0, [S|Ss]) -> + case schema_prop_find(P, S) of + {ok, _} = Ok -> Ok; + error -> + any_schema_prop(P, S0, Ss) + end; +any_schema_prop(P, S, []) -> + schema_prop_find(P, S). + +schema_prop_find(P, #st{s = S, r = RS}) when is_map(S) -> + case maps:find(P, S) of + {ok, #{<<"$ref">> := Sub} = M} when map_size(M) == 1 -> + D = expand_ref(Sub, RS), + {ok, D}; + Other -> Other + end; +%% schema_find(P, #st{s = S}) when is_map(S) -> +%% maps:find(P, S); +schema_prop_find(_, _) -> + error. + +schema_get(P, #st{s = S}, Default) when is_map(S) -> + maps:get(P, S, Default); +schema_get(_, _, Default) -> + Default. + +%% let us pattern-match on a schema map +%% all schemas that are not a map are converted to the empty map. +schema_map(Map) when is_map(Map) -> Map; +schema_map(_) -> #{}. + +-spec merge_(json(), json(), st()) -> json(). +merge_(A, B, #st{} = St) -> + Ss = schemas_from_dynamic_eval(A, St), + case schema_prop(<<"readOnly">>, St, Ss, false) of + true when B == null -> + valid(A, St); + true -> + fail(read_only, St); + false -> + merge_(A, B, St, Ss) + end. + +merge_(A, B, St, Ss) -> + Type = get_type(St, Ss, A), + case Type of + object -> + update_object(A, B, St, Ss); + _ -> + valid(A, Type, St, Ss) + end. + +update_semantics(A, St, Ss) -> + case maps:find(<<"$updateSemantics">>, schema_map(A)) of + {ok, _} = Ok -> + {Ok, object}; + error -> + {any_schema_prop(<<"updateSemantics">>, St, Ss), schema} + end. + +remove_semantic_props(O, Sem, Where) when is_map(O) -> + Recursive = case {Sem, Where} of + {{ok, <<"replace">>}, object} -> true; + _ -> false + end, + remove_props(O, [<<"$updateSemantics">>], Recursive); +remove_semantic_props(Other, _, _) -> + Other. + +remove_props(O, Keys, Recurse) when is_map(O) -> + if Recurse -> + maps:map(fun(_, V) -> + remove_props(V, Keys, Recurse) + end, maps:without(Keys, O)); + true -> + maps:without(Keys, O) + end; +remove_props(Other, _, _) -> + Other. + +get_type(#st{} = St, Value) -> + Ss = schemas_from_dynamic_eval(Value, St), + get_type(St, Ss, Value). + +get_type(#st{} = St, Ss, Value) -> + case any_schema_prop(<<"type">>, St, Ss) of + {ok, TBin} -> + select_type(TBin, Value, St); + error -> + try infer_type(Value) + catch + _:_ -> + fail(invalid, St) + end + end. + +select_type(TBin, Value, St) -> + case TBin of + <<"null">> -> null; + <<"boolean">> -> boolean; + <<"object">> -> object; + <<"array">> -> array; + <<"number">> -> number; + <<"integer">> -> integer; + <<"string">> -> string; + Types when is_list(Types) -> + pick_a_type(Types, Value, St); + _ -> + fail(invalid_schema, St) + end. + +infer_type(V) -> + if is_map(V) -> object; + is_integer(V) -> integer; + is_number(V) -> number; + is_boolean(V) -> boolean; + is_binary(V) -> string; + is_list(V) -> array; + V == null -> null + end. + +-spec pick_a_type([json_string()], json(), st()) -> json_type(). +pick_a_type([H|T], Value, St) -> + case H of + <<"object">> when is_map(Value) -> object; + <<"array">> when is_list(Value) -> array; + <<"number">> when is_number(Value) -> number; + <<"integer">> when is_integer(Value) -> integer; + <<"string">> when is_binary(Value) -> string; + <<"boolean">> when is_boolean(Value) -> boolean; + _ -> pick_a_type(T, Value, St) + end; +pick_a_type([], Value, St) -> + fail(wrong_type, St#st{v = Value}). + +%% Updating objects is the tricky bit. We need to check for anyOf, etc. +%% since we can't simply join elements from disjunct schemas. +-spec update_object(json(), json_object(), st(), [st()]) -> json_object(). +update_object(A0, B, St, Ss) -> + {Sem, Where} = update_semantics(A0, St, Ss), + A = remove_semantic_props(A0, Sem, Where), + case Sem of + {ok, <<"replace">>} -> + valid(A, object, St, Ss); + {ok, <<"merge">>} -> + update_object_(A, B, St, Ss); + {ok, <<"suggest">>} -> + if B == null; map_size(B) == 0 -> + valid(A, object, St, Ss); + true -> + update_object_(A, B, St, Ss) + end; + error -> + if is_map(A), is_map(B) -> + update_object_(A, B, St, Ss); + true -> + valid(A, object, St, Ss) + end + end. + +update_object_(New, Old, St, Ss) -> + Dyn = acc_props(Ss), + SsOld = schemas_from_dynamic_eval(Old, St), + PropSchemas = [{P, prop_schema(P, Dyn, St)} || P <- maps:keys(New)], + try do_update_object(New, Old, St, PropSchemas) + catch + error:E when Ss =/= SsOld -> + %% Merging failed. Try replacing. If this fails, + %% go with the error raised by the first attempt. + try valid(New, object, St, Ss) + catch + error:_ -> + error(E) + end + end. + +do_update_object(New, Old, St, PropSchemas) -> + Res = lists:foldl( + fun({P, S}, Acc) -> + S1 = push_path(P, S), + V = maps:get(P, New), + case maps:find(P, Old) of + {ok, OldV} -> + Acc#{P => merge(V, OldV, S1)}; + error -> + Acc#{P => valid(V, S1)} + end + end, Old, PropSchemas), + valid(Res, object, St). + + +valid(V) -> + valid(V, get_schema()). + +valid(V, #st{} = St) -> + valid_(V, St#st{v = V}); +valid(V, Schema) -> + valid(V, #st{p = [], s = Schema, r = Schema, v = V}). + +valid_(V, #st{s = true}) -> V; +valid_(_, #st{s = false} = St) -> fail(invalid, St); +valid_(V, St) -> + Type = get_type(St, V), + valid(V, Type, St). + +valid(V, _, #st{s = true}) -> V; +valid(_, _, #st{s = false} = St) -> fail(invalid, St); +valid(V, Type, St) -> + %% We run dynamic eval to find conditional parts of the schema. + %% we keep these in a separate list. + Ss = schemas_from_dynamic_eval(V, St), + valid(V, Type, St, Ss). + +valid(V, Type, St, Ss) -> + valid_const(V, Type, St, Ss), + valid_enum(V, Type, St, Ss), + %% Dynamic eval returns a list of matching schemas + %% We pass them along as they may contain properties, + %% but `V` has already been validated against them. + case Type of + object -> valid_object(V, push_path(object, St), Ss); + integer -> valid_number(V, integer, push_path(integer, St), Ss); + number -> valid_number(V, number, push_path(number, St), Ss); + string -> valid_string(V, push_path(string, St), Ss); + array -> valid_array(V, push_path(array, St), Ss); + boolean -> valid_boolean(V, push_path(boolean, St), Ss); + null -> valid_null(V, push_path(null, St), Ss) + end. + +split_valid(V, St, Ss) -> + split_valid(V, 0, St, Ss, [], []). +split_valid(V, Ix, St, [S|Ss], Yes, No) -> + try valid(V, push_path(Ix, St#st{s = S})) of + _ -> split_valid(V, Ix+1, St, Ss, [{Ix,S}|Yes], No) + catch + error:Err -> + split_valid(V, Ix+1, St, Ss, Yes, [{Ix, Err}|No]) + end; +split_valid(_, _, _, [], Yes, No) -> + {lists:reverse(Yes), lists:reverse(No)}. + +-spec valid_const(any(), json_type(), st(), [st()]) -> json(). +valid_const(V, Type, St, Ss) -> + case any_schema_prop(<<"const">>, St, Ss) of + error -> V; + {ok, C} -> + case is_equal(Type, V, C) of + true -> ok; + false -> + fail(not_in_enum, push_path(const, St)) + end + end. + +valid_enum(V, Type, St, Ss) -> + case any_schema_prop(<<"enum">>, St, Ss) of + error -> V; + {ok, En} -> + case lists:any(fun(X) -> + is_equal(Type, V, X) + end, En) of + true -> V; + false -> + fail(not_in_enum, push_path(enum, St)) + end + end. + +-spec valid_object(any(), st(), [st()]) -> json_object(). +valid_object(O, #st{s = true}, []) -> O; +valid_object(_, #st{s = false} = St, []) -> fail(invalid, St); +valid_object(O, St, Ss) when is_map(O) -> + Dyn = acc_props(Ss), + PropSchemas = [{P, prop_schema(P, Dyn, St)} || P <- maps:keys(O)], + MinP = schema_prop(<<"minProperties">>, St, Ss, 0), + OSz = length(PropSchemas), + MaxP = schema_prop(<<"maxProperties">>, St, Ss, OSz), + assert(fun(Sz) -> Sz >= MinP end, OSz, + min_properties, push_path(min_properties, St)), + assert(fun(Sz) -> Sz =< MaxP end, OSz, + max_properties, push_path(max_properties, St)), + Required = schema_prop(<<"required">>, St, Ss, []), + case [P || P <- Required, not lists:keymember(P, 1, PropSchemas)] of + [] -> ok; + RPs -> fail(required, add_anno(RPs, push_path(required, St))) + end, + lists:foreach( + fun({P, #st{} = S}) -> + valid(maps:get(P, O), push_path(P, S)) + end, PropSchemas), + O; +valid_object(_, St, _) -> + fail(wrong_type, St). + +-spec valid_boolean(json(), st(), [st()]) -> json_bool(). +valid_boolean(V, #st{s = true}, []) -> V; +valid_boolean(_, #st{s = false} = St, []) -> fail(invalid, St); +valid_boolean(V, St, _) -> + assert_type(fun is_boolean/1, V, St), + V. + +valid_null(N, #st{s = true}, []) -> N; +valid_null(_, #st{s = false} = St, []) -> fail(invalid, St); +valid_null(null, #st{s = null}, _) -> + null; +valid_null(_, St, _) -> + fail(wrong_type, St). + + +valid_string(S, #st{s = true}, []) -> S; +valid_string(_, #st{s = false} = St, []) -> fail(invalid, St); +valid_string(S, St, Ss) when is_binary(S) -> + P = schema_prop(<<"pattern">>, St, Ss, <<>>), + try re:run(S, P, []) of + {match, _} -> ok; + nomatch -> fail(no_match, St) + catch + error:_ -> fail(no_match, St) + end, + Sz = byte_size(S), + Lmin = schema_prop(<<"minLength">>, St, Ss, 0), + Lmax = schema_prop(<<"maxLength">>, St, Ss, Sz), + assert_min(Sz, Lmin, min_length, St), + assert_max(Sz, Lmax, max_length, St), + S; +valid_string(_, St, _) -> + fail(wrong_type, St). + + +valid_number(N, _, #st{s = true}, []) -> N; +valid_number(_, _, #st{s = false} = St, []) -> fail(invalid, St); +valid_number(I, Sub, St, Ss) when is_number(I) -> + [assert_type(fun is_integer/1, I, St) || Sub == integer], + case any_schema_prop(<<"multipleOf">>, St, Ss) of + error -> ok; + {ok, X} when is_integer(X), X > 0 -> + %% The spec says: + %% + %% "6.2.1. multipleOf + %% The value of "multipleOf" MUST be a number, strictly greater than 0. + %% + %% A numeric instance is valid only if division by + %% this keyword's value results in an integer." + %% + %% Not sure how to implement (or use!) this reliably without + %% forcing both I and X to be integers, so this is what we'll do. + assert_schema(fun pos_int/1, X, push_path(multipleOf, St)), + + St1 = add_anno(X, push_path(multipleOf, St)), + try I rem X of + 0 -> ok; + _ -> fail(not_a_multiple, St1) + catch + _:_ -> + fail(not_a_multiple, St1) + end + end, + Min = schema_prop(<<"minimum">>, St, Ss, I), + Max = schema_prop(<<"maximum">>, St, Ss, I), + test_range('>=', Max, I, add_anno(Max, push_path(maximum, St))), + test_range('=<', Min, I, add_anno(Min, push_path(minimum, St))), + EMin = schema_prop(<<"exclusiveMinimum">>, St, Ss, I-1), + EMax = schema_prop(<<"exclusiveMaximum">>, St, Ss, I+1), + test_range('>', EMax, I, add_anno(EMax, push_path(exclusiveMaximum, St))), + test_range('<', EMin, I, add_anno(EMin, push_path(exclusiveMinimum, St))), + I; +valid_number(_, _, St, _) -> + fail(wrong_type, St). + +valid_array(A, #st{s = true}, []) -> A; +valid_array(_, #st{s = false} = St, []) -> fail(invalid, St); +valid_array(A, #st{} = St, Ss) when is_list(A) -> + Len = length(A), + MaxIs = schema_prop(<<"maxItems">>, St, Ss, Len), + MinIs = schema_prop(<<"minItems">>, St, Ss, 0), + assert_schema(fun non_neg_int/1, MaxIs, push_path(maxItems, St)), + assert_schema(fun non_neg_int/1, MinIs, push_path(minItems, St)), + test_range('>=', MaxIs, Len, add_anno(MaxIs, push_path(maxItems, St))), + test_range('=<', MinIs, Len, add_anno(MinIs, push_path(minItems, St))), + Uniq = schema_prop(<<"uniqueItems">>, St, Ss, false), + assert_schema(fun is_boolean/1, Uniq, push_path(uniqueItems, St)), + [assert(fun uniqueItems/1, A, not_unique, push_path(uniqueItems, St)) || Uniq], + PfxItems = any_schema_prop(<<"prefixItems">>, St, Ss), + case any_schema_prop(<<"items">>, St, Ss) of + {ok, Is} -> + case PfxItems of + {ok, PfxIs} -> + assert_schema(fun is_list/1, PfxIs, push_path(prefixItems, St)), + check_prefix_items( + PfxIs, A, Is, push_path(prefixItems, St#st{s = PfxIs})); + error -> + check_items(A, push_path(items, St#st{s = Is})) + end; + error -> + case PfxItems of + {ok, PfxIs} -> + assert_schema(fun is_list/1, PfxIs, push_path(prefixItems, St)), + check_prefix_items( + PfxIs, A, true, push_path(prefixItems, St#st{s = PfxIs})); + error -> + ok + end + end, + case any_schema_prop(<<"contains">>, St, Ss) of + {ok, Cs} -> + check_contains(A, push_path(contains, St#st{s = Cs}), + schema_prop(<<"minContains">>, St, Ss, null), + schema_prop(<<"maxContains">>, St, Ss, null)); + error -> + ok + end, + A; +valid_array(_, St, _) -> + fail(wrong_type, St). + +test_range(Op, X, I, St) -> + assert_schema(fun is_number/1, X, St), + try erlang:Op(X, I) of + true -> ok; + false -> fail(not_in_range, St) + catch + error:_ -> + fail(not_in_range, St) + end. + +-spec check_prefix_items([schema()], [json()], schema(), st()) -> ok. +check_prefix_items(Is, A, Items, St) when is_list(Is), is_list(A) -> + check_prefix_items(Is, A, 0, Items, St); +check_prefix_items(_, _, _, St) -> + fail(invalid, St). + +check_prefix_items([I|Is], [H|T], Ix, Items, St) -> + _ = valid(H, push_path(Ix, St#st{s = I})), + check_prefix_items(Is, T, Ix+1, Items, St); +check_prefix_items(_, [], _, _, _) -> + ok; +check_prefix_items([], Rest, Ix, Items, St) -> + check_items(Rest, Ix, push_path(items, St#st{s = Items})). + +check_items(A, St) -> + check_items(A, 0, St). + +check_items([H|T], Ix, St) -> + _ = valid(H, push_path(Ix, St)), + check_items(T, Ix+1, St); +check_items([], _, _) -> + ok. + +check_contains(A, St, Min, Max) -> + check_contains(A, 0, St, Min, Max, [], []). + +check_contains([H|T], Ix, St, Min, Max, Yes, No) -> + try valid(H, push_path(Ix, St)) of + _ -> check_contains(T, Ix+1, St, Min, Max, [Ix|Yes], No) + catch + error:_ -> + check_contains(T, Ix+1, St, Min, Max, Yes, [Ix|No]) + end; +check_contains([], _, St, Min, Max, Yes, _No) -> + case {Yes, Min, Max} of + {[_|_], null, null} -> + ok; + {[], null, _} -> + fail(contains, St); + _ -> + YesLen = length(Yes), + if is_integer(Max) -> + _ = valid(YesLen, + push_path(max, + St#st{s = #{<<"maximum">> => Max}})); + true -> ok + end, + if is_integer(Min) -> + _ = valid(YesLen, + push_path(min, + St#st{s = #{<<"minimum">> => Min}})); + true -> + ok + end + end. + +prop_schema(P, Dyn, St) -> + try_props([fun() -> in_dyn(P, Dyn, St) end, + fun() -> in_properties(P, St) end, + fun() -> in_patternprops(P, St) end, + fun() -> in_additionalprops(P, St) end, + fun() -> unevaluated_or_true(St) end + ]). + +try_props([F|Fs]) -> + case F() of + {ok, S} -> S; + error -> + try_props(Fs) + end; +try_props([]) -> + %% If we don't find anything, validation doesn't fail. + %% (empty schema validates everything) + true. + +in_dyn(P, Dyn, St) -> + case maps:find(P, Dyn) of + {ok, S1} -> + {ok, add_anno(dynamic_eval, St#st{s = S1})}; + error -> + error + end. + +in_properties(P, St) -> + case maps:find(P, schema_get(<<"properties">>, St, #{})) of + {ok, S1} -> + {ok, add_anno(properties, St#st{s = S1})}; + error -> + error + end. + +in_patternprops(P, S) -> + case any_pattern(schema_get(<<"patternProperties">>, S, #{}), P) of + {ok, S1} -> + {ok, add_anno(patternProperties, S#st{s = S1})}; + error -> + error + end. + +in_additionalprops(_, St) -> + case schema_prop_find(<<"additionalProperties">>, St) of + error -> error; + {ok, S} -> + {ok, add_anno(additionalProperties, St#st{s = S})} + end. + +unevaluated_or_true(St) -> + case schema_prop_find(<<"unevaluatedProperties">>, St) of + error -> {ok, add_anno(no_unevaluated, St#st{s = true})}; + {ok, S} -> + {ok, add_anno(unevaluated, St#st{s = S})} + end. + +any_pattern(Ps, P) -> + I = maps:iterator(Ps), + any_pattern_(maps:next(I), P). + +any_pattern_(none, _) -> + error; +any_pattern_({Pat, Schema, I}, P) -> + case re:run(P, Pat, []) of + {match, _} -> + {ok, Schema}; + nomatch -> + any_pattern_(maps:next(I), P) + end. + +schemas_from_dynamic_eval(Obj, #st{s = Schema} = St) -> + SMap = schema_map(Schema), + maps:fold( + fun(<<"allOf">>, Ss, Acc) -> + St1 = push_path(allOf, St), + case split_valid(Obj, St, Ss) of + {ValidSs, []} -> + Acc ++ [St1#st{s = S} || {_, S} <- ValidSs]; + {_, FailedSs} -> + fail(failing_schemas, add_anno(FailedSs, St1)) + end; + (<<"anyOf">>, Ss, Acc) -> + St1 = push_path(anyOf, St), + case split_valid(Obj, St1, Ss) of + {[_|_] = ValidSs, _} -> + Acc ++ [St1#st{s = S} || {_, S} <- ValidSs]; + {[], FailedSs} -> + fail(no_matching_schema, add_anno(FailedSs, St1)) + end; + (<<"oneOf">>, Ss, Acc) -> + St1 = push_path(oneOf, St), + case split_valid(Obj, St1, Ss) of + {[{_, S}], _} -> + Acc ++ [St1#st{s = S}]; + {[_|_] = MoreValid, _} -> + ValidIxs = [I || {I,_} <- MoreValid], + fail(more_than_one, add_anno({valid, ValidIxs}, St1)); + {[], _} -> + fail(no_matching_schema, St1) + end; + (<<"if">>, S, Acc) -> + St1 = push_path('if', St), + try valid(Obj, St1#st{s = S}) of + _ -> + Sthen = + push_path( + 'then', St1#st{s = maps:get(<<"then">>, SMap, #{})}), + _ = valid(Obj, Sthen), + Acc ++ [Sthen] + catch + error:_ -> + Selse = + push_path( + 'else', St1#st{s = maps:get(<<"else">>, SMap, #{})}), + _ = valid(Obj, Selse), + Acc ++ [Selse] + end; + (<<"not">>, S, Acc) -> + Snot = push_path('not', St#st{s = S}), + try valid(Obj, Snot) of + _ -> fail(invalid, Snot) + catch + error:_ -> + Acc + end; + (_, _, Acc) -> Acc + end, [], SMap). + +acc_props(Ss) -> + lists:foldl( + fun(#st{} = S, Acc1) -> + case schema_prop_find(<<"properties">>, S) of + error -> Acc1; + {ok, Ps} -> + maps:merge(Acc1, Ps) + end + end, #{}, Ss). + +push_path(Ps, #st{p = P0} = St) when is_list(Ps) -> + %% Assume Ps is in reverse order + St#st{p = Ps ++ P0}; +push_path(P, #st{p = P0} = St) -> + St#st{p = [P|P0]}. + +add_anno(A, #st{a = Ann} = St) -> + St#st{a = [A|Ann]}. + +assert_schema(F, X, St) -> + assert(F, X, invalid_schema, St). + +assert_type(F, X, St) -> + assert(F, X, wrong_type, St). + +fail(Error, #st{p = Path0, a = Ann, v = Val, s = S}) -> + error(#{e => Error, p => lists:reverse(Path0), + a => Ann, v => Val, s => S}). + +is_equal(_Type, A, B) -> + A == B. + +assert(F, X, Err, #st{} = St) when is_function(F, 1) -> + assert(fun() -> F(X) end, Err, St). + +assert(F, Err, St) when is_function(F, 0) -> + try F() of + true -> ok; + false -> fail(Err, St) + catch + error:_ -> + fail(Err, St) + end. + +assert_min(V, Min, EInfo, St) -> + assert(fun(X) -> X >= Min end, V, EInfo, St). + +assert_max(V, Min, EInfo, St) -> + assert(fun(X) -> X =< Min end, V, EInfo, St). + +-spec non_neg_int(any()) -> boolean(). +non_neg_int(I) -> + is_integer(I) andalso I >= 0. + +-spec pos_int(any()) -> boolean(). +pos_int(I) -> + is_integer(I) andalso I > 0. + +uniqueItems(L) -> + USorted = lists:usort(L), + [] == L -- USorted. + +expand_schema(S0) -> + S = expand_definitions(S0), + expand_schema(S, S). + +expand_definitions(#{<<"definitions">> := D} = S) -> + S#{<<"definitions">> := expand_schema(D, S)}. + +expand_schema(S, S0) when is_map(S) -> + %% https://json-schema.org/understanding-json-schema/structuring#dollarref + %% When $id is used in a subschema, it indicates an embedded schema. + %% The identifier for the embedded schema is the value of $id + %%resolved against the Base URI of the schema it appears in. + %% A schema document that includes embedded schemas is called a + %% Compound Schema Document. Each schema with an $id in a + %% Compound Schema Document is called a Schema Resource. + S1 = case maps:find(<<"$id">>, S) of + {ok, _} -> + S; + error -> + S0 + end, + maps:fold(fun(K, V, Acc) -> expand_schema_(K, V, Acc, S1) end, #{}, S); +expand_schema([#{<<"$ref">> := Path} = V], S0) when map_size(V) == 1 -> + D = expand_ref(Path, S0), + [D]; +expand_schema(S, S0) when is_list(S) -> + [expand_schema(E, S0) || E <- S]; +expand_schema(S, _) -> + S. + +expand_schema_(K, #{<<"$ref">> := Path} = V, Acc, S0) when map_size(V) == 1 -> + D = expand_ref(Path, S0), + Acc#{K => D}; +expand_schema_(K, V, Acc, S0) -> + Acc#{K => expand_schema(V, S0)}. + +expand_ref(R, _, #{follow_refs := false}) -> + R; +expand_ref(R, S, _) -> + expand_ref(R, S). + +expand_ref(<<"#">>, S) -> + %% The $ref keyword may be used to create recursive schemas that refer to themselves. + %% This done by using `{"$ref" : "#"}` + S; +expand_ref(<<"#/", Path/binary>>, S) -> + Key = filename:split(Path), + case schema(Key, S, #{follow_refs => false}) of + {ok, #{<<"$ref">> := _}} -> + %% a $ref referring to another $ref could cause an infinite loop + %% in the resolver, and is explicitly disallowed. + %% + %% Example: + %% { + %% "$defs": { + %% "alice": { "$ref": "#/$defs/bob" }, + %% "bob": { "$ref": "#/$defs/alice" } + %% } + %% } + %% + error(nested_references); + {ok, Def} -> + Def; + undefined -> + error(unknown_ref, [Path]) + end. + +schema(Path) -> + schema(Path, get_schema()). + +schema(Path, Schema) -> + schema(Path, Schema, #{follow_refs => true}). + +schema(Path, Schema, Opts) -> + schema_(Path, Schema, Schema, Opts). + +schema_([H|T], Schema, RootSchema0, Opts) -> + RootSchema = set_rootschema(Schema, RootSchema0), + case Schema of + #{<<"$schema">> := _, <<"properties">> := #{H := Tree}} -> + schema_find(T, Tree, RootSchema, Opts); + #{'$schema' := _, properties := #{H := Tree}} -> + schema_find(T, Tree, RootSchema, Opts); + #{H := Tree} -> + schema_find(T, Tree, RootSchema, Opts); + _ -> + undefined + end; +schema_([], Schema, _, _) -> + {ok, Schema}; +schema_(Key, Schema, RootSchema, Opts) -> + case maps:find(Key, Schema) of + {ok, #{<<"$ref">> := R} = S1} when map_size(S1) == 1 -> + case maps:get(follow_refs, Opts, true) of + true -> + D = expand_ref(R, RootSchema, Opts), + {ok, D}; + false -> + {ok, S1} + end; + {ok, _} = Ok -> Ok; + error -> undefined + end. + +schema_find([H|T], S, RS, Opts) -> + case S of + #{<<"properties">> := #{H := Tree}} -> + schema_find(T, Tree, set_rootschema(Tree, RS), Opts); + #{<<"patternProperties">> := Tree} -> + schema_match(H, Tree, T, RS, Opts); + #{properties := #{H := Tree}} -> + schema_find(T, Tree, set_rootschema(Tree, RS), Opts); + #{patternProperties := Tree} -> + schema_match(H, Tree, T, RS, Opts); + Map when is_map(Map) -> + case maps:find(H, Map) of + {ok, #{<<"$ref">> := R} = M} when map_size(M) == 1 -> + case maps:get(follow_refs, Opts, true) of + true -> + D = expand_ref(R, RS, Opts), + schema_find(T, D, RS, Opts); + false -> + schema_find(T, M, RS, Opts) + end; + {ok, Tree} -> + schema_find(T, Tree, RS, Opts); + error -> + undefined + end; + _ -> + schema_inspect([H|T], S, RS, Opts) + end; +schema_find([], S, _, _) -> + {ok, S}. + +schema_match(P, Tree, T, RS, Opts) -> + case any_pattern(Tree, P) of + {ok, SubTree} -> + schema_find(T, SubTree, set_rootschema(SubTree, RS), Opts); + error -> + undefined + end. + +set_rootschema(#{<<"$id">> := _} = S, _) -> + S; +set_rootschema(_, S) -> + S. + +schema_inspect([H|T], S, RS, Opts) -> + case S of + #{<<"properties">> := #{<<"oneOf">> := Alts}} -> + case map_list_search(H, Alts) of + false -> + undefined; + #{H := Tree} -> + schema_find(T, Tree, set_rootschema(Tree, RS), Opts) + end; + #{properties := #{oneOf := Alts}} -> + case map_list_search(H, Alts) of + false -> + undefined; + #{H := Tree} -> + schema_find(T, Tree, set_rootschema(Tree, RS), Opts) + end; + _ -> + undefined + end. + +map_list_search(K, [H|T]) -> + case maps:is_key(K, H) of + true -> + H; + false -> + map_list_search(K, T) + end; +map_list_search(_, []) -> + false.